はじめに
PL/0 という言語があります。この名前を持つプログラミング言語の一つは IBM が作った PL/I (ピーエル・ワン) のサブセットです。
この記事で取り上げるのは、Wirth 先生が 1976 年に書いた **『アルゴリズム + データ構造 = プログラム (Algorithms + Data Structures = Programs)』**という書籍で書かれている Pascal のサブセット言語の方です。
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 に掲載されているソースコードは 449 行しかありません。
- 関数は使えず、手続きは call 文で呼び出します。
- 手続きにパラメータは渡せません。
- 標準手続き / 関数はありません。
- 演算子 odd があります。関数ではありません。
- 型は数値のみです。
- if 文に else はありません。
- for 文や repeat 文はありません。
PL/0 のバリエーション
■『アルゴリズム + データ構造 = プログラム (Algorithms + Data Structures = Programs)』の PL/0
PL/0 は文字コードが CDC 6000 の 64 文字集合なため、現在のコンピュータの多くではそのままだとコンパイルできません。
| 一般的な演算子 | 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)
- CDC display code (Wikipedia: en)
- Algorithms+ Data Structures = Programs, 1976,
Chapter 5: PL/0 Compiler (pascal.hansotten.com)
■『翻訳系構成法序論 (Compilerbau: Eine Einführung)』の PL/0
若干の機能拡張が施されており、Modula-2 のサブセットと呼んでもいいかもしれません。
| 一般的な演算子 | PL/0 での演算子 |
|---|---|
| = | = |
| <> | # |
| < | < |
| <= | <= |
| > | > |
| >= | >= |
- 予約語はすべて大文字です。
- 入力
?および出力!命令が実装されています (Read() / Write() みたいなもの)。 - ソースコードは Modula-2 で書かれています。
See also:
エラーコード表
| 説明 | |
|---|---|
| 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:
修正
お題の通り、PL/0 を Delphi でコンパイルしてみたいと思います。ソースコードは Pascal for small machines のものを使います。
Pascal for small machines には簡単に移植できるみたいに書かれていますが、(まぁ簡単ですが) 実際にはちょっと手間が掛かります。
ソースコードのリネーム
まず、Pascal for small machinesのソースコードを持ってきます。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 をダウンロードしてください。学習や趣味なんかに無償で使える製品です。
コードの修正 (コンパイルエラーの除去)
コンソールアプリケーションの指定
コンソールアプリケーションとして動作させるために、{$APPTYPE CONSOLE} を追加します。
program pl0(input,output);
{pl/0 compiler with code generation}
{$APPTYPE CONSOLE} // <-- 追加
label 99;
...
競合する識別子をリネーム
object という識別子が競合するので objekt にリネームします。キーボードショートカットの〔Ctrl〕+〔R〕、またはメインメニューの [検索 | 置換] で置換ダイアログが開きます。単語単位で検索にチェックを入れておくといいでしょう。
[すべて置換] ボタンを押して全置換します。
ラベル 99 を削除
ラベル 99 を使った大域ジャンプが行われているので、これを削除します。Borland 系 Pascal での goto は手続き内 goto (intraprocedural gotos) であり、手続き/関数の外側へジャンプする事はできません。
ラベル 99 はプログラムの最後に設定されているので、ここにジャンプしている goto 文は Halt で置き換えます。
ラベルの定義を削除します。
program pl0(input,output);
{pl/0 compiler with code generation}
{$APPTYPE CONSOLE}
// label 99; // 削除
const norw = 11; {no. of reserved words}
...
goto 99 を Halt で置き換えます。
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;
...
もう一か所あります。
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};
ラベルを削除します。
...
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() | ページ送りを行う。 |
改行で置き換えます。
...
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 でキャストして対処します。
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 してください。
program pl0(input,output);
{pl/0 compiler with code generation}
{$APPTYPE CONSOLE}
uses // 追加
System.SysUtils; // 追加
...
getsym() の中に 4 箇所あります。
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']); // 追加
...
実行
とりあえず実行してみます。この PL/0 は標準入力に与えられたソースファイルを解釈します。メモ帳に次のようなコードを用意しておきます。
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 の実行をちょっとだけ簡単にするバッチファイルです。
plzero.bat
@echo off
cls
if not "%1"=="" goto paramok
echo *** Error: Missing parameter
goto exit
:paramok
pl0 < %1
:exit
例えば test.pl0 というソースファイルを作った場合、
test.pl0
var
x;
begin
x := 1;
x := x + 1;
end.
plzero test.pl0 で実行できます。
パラメータを受け付ける PL/0
getch() を次のように書き換え、
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 };
メインブロックの先頭に処理を追加すれば、
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 は次のようになります。
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 は次のようになります。
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 10.3 Rio で動作するように修正したソースコードを掲載しておきます。ソースコードは読みやすいように整形してあります。
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.
後で気付いたのですが、"plzero fpc.pas" は本記事とほぼ同じ修正が行ってあります。