はじめに
標準 Pascal に準拠した Pascal-P5 を使う方法や、ビルドする方法についての記事を以前書きました。
Delphi でコンパイルする方法が書いてなかったのは、Pascal-P5 のソースコードは標準 Pascal に準拠したコンパイラでしかコンパイルできないためです。移植するために致命的だと思われたのは、Delphi にはバッファ変数のサポート (ファイルポインタを進めずに 1 文字読む) がない事でした。
ところが、ひょんな事からバッファ変数の代替機能を作れる事が判明したため、Delphi でコンパイルできるように Pascal-P5 のソースコードを改変してみようという事になりました。
改変
使うのは Pascal-P5 バージョン 1.3 のソースコードです。もう既に DL できないようだったので、私のサイトでアーカイブをミラーしています。
アーカイブを解凍したら、source サブフォルダにある pcom.pas と pint.pas をそれぞれ pcom.dpr pint.dpr にリネームし、コンソールアプリケーションのプロジェクトファイルとして Delphi IDE に読み込めるようにしておきます。
Delphi は 11.0 Alexandria を使っていますが、無償の Community Edition でもコンパイルできると思います。新しい機能はほぼ使っていないので、Delphi 2009 以降の Unicode 版 Delphi であれば普通にコンパイルできると思います (uses に追加したユニットの名前空間だけ注意)。
See also:
■ PCOM
そのまま Delphi でコンパイルすると 30 件のコンパイルエラーと 4 件の警告が出ます。
1. コンパイラ指令の削除
先頭のコンパイラ指令を削除します。
//(*$c+,t-,d-,l-*)
{*******************************************************************************
* *
* Portable Pascal assembler/interpreter *
* ************************************* *
...
*******************************************************************************}
2. コンソールアプリケーションの指定
{$APPTYPE Console} を追記して、コンソールアプリケーションであることを明示します。RTTI も使わない設定にします。
program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
3. goto 99 の削除
プログラム終端にラベル 99 が設定されています。標準 Pascal の goto は Extraprocedural gotos であり、広域ジャンプが可能ですが、Delphi の goto は Intraprocedural gotos であり、局所的なジャンプとなります。この非互換性は Abort() を使って代替します。
例外を使うので、uses に SysUtils を追加します。
...
program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
uses
System.SysUtils;
label 99; { terminate immediately }
ラベル 99を削除。
program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
uses
System.SysUtils;
//label 99; { terminate immediately }
メインブロックを try～except で括ります。ラベル 99 は削除します。
...
begin
try
{ Suppress unreferenced errors. These are all MPB (machine parameter
block) equations that need to stay the same between front end and backend. }
...
if cipcnt <> 0 then
writeln('*** Error: Compiler internal error: case recycle balance: ',
cipcnt:1);
//99:
except
on E: EAbort do
;
end;
end.
goto 99 を Abort で置換します。
{ scrub all display levels until given }
procedure putdsps(l: disprange);
var t: disprange;
begin
if l > top then begin
writeln('*** Error: Compiler internal error');
// goto 99
Abort
end;
t := top;
while t > l do begin
putdsp(t); t := t-1
end
end;
See also:
- 2. goto の扱い - Delphi と標準 Pascal の比較 (標準 Pascal コードを Delphi に移植する際の注意点) (Qiita)
- Delphi で多重ループを抜ける方法 (Qiita)
- System.SysUtils.Abort (DocWiki)
4. 識別子 string の変更 (1)
string という名前の識別子が使われていますので、これを passtr に置換します。
procedure insymbol;
(*read next basic symbol of source program and return its
description in the global variables sy, op, id, val and lgth*)
label 1;
var i,k: integer;
digit: nmstr; { temp holding for digit string }
rvalb: nmstr; { temp holding for real string }
// string: csstr;
passtr: csstr;
lvp: csp; test, ferr: boolean;
iscmte: boolean;
ev: integer;
chstrquo:
begin lgth := 0; sy := stringconst; op := noop;
// for i := 1 to strglgth do string[i] := ' ';
for i := 1 to strglgth do passtr[i] := ' ';
repeat
repeat nextch; lgth := lgth + 1;
// if lgth <= strglgth then string[lgth] := ch
if lgth <= strglgth then passtr[lgth] := ch
until (eol) or (ch = '''');
if eol then error(202) else nextch
until ch <> '''';
// string[lgth] := ' '; { get rid of trailing quote }
passtr[lgth] := ' '; { get rid of trailing quote }
lgth := lgth - 1; (*now lgth = nr of chars in passtr*)
// if lgth = 1 then val.ival := ord(string[1])
if lgth = 1 then val.ival := ord(passtr[1])
else
begin
if lgth = 0 then error(205);
new(lvp,strg); pshcst(lvp);
lvp^.cclass:=strg;
if lgth > strglgth then
begin error(399); lgth := strglgth end;
with lvp^ do
// begin slgth := lgth; strassvc(sval, string, strglgth) end;
begin slgth := lgth; strassvc(sval, passtr, strglgth) end;
val.valp := lvp
end
end;
5. 識別子 string の変更 (2)
string() という名前の関数がありますので、これを _string() に置換します。
//function string(fsp: stp) : boolean; forward;
function _string(fsp: stp) : boolean; forward;
// function string;
function _string;
var fmin, fmax: integer;
// begin string := false;
begin _string := false;
if fsp <> nil then
if fsp^.form = arrays then
if fsp^.packing then begin
{ if the index is nil, either the array is a string constant or the
index type was in error. Either way, we call it a string }
if fsp^.inxtype = nil then fmin := 1
else getbounds(fsp^.inxtype,fmin,fmax);
// if comptypes(fsp^.aeltype,charptr) and (fmin = 1) then string := true
if comptypes(fsp^.aeltype,charptr) and (fmin = 1) then _string := true
end
// end (*string*) ;
end (*_string*) ;
関数を使っている所も置換します。
{ Arrays are compatible if they are string types and equal in size }
// arrays: comptypes := string(fsp1) and string(fsp2) and
arrays: comptypes := _string(fsp1) and _string(fsp2) and
(fsp1^.size = fsp2^.size );
変更対象が複数あります。
6. バッファ変数の置換
Delphi にはバッファ変数がありませんので、CurrentChar()関数を用意します。insymbol() 手続きよりも前に追加してください。
...
function CurrentChar(var F: Text): WideChar;
begin
Eoln(F);
result := WideChar((TTextRec(F).BufPtr + TTextRec(F).BufPos)^);
end (*CurrentChar*) ;
procedure insymbol;
(*read next basic symbol of source program and return its
description in the global variables sy, op, id, val and lgth*)
バッファ変数を使っている箇所を CurrentChar() で置換します。
number:
begin op := noop; i := 0;
repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
until chartp[ch] <> number;
// if ((ch = '.') and (prd^ <> '.') and (prd^ <> ')')) or
if ((ch = '.') and (CurrentChar(prd) <> '.') and (CurrentChar(prd) <> ')')) or
(lcase(ch) = 'e') then
変更対象が複数あります。
See also:
7. New() 関数の二番目の書式
New() 関数の二番目の書式を使っている箇所を変更します。二番目以降のパラメータを削除するだけです。
// new(lvp,reel); pshcst(lvp); sy:= realconst;
new(lvp); pshcst(lvp); sy:= realconst;
変更対象が複数あります。
See also:
8. Write() / Writeln() の書式
write() / writeln() に Pascal 文字列を渡している所があるので、Delphi の長い文字列に変換します。
// ident: write('ident: ', id:10);
ident: write('ident: ', string(id):10);
変更対象が複数あります。
See also:
9. ファイルアサイン
ここまでの変更でコンパイルは通るようになったと思いますが、まだ正しく動作はしません。
'prd' を外部ファイル prd に、'prr' を外部ファイル prr に関連付けるよう、メインブロックの先頭に AssignFile() を追加します。
...
begin
AssignFile(prd, 'prd');
AssignFile(prr, 'prr');
try
{ Suppress unreferenced errors. These are all MPB (machine parameter
block) equations that need to stay the same between front end and backend. }
10. ファイルクローズ
ファイルを確実にフラッシュするために Flush() と CloseFile() を追加します。
//99:
except
on E: EAbort do
;
end;
CloseFile(prd);
Flush(prr);
CloseFile(prr);
end.
11. W1050 を消す
WideChar に対して in 演算子を使用している箇所を CharInSet() で置き換えます。
// if c in ['A'..'Z'] then c := chr(ord(c)-ord('A')+ord('a'));
if CharInSet(c, ['A'..'Z']) then c := chr(ord(c)-ord('A')+ord('a'));
変更対象が複数あります。
12. W1036 を消す
ローカル変数が初期化されていない箇所があるので初期化します。
lp := nil;
変更対象が複数あります。
13. H2077 を消す
使われていない代入があるのでブロックコメントでコメントアウトします。
if not(lsp^.form in[scalar,subrange,pointer])
then begin error(120); {lsp := nil} end;
変更対象が複数あります。
14. H2164 を消す
H2077 を潰すと、使われていない変数が発生するので、これもブロックコメントでコメントアウトします。
var lsp,lsp1,lsp2: stp; {varts: integer;}
これでヒントも警告もなくなりました。
15. 改行コードの問題を解決する
Windows 環境の場合、改行コードは CR+LF (0D 0A) ですが、Delphi の Eoln() は 0x0d の位置で True を返し、0x0a の位置では False を返します。このため、Windows 環境では行末を検知したらもう 1 バイト読み飛ばす必要があります。
nextch() 手続きを次のように書き換えます。
procedure nextch;
begin
{$IFDEF MSWINDOWS}
if CurrentChar(prd) = #$0A then
begin
Read(prd,ch);
Exit;
end;
{$ENDIF}
if eol then
begin if list then writeln(output); endofline
end;
if not eof(prd) then
begin eol := eoln(prd); read(prd,ch);
if list then write(output,ch);
chcnt := chcnt + 1
end
else
begin writeln(output,' *** eof ','encountered');
test := false
end
end;
16. ピリオドの判定を解決する
Pascal ソースコードの最後のピリオドの後に改行がない場合、ピリオドが連続したとみなされて部分範囲型の範囲文字列 .. と判定されてしまいます。
chperiod:
begin op := noop; nextch;
// if ch = '.' then begin sy := range; nextch end // 削除
if Eof(Prd) then sy := period // 追加
else if ch = '.' then begin sy := range; nextch end // 追加
else if ch = ')' then begin sy := rbrack; nextch end
else sy := period
end;
そして、プログラムの途中で EOF が来たような判定がされてしまうので、次のようなコードを追加します。
// else
else if (sy <> endsy) or (ch <> '.') then // 追加
begin
writeln(output,' *** eof ','encountered');
ch := ' '; // 追加
eol := true; // 追加
test := false
end;
17. mod 演算子の挙動
想定されている mod 演算子の挙動と異なるので、それを代替するための Mod2() 関数を追加します。
まず、uses に Math を追加します。
program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
uses
System.SysUtils, System.Math;
できるだけ前方に Mod2() 関数を記述します。
function Mod2(a, n: Integer): Integer;
begin
if n = 0 then
result := a
else
result := a - Floor(Extended(a / n)) * n;
end (*Mod2*) ;
mod 演算子を使っている箇所を Mod2() 関数で置き換えます。
// flc := l + k - (k+l) mod k
flc := l + k - Mod2(k+l, k)
変更対象が複数あります。
これで PCOM は正しく動作するようになりました。
■ PINT
そのまま Delphi でコンパイルすると 93 件のコンパイルエラーと 7 件の警告が出ます。エラーが多すぎてコンパイルが打ち切られます。
1. コンパイラ指令の削除
先頭のコンパイラ指令を削除します。
//(*$c+,t-,d-,l-*)
{*******************************************************************************
* *
* Portable Pascal compiler *
* ************************ *
...
*******************************************************************************}
2. コンソールアプリケーションの指定
{$APPTYPE Console} を追記して、コンソールアプリケーションであることを明示します。RTTI も使わない設定にします。
program pcode(input,output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
3. goto 1 の削除
プログラム終端付近にラベル 1 が設定されていますので、Abort() を使って代替します。
例外を使うので、uses に SysUtils を追加します。
...
program pcode(input,output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
uses
System.SysUtils;
label 1;
ラベル 1を削除。
program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
//label 1;
メインブロックを try～except で括ります。ラベル 1 は削除します。
...
begin (* main *)
try
{ Suppress unreferenced errors. }
...
// 1 : { abort run }
except
on E: EAbort do
;
end;
writeln;
writeln('program complete');
end.
goto 1 を Abort で置換します。
procedure errori(string: beta);
begin writeln; write('*** Runtime error');
if srclin > 0 then write(' [', srclin:1, ']');
writeln(': ', string);
// pmd; goto 1
pmd; Abort;
end;(*errori*)
procedure errorl(string: beta); (*error in loading*)
begin writeln;
writeln('*** Program load error: [', iline:1, '] ', string);
// goto 1
Abort;
end; (*errorl*)
4. 識別子 string の変更
string という名前の識別子が使われていますので、これを passtr に置換します。ついでに Writeln() のパラメータとして渡せるように string でキャストしておきます。
//procedure errori(string: beta);
procedure errori(passtr: beta);
begin writeln; write('*** Runtime error');
if srclin > 0 then write(' [', srclin:1, ']');
// writeln(': ', string);
writeln(': ', string(passtr));
// pmd; goto 1
pmd; Abort;
end;(*errori*)
// procedure errorl(string: beta); (*error in loading*)
procedure errorl(passtr: beta); (*error in loading*)
begin writeln;
// writeln('*** Program load error: [', iline:1, '] ', string);
writeln('*** Program load error: [', iline:1, '] ', string(passtr));
// goto 1
Abort;
end; (*errorl*)
5. Write() / Writeln() の書式
write() / writeln() に Pascal 文字列を渡している所があるので、Delphi の長い文字列に変換します。
// write(' ', instr[op]:10, ' ');
write(' ', string(instr[op]):10, ' ');
変更対象が複数あります。
6. Pack の削除
Delphi には Pack() がないので削除します。ここでの処理は word -> name のコピーなので、Move() 手続きで代替します。
// pack(word,1,name)
Move(word, name, SizeOf(name));
See also:
- 6.3. パックとアンパック - <6> 構造化型の概要と配列型 (Qiita)
- 5. Pack() / Unpack() - Delphi と標準 Pascal の比較 (標準 Pascal コードを Delphi に移植する際の注意点) (Qiita)
- System.Move (DocWiki)
7. バッファ変数の置換
Delphi にはバッファ変数がありませんので、CurrentChar()関数を用意します。load() 手続きよりも前に追加してください。
...
(*--------------------------------------------------------------------*)
function CurrentChar(var F: Text): WideChar;
begin
result := WideChar((TTextRec(F).BufPtr + TTextRec(F).BufPos)^);
end (*CurrentChar*) ;
{ load intermediate file }
procedure load;
バッファ変数を使っている箇所を CurrentChar() で置換します。
// c := ch; if (ch = '''') and (prd^ = '''') then begin
c := ch; if (ch = '''') and (CurrentChar(prd) = '''') then begin
変更対象が複数あります。
8. Get() の追加
Delphi には Get() がありませんので、同等の関数を追加します。
{$HINTS OFF}
procedure Get(var F: Text);
var
ch: Char;
begin
Read(F, ch);
end (*Get*) ;
{$HINTS ON}
See also:
9. Page() の追加
Delphi には Page() 手続きがありませんので、同等の関数を追加します。
procedure Page(var F: Text);
begin
Write(F, #$0C);
end (*Page*) ;
See also:
- (11. Page()) - Delphi と標準 Pascal の比較 (標準 Pascal コードを Delphi に移植する際の注意点) (Qiita)
- 12.4. 手続き Page() - <12> テキストファイルの入出力 (標準 Pascal 範囲内での Delphi 入門) (Qiita)
10. Put() の代替
Delphi には Put() 手続きがありませんので、同等のロジックを追加します。
procedure putfile(var f: text; var ad: address; fn: fileno);
begin if not filbuff[fn] then errori('File buffer undefined ');
// f^:= getchr(ad+fileidsize); put(f);
Write(f, getchr(ad+fileidsize));
filbuff[fn] := false
end;(*putfile*)
See also:
11. ファイルアサイン
ここまでの変更でコンパイルは通るようになったと思いますが、まだ正しく動作はしません。
'prd' を外部ファイル prd に、'prr' を外部ファイル prr に関連付けるよう、メインブロックの先頭に AssignFile() を追加します。
...
begin (* main *)
AssignFile(prd, 'prd');
AssignFile(prr, 'prr');
try
{ Suppress unreferenced errors. }
12. ファイルクローズ
ファイルを確実にフラッシュするために Flush() と CloseFile() を追加します。
writeln;
writeln('program complete');
CloseFile(prd);
Flush(prr);
CloseFile(prr);
end.
13. W1050 を消す
WideChar に対して in 演算子を使用している箇所を CharInSet() で置き換えます。
// if not (ch in ['i', 'l', 'q', ' ', ':', 'o', 'g']) then
if not CharInSet(ch, ['i', 'l', 'q', ' ', ':', 'o', 'g']) then
変更対象が複数あります。
14. W1036 を消す
ローカル変数が初期化されていない箇所があるので初期化します。
lp := nil;
変更対象が複数あります。
15. H2077 を消す
使われていない代入があるのでコメントアウトします。
// len := len; { shut up compiler check }
16. W1021 を消す
{$WARN} 指令を使ってワーニングを握りつぶします。
{ Suppress unreferenced errors. }
{$WARN COMPARISON_FALSE OFF}
if adral = 0 then;
if adral = 0 then;
if boolal = 0 then;
if charmax = 0 then;
if charal = 0 then;
if codemax = 0 then;
if filesize = 0 then;
if intdig = 0 then;
if markfv = 0 then;
if maxresult = 0 then;
if ordminchar = 0 then;
if ordmaxchar = 0 then;
if stackelsize = 0 then;
{$WARN COMPARISON_FALSE ON}
これでヒントも警告もなくなりました。
17. Read() 手続きの挙動
Read() 手続きの挙動が異なるため、Delphi では l 4=-40 のような行でファイルポインタが l の後にある場合、数値変数に 4 を読み込む事ができません。ReadNum() 関数を作って処理を置き換えます。
procedure load;
type labelst = (entered,defined); (*label situation*)
labelrg = 0..maxlabel; (*label range*)
labelrec = record
val: address;
st: labelst
end;
var word : array[alfainx] of char; ch : char;
labeltab: array[labelrg] of labelrec;
labelvalue: address;
iline: integer; { line number of intermediate file }
function GetNum(var F: Text): Integer;
var
IsNegative: Boolean;
begin
result := 0;
while (CurrentChar(F) = ' ') and not Eoln(F) do
Read(F, ch);
IsNegative := CurrentChar(F) = '-';
if IsNegative then
Read(F, ch);
while CharInSet(CurrentChar(F), ['0'..'9']) and not Eoln(F) do
begin
result := result * 10 + Ord(CurrentChar(F)) - Ord('0');
Read(F, ch);
end;
if IsNegative then
result := -result;
end;
case ch of
'i': getlin; { comment }
// 'l': begin read(prd,x);
'l': begin x := ReadNum(prd);
getnxt;
if ch='=' then read(prd,labelvalue)
else labelvalue:= pc;
update(x); getlin
end;
// begin read(prd,s1); getnxt; s := s + [s1]
begin s1 := ReadNum(prd); getnxt; s := s + [s1]
18. mod 演算子の挙動
想定されている mod 演算子の挙動と異なるので、それを代替するための Mod2() 関数を追加します。
まず、uses に Math を追加します。
program pcode(input,output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
uses
System.SysUtils, System.Math;
できるだけ前方に Mod2() 関数を記述します。
function Mod2(a, n: Integer): Integer;
begin
if n = 0 then
result := a
else
result := a - Floor(Extended(a / n)) * n;
end (*Mod2*) ;
mod 演算子を使っている箇所を Mod2() 関数で置き換えます。
// v := v mod 268435456; { remove digit }
v := Mod2(v, 268435456); { remove digit }
変更対象が複数あります。
これで PINT が正しく動作するようになりました。
■ 機能拡張
機能拡張に関する修正です。
1. 任意の外部ファイルを扱えるようにする
Pascal-P5 では標準入出力 input / output 以外では特殊なファイル prd (入力) prr (出力) しか使えません。この制約はあまりにも大きいので、任意の外部ファイルを扱えるように改変します。
PCOM で外部ファイルをエラーにしている箇所をコメントアウトします。
// { output general error for undefined external file }
// writeln(output);
// writeln(output,'**** Error: external file unknown ''',
// string(fextfilep^.filename):8, '''');
// toterr := toterr+1;
PINT で Reset() または Rewrite() が実行される直前に AssignFile() でファイルを割り当てます。
22(*rsf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Reset on input file ');
outputfn: errori('Reset on output file ');
prdfn: reset(prd);
prrfn: errori('Reset on prr file ')
end
else begin
filstate[fn] := fread;
AssignFile(filtable[fn] , 'FILE.' + IntToStr(fn - 4)); // 追加
reset(filtable[fn]);
filbuff[fn] := false
end
end;
23(*rwf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Rewrite on input file ');
outputfn: errori('Rewrite on output file ');
prdfn: errori('Rewrite on prd file ');
prrfn: rewrite(prr)
end
else begin
filstate[fn] := fwrite;
AssignFile(filtable[fn] , 'FILE.' + IntToStr(fn - 4)); // 追加
rewrite(filtable[fn])
end
end;
PINT 終了時に外部ファイルをすべて閉じます。
writeln;
writeln('program complete');
for i := 5 to maxfil do
begin
if filstate[i] <> fclosed then
begin
if filstate[i] = fwrite then
Flush(filtable[i]);
CloseFile(filtable[i]);
end;
end;
CloseFile(prd);
Flush(prr);
CloseFile(prr);
end.
この拡張を行う事で任意のファイルが扱えるようになりますが、ファイル名を指定できないため、次のようなプログラムヘッダだった場合、
program Test(Input, Output, TEMP, FIZZ, BUZZ);
次のようなファイル名が割り当てられます。
| 外部ファイル | ファイル名 |
|---|---|
| TEMP | 'FILE.1' |
| FIZZ | 'FILE.2' |
| BUZZ | 'FILE.3' |
外部ファイルの識別子をそのままファイル名にすればよさそうに思えるかもしれませんが、Pascal-P5 はコンパイラなのです。コンパイルした時点で識別子の情報は失われます。
この拡張はオリジナルの Pascal-P5 中間ファイルと互換性を保っています。
See also:
- 9.1 ファイル構造 - <9> ファイル型 (標準 Pascal 範囲内での Delphi 入門) (Qiita)
- 9.1 ファイル構造 - <9> ファイル型 (標準 Pascal 範囲内での Delphi 入門)〔裏〕(Qiita)
2. 任意のファイル名をバインドできるようにする
もっと簡単に外部ファイルを使えるようにするため、言語を拡張します。具体的にはプログラムヘッダでファイル名をバインドできるようにします。
program Test(Input, Output, TEMP='TEMP.TXT');
ファイル名のバインドは、今まで数多くの Pascal 方言が実装してきました。
- Assign() / AssignFile()
- Reset() / Rewrite() の追加パラメータでファイル名を指定
- Bind() / Binding() / Unbind() でバインド
これらの実装は理に適っており、ファイル名をプログラム中で任意に変更する事ができます。しかしながらその代償としてプログラムヘッダが形骸化してしまいます。
標準 Pascal では string 型がありませんし (標準 Pascal の任意の長さの文字列型をルーチンに渡すのは面倒)、先に示した拡張の方が Pascal の雰囲気に合っているかと思います。
PCOM で、文字列定数の認識長さを 250 文字まで拡張します。
// varsqt = 10; { variable string quanta }
varsqt = strglgth; { variable string quanta }
programme() を書き換え、中間形式ファイルに x コマンドを追加します。これはファイル No にファイル名を割り当てる機能です。
| コマンド | オペランド 1 | オペランド 2 |
|---|---|---|
| x | ファイル No | ファイル名 |
procedure programme(fsys:setofsys);
var extfp:extfilep;
extfn: Integer; // Add
extfilename: string; // Add
begin
extfn := 5; // Add
chkudtf := chkudtc; { finalize undefined tag checking flag }
if sy = progsy then
begin insymbol; if sy <> ident then error(2) else insymbol;
if not (sy in [lparent,semicolon]) then error(14);
if sy = lparent then
begin
repeat insymbol;
if sy = ident then
begin getfil(extfp);
with extfp^ do
begin filename := id; nextfile := fextfilep end;
fextfilep := extfp;
extfilename := Trim(id); // Add
{ check 'input' or 'output' appears in header for defaults }
if strequri('input ', id) then inputhdf := true
else if strequri('output ', id) then outputhdf := true;
insymbol;
// Del if not ( sy in [comma,rparent] ) then error(20)
{ Add begin }
if not ( sy in [comma,rparent,relop] ) then
error(20)
else if sy = relop then
begin
insymbol;
if sy <> stringconst then
error(31)
else
begin
extfilename := Trim(string(val.valp^.sval.str));
insymbol
end;
end;
if not (strequri('input ', id) or
strequri('output ', id) or
strequri('prd ', id) or
strequri('prr ', id)) then
begin
writeln(prr, 'x ', extfn:1, ' ''', extfilename, '''');
extfn := extfn + 1;
end;
{ Add end }
end
else error(2)
until sy <> comma;
if sy <> rparent then error(4);
insymbol;
if sy <> semicolon then error(14)
end;
if sy = semicolon then insymbol
end else error(3);
repeat block(fsys,period,nil);
if sy <> period then error(21)
until (sy = period) or eof(prd);
if list then writeln(output);
if errinx <> 0 then
begin list := false; endofline end;
end (*programme*) ;
ファイル No は 5 から始まります。1～4 のファイル No は予約されています。
| ファイル No | 識別子 |
|---|---|
| 1 | input |
| 2 | output |
| 3 | prd |
| 4 | prr |
ファイル名を指定した場合にはそのファイル名が、指定しなかった場合には外部ファイルの識別子がファイル名として指定されます。
program Test(Input, input, output, TMP='TEMP.TXT', FIZZ, BUZZ);
!
! Pascal intermediate file Generated by P5 Pascal compiler vs. 1.4
!
o b-c+d+i-l+r+s-t-u+v+x-y-z-
:1
x 5 'TEMP.TXT'
x 6 'FIZZ'
x 7 'BUZZ'
PINT にファイル名の格納場所を作ります。
filtable : array [1..maxfil] of text; { general (temp) text file holders }
nfiltable : array [1..maxfil] of string; // Add
generate() を書き換えます
procedure generate;(*generate segment of code*)
var x: integer; (* label number *)
again: boolean;
ch1: char;
s: string; // Add
...
getnxt;(* first character of line*)
// if not CharInSet(ch, ['!', 'l', 'q', ' ', ':', 'o', 'g','v', 'f']) then
if not CharInSet(ch, ['!', 'l', 'q', ' ', ':', 'o', 'g','v', 'f', 'x']) then
errorl('unexpected line start ');
...
'g': begin read(prd,gbsiz); gbset := true; getlin end;
{ Add begin }
'x': begin { external file }
read(prd, i);
read(prd, s);
nfiltable[i] := StringReplace(Trim(s), '''', '', [rfReplaceAll]);
getlin
end;
{ Add end }
Reset() または Rewrite() が実行される直前に AssignFile() でファイルを割り当てます。
procedure callsp;
var line: boolean;
i, j, w, l, f: integer;
c: char;
b: boolean;
ad,ad1: address;
r: real;
fn: fileno;
mn,mx: integer;
FileName: string; // Add
...
22(*rsf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Reset on input file ');
outputfn: errori('Reset on output file ');
prdfn: reset(prd);
prrfn: errori('Reset on prr file ')
end
else begin
filstate[fn] := fread;
{ Add begin }
if nfiltable[fn] = '' then
FileName := 'FILE.' + IntToStr(fn - 4)
else
FileName := nfiltable[fn];
AssignFile(filtable[fn] , FileName);
{ Add end}
reset(filtable[fn]);
filbuff[fn] := false
end
end;
23(*rwf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Rewrite on input file ');
outputfn: errori('Rewrite on output file ');
prdfn: errori('Rewrite on prd file ');
prrfn: rewrite(prr)
end
else begin
filstate[fn] := fwrite;
{ Add begin }
if nfiltable[fn] = '' then
FileName := 'FILE.' + IntToStr(fn - 4)
else
FileName := nfiltable[fn];
AssignFile(filtable[fn] , FileName);
{ Add end }
rewrite(filtable[fn])
end
end;
x コマンドが記述されていない場合には FILE.(ファイルNo) のファイル名が使われます。
この拡張は外部ファイルを利用しなければオリジナルの Pascal-P5 中間ファイルと互換性を保っています。
3. PCOM / PINT でコマンドラインパラメータとしてファイル名を受け付けるようにする
入力ファイルと出力ファイルが prd / prr 固定というのはあまりに不便なので、コマンドラインパラメータとしてファイル名を受け付けるようにします。
PCOM <Pascal ソースファイル (*.pas)>
Pascal ソースファイル をコマンドラインパラメータとして指定した場合にはそれを Pascal ソースファイルとみなしてコンパイルし、中間形式ファイルとして拡張子を .p5 にしたものを出力します。
begin
if ParamCount > 0 then
begin
AssignFile(prd, ParamStr(1));
AssignFile(prr, ChangeFileExt(ParamStr(1), '.p5'));
end
else
begin
AssignFile(prd, 'prd');
AssignFile(prr, 'prr');
end;
try
...
PINT <中間形式ファイル (*.p5)>
中間形式ファイル をコマンドラインパラメータとして指定した場合にはそれを Pascal 中間形式ファイルとして解釈・実行します。
begin (* main *)
if ParamCount > 0 then
AssignFile(prd, ParamStr(1))
else
AssignFile(prd, 'prd');
AssignFile(prr, 'prr');
try
...
コマンドラインパラメータにファイルを指定しなかった場合には従来と同じ挙動となります。
■ 不具合の修正
不具合に関する修正です。
1. 内部ファイルへの対応 (1)
標準 Pascal では外部ファイルに関連付けない内部ファイルが使えますが、Delphi はこれに対応していないため、外部ファイルとして対応します。
uses に System.IOUtils を追加します。
uses
System.SysUtils, System.Math, System.IOUtils;
テンポラリファイルを外部ファイルとして割り当てます。
33(*rsb*): begin popadr(ad); valfil(ad); fn := store[ad];
if filstate[fn] = fclosed then
errori('Cannot reset closed file ');
filstate[fn] := fread;
if nfiltable[fn] = '' then // 追加
FileName := TPath.Combine(TPath.GetTempPath, Format('TMPFILE%.3d.BIN', [fn-4])) // 追加
else // 追加
FileName := nfiltable[fn]; // 追加
AssignFile(bfiltable[fn] , FileName); // 追加
reset(bfiltable[fn]);
filbuff[fn] := false
end;
34(*rwb*): begin popadr(ad); valfil(ad); fn := store[ad];
filstate[fn] := fwrite;
if nfiltable[fn] = '' then // 追加
FileName := TPath.Combine(TPath.GetTempPath, Format('TMPFILE%.3d.BIN', [fn-4])) // 追加
else // 追加
FileName := nfiltable[fn]; // 追加
AssignFile(bfiltable[fn] , FileName); // 追加
rewrite(bfiltable[fn]);
filbuff[fn] := false
end;
アプリケーション終了時にテンポラリファイルを閉じるようにします。
for i := 5 to maxfil do
begin
if TtextRec(filtable[i]).Handle <> 0 then
begin
if filstate[i] = fwrite then
Flush(filtable[i]);
CloseFile(filtable[i]);
end;
if TFileRec(bfiltable[i]).Handle <> 0 then
CloseFile(bfiltable[i]);
end;
CloseFile(prd);
Flush(prr);
CloseFile(prr);
end.
See also:
2. 内部ファイルへの対応 (2)
Delphi では常に外部ファイルを用いる関係上、Reset / Rewrite を切り替えるには一旦ファイルをクローズしなくてはなりません。
また、このような使い方は内部ファイルでしかあり得ないので、これもテンポラリファイルとして処理します。
22(*rsf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Reset on input file ');
outputfn: errori('Reset on output file ');
prdfn: reset(prd);
prrfn: errori('Reset on prr file ')
end
else begin
{ Add begin }
if filstate[fn] <> fclosed then
begin
if filstate[fn] = fwrite then
Flush(filtable[fn]);
CloseFile(filtable[fn]);
end;
{ Add end }
filstate[fn] := fread;
if nfiltable[fn] = '' then
FileName := TPath.Combine(TPath.GetTempPath, Format('TMPFILE%.3d.TXT', [fn-4])) // 変更
else
FileName := nfiltable[fn];
AssignFile(filtable[fn] , FileName);
reset(filtable[fn]);
filbuff[fn] := false
end
end;
23(*rwf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Rewrite on input file ');
outputfn: errori('Rewrite on output file ');
prdfn: errori('Rewrite on prd file ');
prrfn: rewrite(prr)
end
else begin
{ Add begin }
if filstate[fn] <> fclosed then
begin
if filstate[fn] = fwrite then
Flush(filtable[fn]);
CloseFile(filtable[fn]);
end;
{ Add end }
filstate[fn] := fwrite;
if nfiltable[fn] = '' then
FileName := TPath.Combine(TPath.GetTempPath, Format('TMPFILE%.3d.TXT', [fn-4])) // 変更
else
FileName := nfiltable[fn];
AssignFile(filtable[fn] , FileName);
rewrite(filtable[fn])
end
end;
3. Write() / Writeln() での Boolean
例えば、次のようなコードがあると、
program BoolStr(Output);
begin
Writeln(1=1);
end.
オリジナルの Pascal-P5 (GPC) では
True
と表示されますが、Delphi でビルドすると
TRUE
と表示されます。さらに幅を指定してみます。
program BoolStr(Output);
begin
Writeln(1=1:3);
end.
Pascal-P5 では
Tru
と表示されますが、Delphi では
TRUE
と表示されます。この非互換を解消するために、WriteBool() 手続きを用意します。
procedure WriteBool(var F: Text; b: Boolean; w: Integer = 0);
const
BOOLSTR: array [Boolean] of string = ('false', 'true');
var
s: string;
begin
s := BOOLSTR[b];
if w > 0 then
begin
if Length(s) < w then
s := StringOfChar(' ', w - (Length(s))) + s
else
s := Copy(s, 1, w);
end;
Write(F, s);
end (*WriteBool*) ;
Boolean 値をファイル出力している箇所を修正します。
24(*wrb*): begin popint(w); popint(i); b := i <> 0; popadr(ad);
pshadr(ad); valfil(ad); fn := store[ad];
if w < 1 then errori('Width cannot be < 1 ');
if fn <= prrfn then case fn of
inputfn: errori('Write on input file ');
// outputfn: write(output, b:w);
outputfn: WriteBool(output, b, w);
prdfn: errori('Write on prd file ');
// prrfn: write(prr, b:w)
prrfn: WriteBool(prr, b, w)
end
else begin
if filstate[fn] <> fwrite then
errori('File not in write mode ');
// write(filtable[fn], b:w)
WriteBool(filtable[fn], b, w)
end
end;
Write() / Writeln() における論理値の大文字・小文字は処理系定義となっており、どれが正解というのはありません。 『Pascal User Manual and Report』ではすべて小文字になっていますので、これに倣います。
See also:
4. Write() / Writeln() での Real (固定小数点)
例えば、次のようなコードがあると、
program RealStr(Output);
begin
Writeln(987.6:10);
Writeln(-987.6:10);
end.
オリジナルの Pascal-P5 (GPC) では
9.876e+02
-9.876e+02
と表示されますが、Delphi でビルドすると
9.876E+0002
-9.876E+0002
と表示されます。
この非互換を解消するために、WriteReal() 手続きを用意します。
procedure WriteReal(var F: Text; r: Real; w: Integer = 0);
var
s: string;
w2: Integer;
begin
if w < 8 then
w2 := 2
else
w2 := w - 6;
s := FloatToStrF(r, ffExponent, w2, 2);
if r >= 0 then
s := ' ' + s;
Write(F, s);
end (*WriteReal*) ;
9 (*wrr*): begin popint(w); poprel(r); popadr(ad); pshadr(ad);
valfil(ad); fn := store[ad];
if w < 1 then errori('Width cannot be < 1 ');
if fn <= prrfn then case fn of
inputfn: errori('Write on input file ');
// outputfn: write(output, r: w);
outputfn: WriteReal(output, r, w);
prdfn: errori('Write on prd file ');
// prrfn: write(prr, r:w)
prrfn: WriteReal(prr, r, w)
end
else begin
if filstate[fn] <> fwrite then
errori('File not in write mode ');
// write(filtable[fn], r:w)
WriteReal(filtable[fn], r, w)
end;
end;
Write() / Writeln() における指数桁数は処理系定義となっており、どれが正解というのはありません。 『Pascal User Manual and Report』では 2 になっていますので、これに倣います。
同様に指数文字の大文字・小文字も処理系定義となっており、どれが正解というのはありません。 『Pascal User Manual and Report』では大文字の E になっていますので、これに倣います。
See also:
- 8. 実数の Write() における ExpDigits の値 - Delphi における Pascal の処理系定義 (Qiita)
- 9. 実数の Write() における指数表現文字の大文字・小文字の別 - Delphi における Pascal の処理系定義 (Qiita)
5. Eoln() が True の時の文字
Eoln() が True の時の文字ですが、Delphi では改行文字をそのまま返してしまうので、空白文字を返すようにします。加えて、Windows 環境で CR (0D) が来たら、次の 1 文字も読み飛ばすようにします。
procedure readc(var f: text; var c: char);
begin if eof(f) then errori('End of file ');
read(f,c);
{$IFDEF MSWINDOWS}
if c = #$0D then
read(f,c);
{$ENDIF}
if c = #$0A then
c := ' ';
end;(*readc*)
See also:
6. テキストファイルでの Write と Writeln
標準 Pascal ではテキストファイルに不完全な行があった場合、行末が書き込まれる仕様です。つまり、Writeln() ではなく Write() で終わった場合には行末が書き込まれるのですが、Delphi ではそのようになっていません。
行末の状態を確認し、必要に応じて行末を書き込む AddEoln() 手続きを用意します。
procedure AddEoln(var F: Text);
begin
if (TTextRec(F).BufPtr + TTextRec(F).BufPos - 1)^ <> #$0A then
Writeln(F);
end (*AddEoln*) ;
ファイルが閉じられる際に行末の状態をチェックし、行末がなければ行末を書き込みます。
22(*rsf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Reset on input file ');
outputfn: errori('Reset on output file ');
prdfn: reset(prd);
prrfn: errori('Reset on prr file ')
end
else begin
if filstate[fn] <> fclosed then
begin
if filstate[fn] = fwrite then
begin
AddEoln(filtable[fn]); // 追加
Flush(filtable[fn]);
end;
CloseFile(filtable[fn]);
end;
filstate[fn] := fread;
if nfiltable[fn] = '' then
FileName := TPath.Combine(TPath.GetTempPath, Format('TMPFILE%.3d.TXT', [fn-4]))
else
FileName := nfiltable[fn];
AssignFile(filtable[fn] , FileName);
reset(filtable[fn]);
filbuff[fn] := false
end
end;
23(*rwf*): begin popadr(ad); valfil(ad); fn := store[ad];
if fn <= prrfn then case fn of
inputfn: errori('Rewrite on input file ');
outputfn: errori('Rewrite on output file ');
prdfn: errori('Rewrite on prd file ');
prrfn: rewrite(prr)
end
else begin
if filstate[fn] <> fclosed then
begin
if filstate[fn] = fwrite then
begin
AddEoln(filtable[fn]); // 追加
Flush(filtable[fn]);
end;
CloseFile(filtable[fn]);
end;
filstate[fn] := fwrite;
if nfiltable[fn] = '' then
FileName := TPath.Combine(TPath.GetTempPath, Format('TMPFILE%.3d.TXT', [fn-4]))
else
FileName := nfiltable[fn];
AssignFile(filtable[fn] , FileName);
rewrite(filtable[fn])
end
end;
for i := 5 to maxfil do
begin
if TtextRec(filtable[i]).Handle <> 0 then
begin
if filstate[i] = fwrite then
begin
AddEoln(filtable[i]); // 追加
Flush(filtable[i]);
end;
CloseFile(filtable[i]);
end;
if TFileRec(bfiltable[i]).Handle <> 0 then
CloseFile(bfiltable[i]);
end;
CloseFile(prd);
Flush(prr);
CloseFile(prr);
end.
See also:
■ チューニング
チューニングに関する修正です。
1. 文字配列の縮小
Unicode 版 Delphi の Char は WideChar なため、array [Char] of のような定義は無駄に大きい配列を確保します。
部分範囲型 subchar を定義して、
{ Subrange char }
subchar = Chr(ordminchar)..Chr(ordmaxchar);
(*-------------------------------------------------------------------------*)
var
[char] を [subchar] に置き換えます。
// chartp : array[char] of chtp;
chartp : array[subchar] of chtp;
rw: array [1..maxres(*nr. of res. words*)] of restr;
frw: array [1..10] of 1..36(*nr. of res. words + 1*);
rsy: array [1..maxres(*nr. of res. words*)] of symbol;
// ssy: array [char] of symbol;
ssy: array [subchar] of symbol;
rop: array [1..maxres(*nr. of res. words*)] of operatort;
// sop: array [char] of operatort;
sop: array [subchar] of operatort;
na: array [1..maxstd] of restr;
mn: array [0..maxins] of packed array [1..4] of char;
sna: array [1..maxsp] of packed array [1..4] of char;
cdx: array [0..maxins] of integer;
cdxs: array [1..6, 1..7] of integer;
pdx: array [1..maxsp] of integer;
// ordint: array [char] of integer;
ordint: array [subchar] of integer;
2. コンパイラを騙すためのコードの削除
「参照されていない」というエラーを出さないようにするためのコードがあるので、これを削除します。Delphi ではエラーにならないようです。
// { Suppress unreferenced errors. These are all MPB (machine parameter
// block) equations that need to stay the same between front end and backend. }
// if begincode = 0 then;
// if heapal = 0 then;
// if inthex = 0 then;
// if market = 0 then;
// if markep = 0 then;
// if markdl = 0 then;
// if markra = 0 then;
// if marksb = 0 then;
// if markfv = 0 then;
// if marksl = 0 then;
// if maxresult = 0 then;
// if maxsize = 0 then;
// { Suppress unreferenced errors. }
// {$WARN COMPARISON_FALSE OFF}
// if adral = 0 then;
// if adral = 0 then;
// if boolal = 0 then;
// if charmax = 0 then;
// if charal = 0 then;
// if codemax = 0 then;
// if filesize = 0 then;
// if intdig = 0 then;
// if markfv = 0 then;
// if maxresult = 0 then;
// if ordminchar = 0 then;
// if ordmaxchar = 0 then;
// if stackelsize = 0 then;
// {$WARN COMPARISON_FALSE ON}
3. テンポラリファイルの削除
PINT 終了時にテンポラリファイルを削除するようにします。
majorver = 1; { major version number }
minorver = 3; { minor version number }
experiment = false; { is version experimental? }
p5temp = 'P5TMP'; // 追加
RemoveTempFile() 手続きを実装します。
procedure RemoveTempFile;
begin
for var FileName in TDirectory.GetFiles(TPath.GetTempPath, p5temp + '*.*', TSearchOption.soTopDirectoryOnly) do
try
TFile.Delete(FileName);
except
;
end;
end (*RemoveTempFile*) ;
PINT が出力したテンポラリファイルを特定できるように、ファイル名を p5temp を使って指定します。
FileName := TPath.Combine(TPath.GetTempPath, Format(p5temp + '%.3d.TXT', [fn-4]))
...
FileName := TPath.Combine(TPath.GetTempPath, Format(p5temp + '%.3d.TXT', [fn-4]))
...
FileName := TPath.Combine(TPath.GetTempPath, Format(p5temp + '%.3d.BIN', [fn-4]))
...
FileName := TPath.Combine(TPath.GetTempPath, Format(p5temp + '%.3d.BIN', [fn-4]))
終了時にテンポラリファイルを削除するようにします。
CloseFile(prd);
Flush(prr);
CloseFile(prr);
RemoveTempFile; // 追加
end.
おわりに
割と大掛かりな修正になってしまいました。改変したソースファイル一式は GitHub にアップしてあります。
プラットフォームに固有の機能は使っていないので、macOS 用や Linux 用としてもビルド可能だと思います。
追記:
v1.4 もビルドできるようになりました。
See also: