# Delphi で PL/0 をコンパイルする --- tags: Delphi programming Pascal embarcadero PL0 created_at: 2020-02-09 updated_at: 2022-01-24 --- # はじめに **PL/0** という言語があります。この名前を持つプログラミング言語の一つは IBM が作った **PL/I** (ピーエル・ワン) のサブセットです。 この記事で取り上げるのは、Wirth 先生が 1976 年に書いた **『アルゴリズム + データ構造 = プログラム (Algorithms + Data Structures = Programs)』**という書籍で書かれている **Pascal** のサブセット言語の方です。 - [PL/0 (Wikipedia)](https://ja.wikipedia.org/wiki/PL/0) - [PL/I (Wikipedia)](https://ja.wikipedia.org/wiki/PL/I) # PL/0 とは 先述の通り、**Pascal** のサブセット言語です。言語仕様がとても小さいです。 ``` program = block "." . block = [ "const" ident "=" number {"," ident "=" number} ";"] [ "var" ident {"," ident} ";"] { "procedure" ident ";" block ";" } statement . statement = [ ident ":=" expression | "call" ident | "begin" statement {";" statement } "end" | "if" condition "then" statement | "while" condition "do" statement ]. condition = "odd" expression | expression ("="|"#"|"<"|"<="|">"|">=") expression . expression = [ "+"|"-"] term { ("+"|"-") term}. term = factor {("*"|"/") factor}. factor = ident | number | "(" expression ")". ``` 『アルゴリズム + データ構造 = プログラム』で書かれたオリジナルの PL/0 の行数を数えてはいませんが、[Pascal for small machines](http://pascal.hansotten.com/niklaus-wirth/pl0/) に掲載されているソースコードは 449 行しかありません。 - 関数は使えず、手続きは **call** 文で呼び出します。 - 手続きにパラメータは渡せません。 - 標準手続き / 関数はありません。 - 演算子 **odd** があります。関数ではありません。 - 型は数値のみです。 - **if** 文に **else** はありません。 - **for** 文や **repeat** 文はありません。 ## PL/0 のバリエーション ### ■『アルゴリズム + データ構造 = プログラム (Algorithms + Data Structures = Programs)』の PL/0 **PL/0** は文字コードが [CDC 6000 の 64 文字集合](./ce1f56017fb4fcf0302a.md#12-%E7%89%B9%E6%AE%8A%E3%82%B7%E3%83%B3%E3%83%9C%E3%83%AB%E3%81%A8%E4%BA%88%E7%B4%84%E8%AA%9E)なため、現在のコンピュータの多くではそのままだとコンパイルできません。 | 一般的な演算子 | PL/0 での演算子 | |:---:|:-:| | = | = | | <> | ≠ | | < | < | | <= | ≤ | | > | > | | >= | ≥ | - 予約語はすべて小文字です。 - ソースコードは最初期の **Pascal** (Pascal 6000) で書かれています。 #### エラーコード表 | | 説明 | |:---:|:---| | 1. | `:=` の代わりに `=` が必要 | | 2. | `=` の後に数が必要 | | 3. | 識別子の後に `=` が必要 | | 4. | const, var, procedure の後に識別子が必要 | | 5. | セミコロン `;` かカンマ `,` がない | | 6. | 手続き宣言の後に不正な記号がある | | 7. | ステートメントが必要 | | 8. | ブロック中のステートメントの後に不正な記号がある | | 9. | ピリオド `.` がない | | 10. | 文と文の間にセミコロン `;` がない | | 11. | 識別子が宣言されていない | | 12. | 定数や手続き名には代入できない | | 13. | 代入演算子 `:=` がない| | 14. | call の後には手続き名が必要 | | 15. | 定数名や変数名に対する呼び出しはできない | | 16. | then がない | | 17. | セミコロン `;` または end がない | | 18. | do がない | | 19. | 文の後に不正な記号がある | | 20. | 関係演算子がない | | 21. | 式に手続きが含まれている | | 22. | 右括弧 `)` がない | | 23. | 直前の因子の後にはこの記号を指定できない | | 24. | 式をこの記号で始める事はできない | | 30. | 数が大きすぎる | **See also:** - [『アルゴリズム + データ構造 = プログラム』- Wirth 先生の邦訳本を読んでみる (Qiita)](./3086b7cff08928eca7a9.md#%E3%82%A2%E3%83%AB%E3%82%B4%E3%83%AA%E3%82%BA%E3%83%A0--%E3%83%87%E3%83%BC%E3%82%BF%E6%A7%8B%E9%80%A0--%E3%83%97%E3%83%AD%E3%82%B0%E3%83%A9%E3%83%A0-pascal) - [CDC display code (Wikipedia: en)](https://en.wikipedia.org/wiki/CDC_display_code) - [Algorithms+ Data Structures = Programs, 1976, Chapter 5: PL/0 Compiler (pascal.hansotten.com)](http://pascal.hansotten.com/uploads/books/Algorithms%20chapter%205%20pl0%20description.pdf) ### ■『翻訳系構成法序論 (Compilerbau: Eine Einführung)』の PL/0 若干の機能拡張が施されており、**Modula-2** のサブセットと呼んでもいいかもしれません。 | 一般的な演算子 | PL/0 での演算子 | |:---:|:-:| | = | = | | <> | # | | < | < | | <= | <= | | > | > | | >= | >= | - 予約語はすべて大文字です。 - 入力 `?` および出力 `!` 命令が実装されています (Read() / Write() みたいなもの)。 - ソースコードは **Modula-2** で書かれています。 **See also:** - [『翻訳系構成法序論』- Wirth 先生の邦訳本を読んでみる (Qiita)](./3086b7cff08928eca7a9.md#%E7%BF%BB%E8%A8%B3%E7%B3%BB%E6%A7%8B%E6%88%90%E6%B3%95%E5%BA%8F%E8%AB%96-modula-2) #### エラーコード表 | | 説明 | |:---:|:---| | 1. | `:=` の代わりに `=` が必要 | | 2. | `=` の後に数が必要 | | 3. | 識別子の後に `=` が必要 | | 4. | CONST, VAR, PROCEDURE の後に識別子が必要 | | 5. | セミコロン `;` かカンマ `,` がない | | 6. | 式をこの記号で始める事はできない | | 7. | 右括弧 `)` がない | | 8. | 因子がこの記号で終わることはない | | 9. | ピリオド `.` がない | | 10. | 文に不正な記号が現れた | | 11. | 識別子が宣言されていない | | 12. | 定数や手続き名には代入できない | | 13. | 代入には演算子 `:=` を使わなければならない| | 14. | CALL や ? の後には手続き名が必要 | | 15. | 定数名や変数名に対する呼び出しはできない | | 16. | THEN がない | | 17. | セミコロン `;` または END がない | | 18. | DO がない | | 19. | 文の後に不正な記号がある | | 20. | 関係演算子がない | | 21. | 式に手続きが含まれている | | 25. | 識別子は一度しか宣言できない | | 30. | 数が大きすぎる | ### ■ "Pascal for small machines" の PL/0 ちゃんと確認した訳ではありませんが、恐らく『Compilerbau: Eine Einführung』の第二版あたりに掲載されているものだと思われます。文字コードが ASCII になっています。 | 一般的な演算子 | PL/0 での演算子 | |:---:|:-:| | = | = | | <> | # | | < | < | | <= | [ | | > | > | | >= | ] | - 予約語はすべて小文字です。 - ソースコードは **Pascal** で書かれています。 #### エラーコード表 『アルゴリズム + データ構造 = プログラム』のものと同じです。 ### ■ PurePASCAL (X68000) 付属の PL/0 PurePASCAL (X68000) 付属の PL/0 は Pascal っぽい拡張が施されています。 | 一般的な演算子 | PL/0 での演算子 | |:---:|:-:| | = | = | | <> | <> | | < | < | | <= | <= | | > | > | | >= | >= | - 予約語はすべて大文字です。 - Read() / Write() / WriteLn() が実装されています。 - ソースコードは **Pascal** で書かれています。 **See also:** - [PurePASCAL (ht-deko.com)](https://ht-deko.com/pure.html) # 修正 お題の通り、PL/0 を Delphi でコンパイルしてみたいと思います。ソースコードは [Pascal for small machines](http://pascal.hansotten.com/niklaus-wirth/pl0/) のものを使います。 [Pascal for small machines](http://pascal.hansotten.com/niklaus-wirth/pl0/) には簡単に移植できるみたいに書かれていますが、(まぁ簡単ですが) 実際にはちょっと手間が掛かります。 ## ソースコードのリネーム まず、[Pascal for small machines](http://pascal.hansotten.com/niklaus-wirth/pl0/)のソースコードを持ってきます。`PL/0 1975 Pascal version from Compilerbau and Algorithms + Data Structures = Programs` のリンクからダウンロードし、`PL0.PAS` を抽出してください。サイトに貼られているコードでもいいのですが、余計な修正が必要になります。 | ファイル名 | 言語 | 改行 | 説明 | |:---|:---:|:---:|:---| | pl0.pas | 英 | CR+LF | ノーマルな PL/0 ソース | | plzero compilerbau.pas | 独 | CR+LF | コメントだけではなく識別子もドイツ語になっている | | plzero fpc.pas | 英 | CR+LF | fpc でコンパイルできるように修正されている | | plzero.pas | 英 | LF | 改行コード以外は pl0.pas と同じ | 次に、名前を `PL0.dpr` にして適当な所に保存してください。これを Delphi から [ファイル | プロジェクトを開く] で開いておきます。 **Delphi** をお持ちでない方は **Community Edition** をダウンロードしてください。学習や趣味なんかに無償で使える製品です。 - [Delphi Community Edition (Embarcadero)](https://www.embarcadero.com/jp/products/delphi/starter) ## コードの修正 (コンパイルエラーの除去) ### コンソールアプリケーションの指定 コンソールアプリケーションとして動作させるために、`{$APPTYPE CONSOLE}` を追加します。 ```pascal program pl0(input,output); {pl/0 compiler with code generation} {$APPTYPE CONSOLE} // <-- 追加 label 99; ... ``` - [Application の種類（Delphi）(DocWiki)](http://docwiki.embarcadero.com/RADStudio/ja/Application_%E3%81%AE%E7%A8%AE%E9%A1%9E%EF%BC%88Delphi%EF%BC%89) ### 競合する識別子をリネーム `object` という識別子が競合するので `objekt` にリネームします。キーボードショートカットの〔Ctrl〕+〔R〕、またはメインメニューの [検索 | 置換] で置換ダイアログが開きます。**単語単位で検索**にチェックを入れておくといいでしょう。  [すべて置換] ボタンを押して全置換します。 ### ラベル 99 を削除 ラベル `99` を使った大域ジャンプが行われているので、これを削除します。Borland 系 Pascal での goto は**手続き内 goto** (intraprocedural gotos) であり、手続き/関数の外側へジャンプする事はできません。 ラベル `99` はプログラムの最後に設定されているので、ここにジャンプしている **goto** 文は `Halt` で置き換えます。 - [goto 文 (DocWiki)](http://docwiki.embarcadero.com/RADStudio/ja/%E5%AE%A3%E8%A8%80%E3%81%A8%E6%96%87%EF%BC%88Delphi%EF%BC%89#goto_.E6.96.87) - [System.Halt (DocWiki)](http://docwiki.embarcadero.com/Libraries/ja/System.Halt) ラベルの定義を削除します。 ```pascal program pl0(input,output); {pl/0 compiler with code generation} {$APPTYPE CONSOLE} // label 99; // 削除 const norw = 11; {no. of reserved words} ... ``` `goto 99` を `Halt` で置き換えます。 ```pascal procedure getsym; var i,j,k: integer; procedure getch; begin if cc = ll then begin if eof(input) then begin write(' program incomplete'); // goto 99 // 削除 Halt // 追加 end; ... ``` もう一か所あります。 ```pascal procedure gen(x: fct; y,z: integer); begin if cx > cxmax then begin write(' program too long'); // goto 99 // 削除 Halt // 追加 end; with code[cx] do begin f := x; l := y; a := z end; cx := cx + 1 end {gen}; ``` ラベルを削除します。 ```pascal ... page(output); err := 0; cc := 0; cx := 0; ll := 0; ch := ' '; kk := al; getsym; block(0, 0, [period]+declbegsys+statbegsys); if sym <> period then error(9); if err=0 then interpret else write(' errors in pl/0 program'); // 99: writeln // 削除 writeln // 追加 end. ``` ### Page() 手続き Page() 手続きは Borland 系の Pascal にはありません。 |手続き|説明| |:---|:---| |Page()|ページ送りを行う。| 改行で置き換えます。 ```pascal ... statbegsys := [beginsym, callsym, ifsym, whilesym]; facbegsys := [ident, number, lparen]; //page(output); err := 0; // 削除 WriteLn; err := 0; // 追加 cc := 0; cx := 0; ll := 0; ch := ' '; kk := al; getsym; block(0, 0, [period]+declbegsys+statbegsys); if sym <> period then error(9); if err=0 then interpret else write(' errors in pl/0 program'); //99: writeln writeln end. ``` ### HTML 文字実体参照の置換 (サイトに貼られたコードをコピペした場合) サイトに貼られているコードは `<` と `>` が変な文字実体参照になってしまっているので、これを置換します。 | 実体参照 | 文字 | |:---|:---:| | \&lt; | < | | \&gt; | > | ### String へのキャスト (Unicode 版 Delphi の場合) writeln へ文字配列を渡している箇所がエラーになります。これらはパラメータを String でキャストして対処します。 ```pascal procedure listcode; var i: integer; begin {list code generated for this block} for i := cx0 to cx-1 do with code[i] do //writeln(i:5, mnemonic[f]:5, 1:3, a:5) // 削除 writeln(i:5, String(mnemonic[f]):5, 1:3, a:5) // 追加 end {listcode}; ``` ### set 式を CharInSet に変更 (Unicode 版 Delphi の場合) Char に対して set 式を使うと Char/UnicodeChar (16bit) -> AnsiChar (8bit) への縮小が発生するので **in** を ```CharInSet()``` で置き換えます。CharInSet() は `System.SysUtils` で定義されているので **uses** に追加します。Delphi XE 以前では単に `SysUtils` を **uses** してください。 ```pascal program pl0(input,output); {pl/0 compiler with code generation} {$APPTYPE CONSOLE} uses // 追加 System.SysUtils; // 追加 ... ``` getsym() の中に 4 箇所あります。 ```pascal begin {getsym} while ch = ' ' do getch; // if ch in ['a'..'z'] then // 削除 if CharInSet(ch, ['a'..'z']) then // 追加 begin {identifier or reserved word} k := 0; // repeat if k < al then begin k := k+1; a[k] := ch end; getch; until not(ch in ['a'..'z','0'..'9']); if k >= kk then kk := k else // 削除 repeat if k < al then begin k := k+1; a[k] := ch end; getch; until not CharInSet(ch, ['a'..'z','0'..'9']); if k >= kk then kk := k else // 追加 ... // if ch in ['0'..'9'] then // 削除 if CharInSet(ch, ['0'..'9']) then // 追加 begin {number} k := 0; num := 0; sym := number; repeat num := 10*num + (ord(ch)-ord('0')); k := k+1; getch // until not(ch in ['0'..'9']); // 削除 until not CharInSet(ch, ['0'..'9']); // 追加 ... ``` - [System.SysUtils.CharInSet (DocWiki)](http://docwiki.embarcadero.com/Libraries/Rio/ja/System.SysUtils.CharInSet) - [DCC 警告 W1050 の回避方法 (EDN)](http://edn.embarcadero.com/jp/article/39699) ## 実行 とりあえず実行してみます。この PL/0 は標準入力に与えられたソースファイルを解釈します。メモ帳に次のようなコードを用意しておきます。 ```pascal var x; begin x := 1; x := x + 1; end. ``` PL0 を実行します。  標準入力からの入力を待っているので、上記コードをキーボードから入力するか、ソースコードをクリップボードにコピーして貼り付けます (最後に Enter)。  結果が表示されます。 オリジナルの PL/0 は入出力ルーチンを持たず、代わりに各変数が変更されるたびに新しい値を出力します。 ``` start pl/0 ... end pl/0 ``` `start pl/0` と `end pl/0` に挟まれた行が実行結果です。  もちろん macOS 用にコンパイルする事もできます。 ### バッチファイル PL/0 の実行をちょっとだけ簡単にするバッチファイルです。 ```batch:plzero.bat @echo off cls if not "%1"=="" goto paramok echo *** Error: Missing parameter goto exit :paramok pl0 < %1 :exit ``` 例えば `test.pl0` というソースファイルを作った場合、 ```pascal:test.pl0 var x; begin x := 1; x := x + 1; end. ``` `plzero test.pl0` で実行できます。 ### パラメータを受け付ける PL/0 getch() を次のように書き換え、 ```pascal:PL0.dpr procedure getch; begin if cc = ll then begin if eof(src) then { mod } begin write(' program incomplete'); Halt end; ll := 0; cc := 0; write(cx:5, ' '); while not eoln(src) do { mod } begin ll := ll + 1; read(src, ch); { mod } write(ch); line[ll] := ch end; writeln; readln(src); { mod } ll := ll + 1; line[ll] := ' '; end; cc := cc + 1; ch := line[cc] end { getch }; ``` メインブロックの先頭に処理を追加すれば、 ```pascal:PL0.dpr begin { main program } { ADD BEGIN } if ParamCount = 0 then begin Writeln('*** Error: Missing parameter'); Exit; end; AssignFile(Src, ParamStr(1)); Reset(Src); { ADD END } for ch := chr(0) to chr(255) do ssym[ch] := nul; ... ``` `PL0 test.pl0` のように、パラメータをソースファイルとして受け付けるようになります。こちらの方が使い勝手がいいと思います。 ### FizzBuzz PL/0 では文字列が使えないので、次の数値で FizzBuzz の状態を出力します。 | 状態 | 値 | |:---:|:-:| | FizzBuzz | 255 | | Fizz | 254 | | Buzz | 253 | 解りやすく書いた FizzBuzz は次のようになります。 ```pascal:fizzbuzz.pl0 var i, a, b, v, m1, m2; procedure mod; begin b := i - (i / a) * a; end; begin i := 1; while i [ 100 do begin a := 3; call mod; m1 := b; a := 5; call mod; m2 := b; v := 0; if m1 + m2 = 0 then v := 255; if v = 0 then begin if m1 = 0 then begin v := 254; end; end; if v = 0 then begin if m2 = 0 then begin v := 253; end; end; if v = 0 then begin v := i; end; i := i + 1; end; end. ``` 短く書いた FizzBuzz は次のようになります。 ```pascal:fizzbuzz.pl0 var i, v; begin i := 1; while i [ 100 do begin v := 0; if (i - (i / 3) * 3) + (i - (i / 5) * 5) = 0 then v := 255; if v + (i - (i / 3) * 3) = 0 then v := 254; if v + (i - (i / 5) * 5) = 0 then v := 253; if v = 0 then v := i; i := i + 1; end; end. ``` # おわりに PL/0 は**大文字小文字を区別する**ので注意が必要です。今回の場合だとソースコードは基本的にすべて小文字で記述してください。 もうちょっと実用的な Pascal サブセットとしては **Pascal-S** があります。 - [Delphi で Pascal-S をコンパイルする (Qiita)](./77052d1f3c3c1a927034.md) こちらもぜひ試してみてください。 ## 改変ソースコード 念のために、Delphi 10.3 Rio で動作するように修正したソースコードを掲載しておきます。ソースコードは読みやすいように整形してあります。 ```pascal:PL0.dpr program pl0(input, output); { pl/0 compiler with code generation } {$APPTYPE CONSOLE} uses System.SysUtils; const norw = 11; { no. of reserved words } txmax = 100; { length of identifier table } nmax = 14; { max. no. of digits in numbers } al = 10; { length of identifiers } amax = 2047; { maximum address } levmax = 3; { maximum depth of block nesting } cxmax = 200; { size of code array } type symbol = (nul, ident, number, plus, minus, times, slash, oddsym, eql, neq, lss, leq, gtr, geq, lparen, rparen, comma, semicolon, period, becomes, beginsym, endsym, ifsym, thensym, whilesym, dosym, callsym, constsym, varsym, procsym); alfa = packed array [1..al] of char; objekt = (constant, varible, proc); symset = set of symbol; fct = (lit, opr, lod, sto, cal, int, jmp, jpc); { functions } instruction = packed record f: fct; { function code } l: 0..levmax; { level } a: 0..amax { displacement address } end; { lit 0,a : load constant a opr 0,a : execute operation a lod l,a : load varible l,a sto l,a : store varible l,a cal l,a : call procedure a at level l int 0,a : increment t-register by a jmp 0,a : jump to a jpc 0,a : jump conditional to a } var ch: char; { last character read } sym: symbol; { last symbol read } id: alfa; { last identifier read } num: integer; { last number read } cc: integer; { character count } ll: integer; { line length } kk, err: integer; cx: integer; { code allocation index } line: array [1..81] of char; a: alfa; code: array [0..cxmax] of instruction; word: array [1..norw] of alfa; wsym: array [1..norw] of symbol; ssym: array [char] of symbol; mnemonic: array [fct] of packed array [1..5] of char; declbegsys, statbegsys, facbegsys: symset; table: array [0..txmax] of record name: alfa; case kind: objekt of constant: (val: integer); varible, proc: (level, adr: integer) end; procedure error(n: integer); begin writeln(' ****', ' ':cc - 1, '^', n:2); err := err + 1 end { error }; procedure getsym; var i, j, k: integer; procedure getch; begin if cc = ll then begin if eof(input) then begin write(' program incomplete'); Halt end; ll := 0; cc := 0; write(cx:5, ' '); while not eoln(input) do begin ll := ll + 1; read(ch); write(ch); line[ll] := ch end; writeln; readln; ll := ll + 1; line[ll] := ' '; end; cc := cc + 1; ch := line[cc] end { getch }; begin { getsym } while ch = ' ' do getch; if CharInSet(ch, ['a'..'z']) then begin { identifier or reserved word } k := 0; repeat if k < al then begin k := k + 1; a[k] := ch end; getch; until not CharInSet(ch, ['a'..'z', '0'..'9']); if k >= kk then kk := k else repeat a[kk] := ' '; kk := kk - 1 until kk = k; id := a; i := 1; j := norw; repeat k := (i + j) div 2; if id <= word[k] then j := k - 1; if id >= word[k] then i := k + 1 until i > j; if i - 1 > j then sym := wsym[k] else sym := ident end else if CharInSet(ch, ['0'..'9']) then begin { number } k := 0; num := 0; sym := number; repeat num := 10 * num + (ord(ch) - ord('0')); k := k + 1; getch until not CharInSet(ch, ['0'..'9']); if k > nmax then error(30) end else if ch = ':' then begin getch; if ch = '=' then begin sym := becomes; getch end else sym := nul; end else begin sym := ssym[ch]; getch end end { getsym }; procedure gen(x: fct; y, z: integer); begin if cx > cxmax then begin write(' program too long'); Halt end; with code[cx] do begin f := x; l := y; a := z end; cx := cx + 1 end { gen }; procedure test(s1, s2: symset; n: integer); begin if not(sym in s1) then begin error(n); s1 := s1 + s2; while not(sym in s1) do getsym end end { test }; procedure block(lev, tx: integer; fsys: symset); var dx: integer; { data allocation index } tx0: integer; { initial table index } cx0: integer; { initial code index } procedure enter(k: objekt); begin { enter objekt into table } tx := tx + 1; with table[tx] do begin name := id; kind := k; case k of constant: begin if num > amax then begin error(30); num := 0 end; val := num end; varible: begin level := lev; adr := dx; dx := dx + 1; end; proc: level := lev end end end { enter }; function position(id: alfa): integer; var i: integer; begin { find indentifier id in table } table[0].name := id; i := tx; while table[i].name <> id do i := i - 1; position := i end { position }; procedure constdeclaration; begin if sym = ident then begin getsym; if sym in [eql, becomes] then begin if sym = becomes then error(1); getsym; if sym = number then begin enter(constant); getsym end else error(2) end else error(3) end else error(4) end { constdeclaration }; procedure vardeclaration; begin if sym = ident then begin enter(varible); getsym end else error(4) end { vardeclaration }; procedure listcode; var i: integer; begin { list code generated for this block } for i := cx0 to cx - 1 do with code[i] do writeln(i:5, String(mnemonic[f]):5, 1:3, a:5) end { listcode }; procedure statement(fsys: symset); var i, cx1, cx2: integer; procedure expression(fsys: symset); var addop: symbol; procedure term(fsys: symset); var mulop: symbol; procedure factor(fsys: symset); var i: integer; begin test(facbegsys, fsys, 24); while sym in facbegsys do begin if sym = ident then begin i := position(id); if i = 0 then error(11) else with table[i] do case kind of constant: gen(lit, 0, val); varible: gen(lod, lev - level, adr); proc: error(21) end; getsym end else if sym = number then begin if num > amax then begin error(30); num := 0 end; gen(lit, 0, num); getsym end else if sym = lparen then begin getsym; expression([rparen] + fsys); if sym = rparen then getsym else error(22) end; test(fsys, [lparen], 23) end end { factor }; begin { term } factor(fsys + [times, slash]); while sym in [times, slash] do begin mulop := sym; getsym; factor(fsys + [times, slash]); if mulop = times then gen(opr, 0, 4) else gen(opr, 0, 5) end end { term }; begin { expression } if sym in [plus, minus] then begin addop := sym; getsym; term(fsys + [plus, minus]); if addop = minus then gen(opr, 0, 1) end else term(fsys + [plus, minus]); while sym in [plus, minus] do begin addop := sym; getsym; term(fsys + [plus, minus]); if addop = plus then gen(opr, 0, 2) else gen(opr, 0, 3) end end { expression }; procedure condition(fsys: symset); var relop: symbol; begin if sym = oddsym then begin getsym; expression(fsys); gen(opr, 0, 6) end else begin expression([eql, neq, lss, gtr, leq, geq] + fsys); if not(sym in [eql, neq, lss, leq, gtr, geq]) then error(20) else begin relop := sym; getsym; expression(fsys); case relop of eql: gen(opr, 0, 8); neq: gen(opr, 0, 9); lss: gen(opr, 0, 10); geq: gen(opr, 0, 11); gtr: gen(opr, 0, 12); leq: gen(opr, 0, 13); end end end end { condition }; begin { statement } if sym = ident then begin i := position(id); if i = 0 then error(11) else if table[i].kind <> varible then begin { assignment to non-varible } error(12); i := 0 end; getsym; if sym = becomes then getsym else error(13); expression(fsys); if i <> 0 then with table[i] do gen(sto, lev - level, adr) end else if sym = callsym then begin getsym; if sym <> ident then error(14) else begin i := position(id); if i = 0 then error(11) else with table[i] do if kind = proc then gen(cal, lev - level, adr) else error(15); getsym end end else if sym = ifsym then begin getsym; condition([thensym, dosym] + fsys); if sym = thensym then getsym else error(16); cx1 := cx; gen(jpc, 0, 0); statement(fsys); code[cx1].a := cx end else if sym = beginsym then begin getsym; statement([semicolon, endsym] + fsys); while sym in [semicolon] + statbegsys do begin if sym = semicolon then getsym else error(10); statement([semicolon, endsym] + fsys) end; if sym = endsym then getsym else error(17) end else if sym = whilesym then begin cx1 := cx; getsym; condition([dosym] + fsys); cx2 := cx; gen(jpc, 0, 0); if sym = dosym then getsym else error(18); statement(fsys); gen(jmp, 0, cx1); code[cx2].a := cx end; test(fsys, [], 19) end { statement }; begin { block } dx := 3; tx0 := tx; table[tx].adr := cx; gen(jmp, 0, 0); if lev > levmax then error(32); repeat if sym = constsym then begin getsym; repeat constdeclaration; while sym = comma do begin getsym; constdeclaration end; if sym = semicolon then getsym else error(5); until sym <> ident; end; if sym = varsym then begin getsym; repeat vardeclaration; while sym = comma do begin getsym; vardeclaration end; if sym = semicolon then getsym else error(5); until sym <> ident; end; while sym = procsym do begin getsym; if sym = ident then begin enter(proc); getsym end else error(4); if sym = semicolon then getsym else error(5); block(lev + 1, tx, [semicolon] + fsys); if sym = semicolon then begin getsym; test(statbegsys + [ident, procsym], fsys, 6) end else error(5) end; test(statbegsys + [ident], declbegsys, 7) until not(sym in declbegsys); code[table[tx0].adr].a := cx; with table[tx0] do begin adr := cx; { start adr of code } end; cx0 := 0 { cx }; gen(int, 0, dx); statement([semicolon, endsym] + fsys); gen(opr, 0, 0); { return } test(fsys, [], 8); listcode; end { block }; procedure interpret; const stacksize = 500; var p, b, t: integer; { program-, base-, topstack-registers } i: instruction; { instruction register } s: array [1..stacksize] of integer; { datastore } function base(l: integer): integer; var b1: integer; begin b1 := b; { find base l levels down } while l > 0 do begin b1 := s[b1]; l := l - 1 end; base := b1 end { base }; begin writeln(' start pl/0'); t := 0; b := 1; p := 0; s[1] := 0; s[2] := 0; s[3] := 0; repeat i := code[p]; p := p + 1; with i do case f of lit: begin t := t + 1; s[t] := a end; opr: case a of { operator } 0: begin { return } t := b - 1; p := s[t + 3]; b := s[t + 2]; end; 1: s[t] := -s[t]; 2: begin t := t - 1; s[t] := s[t] + s[t + 1] end; 3: begin t := t - 1; s[t] := s[t] - s[t + 1] end; 4: begin t := t - 1; s[t] := s[t] * s[t + 1] end; 5: begin t := t - 1; s[t] := s[t] div s[t + 1] end; 6: s[t] := ord(odd(s[t])); 8: begin t := t - 1; s[t] := ord(s[t] = s[t + 1]) end; 9: begin t := t - 1; s[t] := ord(s[t] <> s[t + 1]) end; 10: begin t := t - 1; s[t] := ord(s[t] < s[t + 1]) end; 11: begin t := t - 1; s[t] := ord(s[t] >= s[t + 1]) end; 12: begin t := t - 1; s[t] := ord(s[t] > s[t + 1]) end; 13: begin t := t - 1; s[t] := ord(s[t] <= s[t + 1]) end; end; lod: begin t := t + 1; s[t] := s[base(l) + a] end; sto: begin s[base(l) + a] := s[t]; writeln(s[t]); t := t - 1 end; cal: begin { generate new block mark } s[t + 1] := base(l); s[t + 2] := b; s[t + 3] := p; b := t + 1; p := a end; int: t := t + a; jmp: p := a; jpc: begin if s[t] = 0 then p := a; t := t - 1 end end { with, case }; until p = 0; write(' end pl/0'); end { interpret }; begin { main program } for ch := chr(0) to chr(255) do ssym[ch] := nul; word[ 1] := 'begin '; word[ 2] := 'call '; word[ 3] := 'const '; word[ 4] := 'do '; word[ 5] := 'end '; word[ 6] := 'if '; word[ 7] := 'odd '; word[ 8] := 'procedure '; word[ 9] := 'then '; word[10] := 'var '; word[11] := 'while '; wsym[ 1] := beginsym; wsym[ 2] := callsym; wsym[ 3] := constsym; wsym[ 4] := dosym; wsym[ 5] := endsym; wsym[ 6] := ifsym; wsym[ 7] := oddsym; wsym[ 8] := procsym; wsym[ 9] := thensym; wsym[10] := varsym; wsym[11] := whilesym; ssym['+'] := plus; ssym['-'] := minus; ssym['*'] := times; ssym['/'] := slash; ssym['('] := lparen; ssym[')'] := rparen; ssym['='] := eql; ssym[','] := comma; ssym['.'] := period; ssym['#'] := neq; ssym['<'] := lss; ssym['>'] := gtr; ssym['['] := leq; ssym[']'] := geq; ssym[';'] := semicolon; mnemonic[lit] := ' lit'; mnemonic[opr] := ' opr'; mnemonic[lod] := ' lod'; mnemonic[sto] := ' sto'; mnemonic[cal] := ' cal'; mnemonic[int] := ' int'; mnemonic[jmp] := ' jmp'; mnemonic[jpc] := ' jpc'; declbegsys := [constsym, varsym, procsym]; statbegsys := [beginsym, callsym, ifsym, whilesym]; facbegsys := [ident, number, lparen]; writeln; err := 0; cc := 0; cx := 0; ll := 0; ch := ' '; kk := al; getsym; block(0, 0, [period] + declbegsys + statbegsys); if sym <> period then error(9); if err = 0 then interpret else write(' errors in pl/0 program'); writeln end. ``` :::note info 後で気付いたのですが、"plzero fpc.pas" は本記事とほぼ同じ修正が行ってあります。 :::