はじめに

前回、Delphi で Pascal-P5 v1.3 のソースコードをコンパイルできるように改変する記事を書きました。

Delphi で Pascal-P5 v1.3 をビルドする (Qiita)

今回は Pascal-P5 v1.4 のソースコードにチャレンジしてみます。

何故、最初から v1.4 でやらなかったかというと、v1.4 は GNU Pascal (GPC) でしかコンパイルできないような改変がなされていたからです。v1.3 は Free Pascal (FPC) でもコンパイルできましたから、比較的容易にトラブルシューティングができたのです。

目論見通り v1.3 は Delphi へと移植できましたから、次は v1.4 との差分を修正すればいいわけです。

v1.3 と v1.4 で共通な詳細情報へのリンクは本記事では省いてあります。

改変

使うのは Pascal-P5 バージョン 1.4 のソースコードです。

アーカイブを解凍したら、source サブフォルダにある pcom.pas と pint.pas をそれぞれ pcom.dpr pint.dpr にリネームし、コンソールアプリケーションのプロジェクトファイルとして Delphi IDE に読み込めるようにしておきます。

Delphi は 11.0 Alexandria を使っていますが、無償の Community Edition でもコンパイルできると思います。新しい機能はほぼ使っていませんが、条件シンボルの関係で Delphi XE8 以降が必要です ¹。

See also:

Delphi Community Edition (Embarcadero)

■ PCOM

そのまま Delphi でコンパイルすると 42 件のコンパイルエラーと 1 件の警告が出ます。

1. コンパイラ指令の削除

先頭のコンパイラ指令を削除します。

pcom.dpr

//(*$l-,p*)
{*******************************************************************************
*                                                                              *
*                         PASCAL-P5 PORTABLE INTERPRETER                       *
*                                                                              *

...

*******************************************************************************}

2. 条件コンパイル指令の変更 (1)

GNU Pascal (GPC) 用の条件コンパイル指令を Delphi 用に書き換えます。

pcom.dpr

{ Set default configuration flags. This gives proper behavior even if no
  preprocessor flags are passed in.

  The defaults are:
  WRDSIZ32       - 32 bit compiler.
}
//#if !defined(WRDSIZ16) && !defined(WRDSIZ32) && !defined(WRDSIZ64)
//#define WRDSIZ32 1
//#endif

{$DEFINE WRDSIZ32}

常に 32bit コンパイラ用の設定を使います。これは Pascal-P5 v1.4 をコンパイルするための Pascal コンパイラの Integer 型が 16bit / 32bit / 64bit コンパイラでそれぞれ 16bit / 32bit / 64bit 整数であると想定されているからです。Delphi の Integer 型は 32bit / 64bit コンパイラともに 32bit 整数です。

Delphi 1 の Integer 型は 16bit 整数ですが、今回の記事ではビルド対象外です。

3. コンソールアプリケーションの指定

{$APPTYPE Console} を追記して、コンソールアプリケーションであることを明示します。RTTI も使わない設定にします。

pcom.dpr

program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

4. goto 99 の削除

プログラム終端にラベル 99 が設定されています。標準 Pascal の goto は Extraprocedural gotos であり、広域ジャンプが可能ですが、Delphi の goto は Intraprocedural gotos であり、局所的なジャンプとなります。この非互換性は Abort() を使って代替します。

例外を使うので、uses に SysUtils を追加します。

pcom.dpr

...

program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

uses
  System.SysUtils;

label 99; { terminate immediately }

ラベル 99を削除。

pcom.dpr

program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

uses
  System.SysUtils;

//label 99; { terminate immediately }

メインブロックを try～except で括ります。ラベル 99 は削除します。

pcom.dpr


...

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 wtpcnt <> 0 then
       writeln('*** Error: Compiler internal error: with recycle balance: ',
               wtpcnt:1);

//  99:
  except
    on E: EAbort do
      ;
  end;
end.

goto 99 を Abort で置換します。

pcom.dpr

  { 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;

変更対象が複数あります。

5. 条件コンパイル指令の変更 (2)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pcom.dpr

//#ifdef WRDSIZ16
//#include "mpb16.inc"
//#endif
//
//#ifdef WRDSIZ32
//#include "mpb32.inc"
//#endif
//
//#ifdef WRDSIZ64
//#include "mpb64.inc"
//#endif

{$IFDEF WRDSIZ16}
  {$I 'mpb16.inc'}
{$ENDIF}
{$IFDEF WRDSIZ32}
  {$I 'mpb32.inc'}
{$ENDIF}
{$IFDEF WRDSIZ64}
  {$I 'mpb64.inc'}
{$ENDIF}

常に mpb32.inc を使います。

6. 条件コンパイル指令の変更 (3)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pcom.dpr

var

    { !!! remove this statement for self compile }
//#ifndef SELF_COMPILE
{$IFNDEF SELF_COMPILE}
    prd,prr: text;                  { output code file }
//#endif
{$ENDIF}

7. New() / Dispose() 関数の二番目の書式

New() / Dispose() 関数の二番目の書式を使っている箇所を変更します。二番目以降のパラメータを削除するだけです。

pcom.dpr

//     reel: dispose(p, reel);
       reel: dispose(p);

変更対象が複数あります。

8. 条件コンパイル指令の変更 (4)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pcom.dpr

//#ifdef NO_PREAMBLE
{$IFDEF NO_PREAMBLE}
      begin write(output,' ':6,'  ':2);
        if dp then write(output,' ':7) else write(output,' ':7);
        write(output,' ')
      end;
//#else
{$ELSE}
      begin write(output,linecount:6,'  ':2);
        if dp then write(output,lc:7) else write(output,ic:7);
        write(output,' ')
      end;
//#endif
{$ENDIF}

9. 条件コンパイル指令の変更 (5)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pcom.dpr

//#ifdef IMM_ERR
{$IFDEF IMM_ERR}
    writeln; writeln('error: ', ferrnr:1);
//#endif
{$ENDIF}

10. 識別子 string の変更

string という名前の識別子が使われていますので、これを passtr に置換します。

pcom.dpr

  procedure insymbol;
    (*read next basic symbol of source program and return its
    description in the global variables sy, op, id, val and lgth*)
    var i,k, ks: integer;
        digit: nmstr; { temp holding for digit string }
        rvalb: nmstr; { temp holding for real string }
//      string: csstr;
        passtr: csstr;
        lvp: csp; test, ferr: boolean;
        ev: integer;
        syv: boolean;

11. バッファ変数の置換

Delphi にはバッファ変数がありませんので、CurrentChar() 関数を用意します。insymbol() 手続きよりも前に追加してください。

pcom.dpr

  function CurrentChar(var F: Text): WideChar;
  begin
    Eoln(F);
    result := WideChar((TTextRec(F).BufPtr + TTextRec(F).BufPos)^);
  end (*CurrentChar*) ;

バッファ変数を使っている箇所を CurrentChar() で置換します。

pcom.dpr

        number:
          begin op := noop; i := 0;
            repeat i := i+1; if i<= digmax then digit[i] := ch; nextch
            until chartp[ch] <> number;
            { separator must be non-alpha numeric or 'e' }
            if (chartp[ch] = letter) and not (lcase(ch) = 'e') then error(241);
//          if ((ch = '.') and (prd^ <> '.') and (prd^ <> ')')) or
            if ((ch = '.') and (CurrentChar(prd) <> '.') and (prd^ <> ')')) or
               (lcase(ch) = 'e') then

変更対象が複数あります。

12. Write() / Writeln() の書式

write() / writeln() に Pascal 文字列を渡している所があるので、Delphi の長い文字列に変換します。

pcom.dpr

//       ident:       write('ident: ', id:10);
         ident:       write('ident: ', string(id):10);

変更対象が複数あります。

13. 条件コンパイル指令の変更 (6)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pcom.dpr

    { !!! remove these statements for self compile }
//#ifndef SELF_COMPILE
{$IFNDEF SELF_COMPILE}
    reset(prd); rewrite(prr); { open output file }
//#endif
{$ENDIF}

14. ファイルアサイン

ここまでの変更でコンパイルは通るようになったと思いますが、まだ正しく動作はしません。

'prd' を外部ファイル prd に、'prr' を外部ファイル prr に関連付けるよう、メインブロックの先頭に AssignFile() を追加します。

pcom.dpr

...

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. }

15. ファイルクローズ

ファイルを確実にフラッシュするために Flush() と CloseFile() を追加します。

pcom.dpr

  //99:
  except            
    on E: EAbort do 
      ;             
  end;              

  CloseFile(prd);
  Flush(prr);
  CloseFile(prr);
end.

16. W1050 を消す

WideChar に対して in 演算子を使用している箇所を CharInSet() で置き換えます。

pcom.dpr

//  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'));

変更対象が複数あります。

17. W1036 を消す

ローカル変数が初期化されていない箇所があるので初期化します。

pcom.dpr

    lp := nil;

変更対象が複数あります。

18. H2077 を消す

使われていない代入があるのでコメントアウトします。

pcom.dpr

//                        lsize := parmsize; if id <> nil then lsize := id^.size;

変更対象が複数あります。

19. H2164 を消す

H2077 を潰すと、使われていない変数が発生するので、これもブロックコメントでコメントアウトします。

pcom.dpr

            var lsp,lsp1,lsp2: stp; {varts: integer;}

20. W1022 を消す

バグか仕様か不明なので、ブロックコメントでコメントアウトしておきます。

pcom.dpr

            {if varcnt >= 0 then} begin

これでヒントも警告もなくなりました。

21. 改行コードの問題を解決する

Windows 環境の場合、改行コードは CR+LF (0D 0A) ですが、Delphi の Eoln() は 0x0d の位置で True を返し、0x0a の位置では False を返します。このため、Windows 環境では行末を検知したらもう 1 バイト読み飛ばす必要があります。

nextch() 手続きを次のように書き換えます。

pcom.dpr

    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;

22. ピリオドの判定を解決する

Pascal ソースコードの最後のピリオドの後に改行がない場合、ピリオドが連続したとみなされて部分範囲型の範囲文字列 .. と判定されてしまいます。

pcom.dpr

      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 が来たような判定がされてしまうので、次のようなコードを追加します。

pcom.dpr

//     else                                           // 削除 
       else if (sy <> endsy) or (ch <> '.') then      // 追加
       begin
         writeln(output,'   *** eof ','encountered');
         ch := ' ';                                   // 追加
         eol := true;                                 // 追加
         test := false
       end;

23. mod 演算子の挙動

想定されている mod 演算子の挙動と異なるので、それを代替するための Mod2() 関数を追加します。

まず、uses に Math を追加します。

pcom.dpr

program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

uses
  System.SysUtils, System.Math;

できるだけ前方に Mod2() 関数を記述します。

pcom.dpr

  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() 関数で置き換えます。

pcom.dpr

//  flc := l + k  -  (k+l) mod k
    flc := l + k  -  Mod2(k+l, k)

変更対象が複数あります。

これで PCOM は正しく動作するようになりました。

■ PINT

そのまま Delphi でコンパイルすると 57 件のコンパイルエラーと 1 件の警告が出ます。

1. コンパイラ指令の削除

先頭のコンパイラ指令を削除します。

pint.dpr

//(*$l-,u-*)
{*******************************************************************************
*                                                                              *
*                           Portable Pascal compiler                           *
*                           ************************                           *

...

*******************************************************************************}

2. 条件コンパイル指令の変更 (1)

GNU Pascal (GPC) 用の条件コンパイル指令を Delphi 用に書き換えます。

pcom.dpr

{ Set default configuration flags. This gives proper behavior even if no
  preprocessor flags are passed in.

  The defaults are:
  WRDSIZ32       - 32 bit compiler.
}
//#if !defined(WRDSIZ16) && !defined(WRDSIZ32) && !defined(WRDSIZ64)
//#define WRDSIZ32 1
//#endif

{$DEFINE WRDSIZ32}

3. コンソールアプリケーションの指定

{$APPTYPE Console} を追記して、コンソールアプリケーションであることを明示します。RTTI も使わない設定にします。

pint.dpr

program pcode(input,output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

4. goto 1 の削除

プログラム終端付近にラベル 1 が設定されていますので、Abort() を使って代替します。

例外を使うので、uses に SysUtils を追加します。

pint.dpr

...

program pcode(input,output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

uses
  System.SysUtils;

label 1;

ラベル 1を削除。

pint.dpr

program pascalcompiler(output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

//label 1;

メインブロックを try～except で括ります。ラベル 1 は削除します。

pint.dpr


...

begin (* main *)
  try
    { Suppress unreferenced errors. }

  ...

//  1 : { abort run }
  except
    on E: EAbort do
      ;
  end;

  writeln;
  writeln('program complete');

end.

goto 1 を Abort で置換します。

pint.dpr

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*)

pint.dpr

   procedure errorl(string: beta); (*error in loading*)
   begin writeln;
      writeln('*** Program load error: [', iline:1, '] ', string);
//    goto 1
      Abort
   end; (*errorl*)

5. 条件コンパイル指令の変更 (2)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pint.dpr

//#ifdef WRDSIZ16
//#include "mpb16.inc"
//#endif
//
//#ifdef WRDSIZ32
//#include "mpb32.inc"
//#endif
//
//#ifdef WRDSIZ64
//#include "mpb64.inc"
//#endif

{$IFDEF WRDSIZ16}
  {$I 'mpb16.inc'}
{$ENDIF}
{$IFDEF WRDSIZ32}
  {$I 'mpb32.inc'}
{$ENDIF}
{$IFDEF WRDSIZ64}
  {$I 'mpb64.inc'}
{$ENDIF}

6. 条件コンパイル指令の変更 (3)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pint.dpr

      { !!! Need to use the small size memory to self compile, otherwise, by
        definition, pint cannot fit into its own memory. }
//#ifndef SELF_COMPILE
{$IFNDEF SELF_COMPILE}
      maxstr      = 16777215;  { maximum size of addressing for program/var }
      maxtop      = 16777216;  { maximum size of addressing for program/var+1 }
      maxdef      = 2097152;   { maxstr / 8 for defined bits }
//#else
{$ELSE}
      maxstr     =  2000000;   { maximum size of addressing for program/var }
      maxtop     =  2000001;   { maximum size of addressing for program/var+1 }
      maxdef      = 250000;    { maxstr /8 for defined bits }
//#endif
{$ENDIF}

7. 条件コンパイル指令の変更 (4)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pint.dpr

    { !!! remove this statement for self compile }
//#ifndef SELF_COMPILE
{$IFNDEF SELF_COMPILE}
    prd,prr     : text; (*prd for read only, prr for write only *)
//#endif
{$ENDIF}

8. 識別子 string の変更

string という名前の識別子が使われていますので、これを passtr に置換します。ついでに Writeln() のパラメータとして渡せるように string でキャストしておきます。

pint.dpr

//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*)

pint.dpr

// 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*)

9. Write() / Writeln() の書式

write() / writeln() に Pascal 文字列を渡している所があるので、Delphi の長い文字列に変換します。

pint.dpr

// write(' ', instr[op]:10, '  ');
   write(' ', string(instr[op]):10, '  ');

変更対象が複数あります。

10. 条件コンパイル指令の変更 (5)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pint.dpr

         { !!! remove this next statement for self compile }
//#ifndef SELF_COMPILE
{$IFNDEF SELF_COMPILE}
  reset(prd);
//#endif
{$ENDIF}

11. Pack の削除

Delphi には Pack() がないので削除します。ここでの処理は word -> name のコピーなので、Move() 手続きで代替します。

pint.dpr

//      pack(word,1,name)
        Move(word, name, SizeOf(name));

12. バッファ変数の置換

Delphi にはバッファ変数がありませんので、CurrentChar() 関数を用意します。load() 手続きよりも前に追加してください。

pint.dpr

function CurrentChar(var F: Text): WideChar;
begin
  result := WideChar((TTextRec(F).BufPtr + TTextRec(F).BufPos)^);
end (*CurrentChar*) ;

バッファ変数を使っている箇所を CurrentChar() で置換します。

pint.dpr

//                         c := ch; if (ch = '''') and (prd^ = '''') then begin
                           c := ch; if (ch = '''') and (CurrentChar(prd) = '''') then begin

変更対象が複数あります。

13. Get() の追加

Delphi には Get() がありませんので、同等の関数を追加します。

pint.dpr

{$HINTS OFF}
procedure Get(var F: Text);
var
  ch: Char;
begin
  Read(F, ch);
end (*Get*) ;
{$HINTS ON}

14. Page() の追加

Delphi には Page() 手続きがありませんので、同等の関数を追加します。

pint.dpr

procedure Page(var F: Text);
begin
  Write(F, #$0C);
end (*Page*) ;

15. Put() の代替

Delphi には Put() 手続きがありませんので、同等のロジックを追加します。

pint.dpr

   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*)

16. 条件コンパイル指令の変更 (6)

GPC 用の条件コンパイル指令を Delphi 用に書き換えます。

pint.dpr

    { !!! remove this next statement for self compile }
//#ifndef SELF_COMPILE
{$IFNDEF SELF_COMPILE}
  rewrite(prr);
//#endif
{$ENDIF}

17. ファイルアサイン

ここまでの変更でコンパイルは通るようになったと思いますが、まだ正しく動作はしません。

'prd' を外部ファイル prd に、'prr' を外部ファイル prr に関連付けるよう、メインブロックの先頭に AssignFile() を追加します。

pint.dpr

...

begin (* main *)
  AssignFile(prd, 'prd');
  AssignFile(prr, 'prr');
  try
    { Suppress unreferenced errors. }

18. ファイルクローズ

ファイルを確実にフラッシュするために Flush() と CloseFile() を追加します。

pint.dpr

  writeln;
  writeln('program complete');

  CloseFile(prd);
  Flush(prr);
  CloseFile(prr);
end.

19. W1050 を消す

WideChar に対して in 演算子を使用している箇所を CharInSet() で置き換えます。

pint.dpr

//                if not (ch in ['!', 'l', 'q', ' ', ':', 'o', 'g','v', 'f']) then
                  if not CharInSet(ch, ['!', 'l', 'q', ' ', ':', 'o', 'g','v', 'f']) then

変更対象が複数あります。

20. W1036 を消す

ローカル変数が初期化されていない箇所があるので初期化します。

pint.dpr

    p := 0;

変更対象が複数あります。

21. H2077 を消す

使われていない代入があるのでコメントアウトします。

pint.dpr

//   len := len; { shut up compiler check }

22. H2164 を消す

H2077 を潰すと、使われていない変数が発生するので、これもコメントアウトします。

pint.dpr

          {op: instyp;} q : address;  (*instruction register*)

23. W1021 を消す

{$WARN} 指令を使ってワーニングを握りつぶします。

pint.dpr

    { 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 fileal = 0 then;
    if intdig = 0 then;
    if maxresult = 0 then;
    if ordminchar = 0 then;
    if ordmaxchar = 0 then;
    if maxexp = 0 then;
    if stackelsize = 0 then;
    if filres = 0 then;
    if ujplen = 0 then;
    if false then dmpdsp(0);
    {$WARN COMPARISON_FALSE ON}

これでヒントも警告もなくなりました。

24. Read() 手続きの挙動

Read() 手続きの挙動が異なるため、Delphi では l 4=-40 のような行でファイルポインタが l の後にある場合、数値変数に 4 を読み込む事ができません。ReadNum() 関数を作って処理を置き換えます。

pint.dpr

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 ReadNum(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;

pint.dpr

                  case ch of
                       '!': 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;

pint.dpr

                           7: begin skpspc;
                                   if ch <> '(' then
                                     errorl('ldcs() expected          ');
                                   s := [ ];  getnxt;
                                   while ch<>')' do
//                                 begin read(prd,s1); getnxt; s := s + [s1]
                                   begin s1 := ReadNum(prd); getnxt; s := s + [s1]
                                   end;
                                   cp := cp-setsize;
                                   alignd(setal, cp);
                                   if cp <= 0 then
                                      errorl('constant table overflow  ');
                                   putset(cp, s);
                                   q := cp;
                                   storeop; storeq
                                end
                           end (*case*)

25. mod 演算子の挙動

想定されている mod 演算子の挙動と異なるので、それを代替するための Mod2() 関数を追加します。

まず、uses に Math を追加します。

pint.dpr

program pcode(input,output,prd,prr);
{$APPTYPE Console}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}

uses              
  System.SysUtils, System.Math;

できるだけ前方に Mod2() 関数を記述します。

pint.dpr

  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() 関数で置き換えます。

pint.dpr

//   v := v mod maxpow16; { remove digit }
     v := Mod2(v, maxpow16); { remove digit }

変更対象が複数あります。

これで PINT が正しく動作するようになりました。

■ 機能拡張

機能拡張に関する修正です。

1. 任意の外部ファイルを扱えるようにする

Pascal-P5 では標準入出力 input / output 以外では特殊なファイル prd (入力) prr (出力) しか使えません。この制約はあまりにも大きいので、任意の外部ファイルを扱えるように改変します。

PCOM で外部ファイルをエラーにしている箇所をコメントアウトします。

pcom.dpr

//                     { 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() でファイルを割り当てます。

pint.dpr

           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 終了時に外部ファイルをすべて閉じます。

pint.dpr

  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 中間ファイルと互換性を保っています。

2. 任意のファイル名をバインドできるようにする

もっと簡単に外部ファイルを使えるようにするため、言語を拡張します。具体的にはプログラムヘッダでファイル名をバインドできるようにします。

program Test(Input, Output, TEMP='TEMP.TXT');

ファイル名のバインドは、今まで数多くの Pascal 方言が実装してきました。

Assign() / AssignFile()
Reset() / Rewrite() の追加パラメータでファイル名を指定
Bind() / Binding() / Unbind() でバインド

これらの実装は理に適っており、ファイル名をプログラム中で任意に変更する事ができます。しかしながらその代償としてプログラムヘッダが形骸化してしまいます。

標準 Pascal では string 型がありませんし (標準 Pascal の任意の長さの文字列型をルーチンに渡すのは面倒)、先に示した拡張の方が Pascal の雰囲気に合っているかと思います。

PCOM で、文字列定数の認識長さを 250 文字まで拡張します。

pcom.dpr

// varsqt     = 10;   { variable string quanta }
   varsqt     = strglgth;   { variable string quanta }

programme() を書き換え、中間形式ファイルに x コマンドを追加します。これはファイル No にファイル名を割り当てる機能です。

コマンド	オペランド 1	オペランド 2
x	ファイル No	ファイル名

pcom.dpr

  procedure programme(fsys:setofsys);
    var extfp:extfilep;
    extfn: Integer;       // Add
    extfilename: string;  // Add
  begin
    extfn := 5;
    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); if searchext then error(240);
                  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;
//                if not ( sy in [comma,rparent] ) then
//                  perror(20, fsys+[ident,comma,rparent,semicolon], [])
                  { Add begin }
                  if not ( sy in [comma,rparent,relop] ) then
                    perror(20, fsys+[ident,comma,rparent,relop,semicolon], [])
                  else if sy = relop then
                  begin
                    insymbol;
                    if sy <> stringconst then
                      perror(31, fsys+[stringconst], [])
                    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 perror(2, fsys+[ident,comma,rparent,semicolon], [])
            until sy <> comma;
            if sy <> rparent then perror(4, fsys+[rparent,semicolon], []);
            insymbol;
            if sy <> semicolon then perror(14, fsys+[rparent,semicolon], [])
          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 にファイル名の格納場所を作ります。

pint.dpr

      filtable    : array [1..maxfil] of text; { general (temp) text file holders }
      nfiltable   : array [1..maxfil] of string; // Add

generate() を書き換えます

pint.dpr

   procedure generate;(*generate segment of code*)
      var x: integer; (* label number *)
          l: integer;
          again: boolean;
          ch1: char;
          ad: address;
          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    ');


                       'f': begin { faults (errors) }
                              read(prd,i); errsinprg := errsinprg+i; 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() でファイルを割り当てます。

pint.dpr

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 にしたものを出力します。

pcom.dpr

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 中間形式ファイルとして解釈・実行します。

pint.dpr

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 を追加します。

pint.dpr

uses
  System.SysUtils, System.Math, System.IOUtils;

テンポラリファイルを外部ファイルとして割り当てます。

pint.dpr

           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;

アプリケーション終了時にテンポラリファイルを閉じるようにします。

pint.dpr

  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.

2. 内部ファイルへの対応 (2)

Delphi では常に外部ファイルを用いる関係上、Reset / Rewrite を切り替えるには一旦ファイルをクローズしなくてはなりません。
また、このような使い方は内部ファイルでしかあり得ないので、これもテンポラリファイルとして処理します。

pint.dpr

           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() 手続きを用意します。

pint.dpr

  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 値をファイル出力している箇所を修正します。

pint.dpr

           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』ではすべて小文字になっていますので、これに倣います。

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() 手続きを用意します。

pint.dpr

  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*) ;

pint.dpr

           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 になっていますので、これに倣います。

5. Eoln() が True の時の文字

Eoln() が True の時の文字ですが、Delphi では改行文字をそのまま返してしまうので、空白文字を返すようにします。加えて、Windows 環境で CR (0D) が来たら、次の 1 文字も読み飛ばすようにします。

pint.dpr

   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*)

6. テキストファイルでの Write と Writeln

標準 Pascal ではテキストファイルに不完全な行があった場合、行末が書き込まれる仕様です。つまり、Writeln() ではなく Write() で終わった場合には行末が書き込まれるのですが、Delphi ではそのようになっていません。

行末の状態を確認し、必要に応じて行末を書き込む AddEoln() 手続きを用意します。

pint.dpr

  procedure AddEoln(var F: Text);
  begin
    if (TTextRec(F).BufPtr + TTextRec(F).BufPos - 1)^ <> #$0A then
      Writeln(F);
  end (*AddEoln*) ;

ファイルが閉じられる際に行末の状態をチェックし、行末がなければ行末を書き込みます。

pint.dpr

           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;

pint.dpr

  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.

■ チューニング

チューニングに関する修正です。

1. 条件コンパイル指令の削除

Delphi でコンパイルできるようにソースコードを改変した時点でセルフコンパイルは望めないので、セルフコンパイル用の不要なコードを削除します。

pcom.dpr

//    { !!! remove this statement for self compile }
//{$IFNDEF SELF_COMPILE}
    prd,prr: text;                  { output code file }
//{$ENDIF}

pcom.dpr

//   { !!! remove these statements for self compile }
//{$IFNDEF SELF_COMPILE}
    reset(prd); rewrite(prr); { open output file }
//{$ENDIF}

pint.dpr

//{$IFNDEF SELF_COMPILE}
      maxstr      = 16777215;  { maximum size of addressing for program/var }
      maxtop      = 16777216;  { maximum size of addressing for program/var+1 }
      maxdef      = 2097152;   { maxstr / 8 for defined bits }
//{$ELSE}
//      maxstr     =  2000000;   { maximum size of addressing for program/var }
//      maxtop     =  2000001;   { maximum size of addressing for program/var+1 }
//      maxdef      = 250000;    { maxstr /8 for defined bits }
//{$ENDIF}

pint.dpr

//      { !!! remove this next statement for self compile }
//{$IFNDEF SELF_COMPILE}
      prd,prr     : text; (*prd for read only, prr for write only *)
//{$ENDIF}

pint.dpr


//         { !!! remove this next statement for self compile }
//{$IFNDEF SELF_COMPILE}
  reset(prd);
//{$ENDIF}

pint.dpr

//    { !!! remove this next statement for self compile }
//{$IFNDEF SELF_COMPILE}
    rewrite(prr);
//{$ENDIF}

2. 文字配列の縮小

Unicode 版 Delphi の Char は WideChar なため、array [Char] of のような定義は無駄に大きい配列を確保します。

部分範囲型 subchar を定義して、

pcom.dpr

     { Subrange char }
     subchar = Chr(ordminchar)..Chr(ordmaxchar);

(*-------------------------------------------------------------------------*)

var

[char] を [subchar] に置き換えます。

pcom.dpr

//  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;

3. コンパイラを騙すためのコードの削除

「参照されていない」というエラーを出さないようにするためのコードがあるので、これを削除します。Delphi ではエラーにならないようです。

pcom.dpr

//    { 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 markwb = 0 then;
//    if markep = 0 then;
//    if markdl = 0 then;
//    if markra = 0 then;
//    if marksb = 0 then;
//    if marksl = 0 then;
//    if maxresult = 0 then;
//    if maxsize = 0 then;
//    if gbsal = 0 then;
//    if ujplen = 0 then;

pint.dpr

//    { 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 fileal = 0 then;
//    if intdig = 0 then;
//    if maxresult = 0 then;
//    if ordminchar = 0 then;
//    if ordmaxchar = 0 then;
//    if maxexp = 0 then;
//    if stackelsize = 0 then;
//    if filres = 0 then;
//    if ujplen = 0 then;
//    if false then dmpdsp(0);
//    {$WARN COMPARISON_FALSE ON}

4. 冗長な New() / Dispose() の削除

New() / Dispose() の二番目の書式を使わないようにしたため、冗長な記述になっている箇所があります。

pcom.dpr

  { recycle constant entry }
  procedure putcst(p: csp);
  begin
     { recycle string if present }
     if p^.cclass = strg then putstrs(p^.sval)
     else if p^.cclass = reel then putstrs(p^.rval);
     { release entry }
//     case p^.cclass of
//       reel: dispose(p);
//       pset: dispose(p);
//       strg: dispose(p)
//     end;
     Dispose(p); // 追加
     cspcnt := cspcnt-1 { remove from count }
  end;

pcom.dpr

  { recycle structure entry }
  procedure putstc(p: stp);
  begin
     { release entry }
//     case p^.form of
//       scalar:   if p^.scalkind = declared then dispose(p)
//                                           else dispose(p);
//       subrange: dispose(p);
//       pointer:  dispose(p);
//       power:    dispose(p);
//       arrays:   dispose(p);
//       records:  dispose(p);
//       files:    dispose(p);
//       tagfld:   begin dispose(p^.vart); dispose(p) end;
//       variant:  dispose(p);
//     end;
     if p^.form = tagfld then // 追加
       Dispose(p^.vart);      // 追加
     Dispose(p);              // 追加
     stpcnt := stpcnt-1
  end;

pcom.dpr

  procedure putnam{(p: ctp)};
  begin
     if (p^.klass = proc) or (p^.klass = func) then putidlst(p^.pflist);
     putstrs(p^.name); { release name string }
     { release entry according to class }
//     case p^.klass of
//       types: dispose(p);
//       konst: dispose(p);
//       vars:  dispose(p);
//       field: dispose(p);
//       proc: if p^.pfdeckind = standard then dispose(p)
//                                        else if p^.pfkind = actual then
//                                            dispose(p)
//                                          else dispose(p);
//       func: if p^.pfdeckind = standard then dispose(p)
//                                        else if p^.pfkind = actual then
//                                            dispose(p)
//                                          else dispose(p)
//     end;
     Dispose(p); // 追加
     ctpcnt := ctpcnt-1 { remove from count }
  end;

5. テンポラリファイルの削除

PINT 終了時にテンポラリファイルを削除するようにします。

pint.dpr

      majorver   = 1; { major version number }
      minorver   = 3; { minor version number }
      experiment = false; { is version experimental? }

      p5temp     = 'P5TMP'; // 追加

RemoveTempFile() 手続きを実装します。

pint.dpr

  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 を使って指定します。

pint.dpr

                                  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]))

終了時にテンポラリファイルを削除するようにします。

pint.dpr

  CloseFile(prd);
  Flush(prr);
  CloseFile(prr);

  RemoveTempFile; // 追加
end.

ウィルス対策ソフトが反応して、すべてのテンポラリファイルが消えない事があります。

おわりに

やはり v1.3 よりも修正箇所が増えました。改変したソースファイル一式は GitHub にアップしてあります。

プラットフォームに固有の機能は使っていないので、macOS 用や Linux 用としてもビルド可能だと思います。

GitHub の source フォルダにある pcom.dpr と pint.dpr は v1.4 のものですが、mod 1.3 サブフォルダのファイルを上書きして v1.3 をビルドする事もできます。

See also:

64bit 環境用のパラメータが設定されないだけで、ビルドは成功します。 ↩