Delphi で PL/0 をコンパイルする

# はじめに
**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 文字集合](https://qiita.com/ht_deko/items/ce1f56017fb4fcf0302a#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)](https://qiita.com/ht_deko/items/3086b7cff08928eca7a9#%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 Einführung)』の PL/0
若干の機能拡張が施されており、**Modula-2** のサブセットと呼んでもいいかもしれません。

| 一般的な演算子 | PL/0 での演算子 |
|:-:|:-:|
| =  | = |
| <>  | # |
| <  | < |
| <= | <= |
| >  | > |
| >= | >= |

 - 予約語はすべて大文字です。
 - 入力 `?` および出力 `!` 命令が実装されています (Read() / Write() みたいなもの)。
 - ソースコードは **Modula-2** で書かれています。

**See also:**

 - [『翻訳系構成法序論』- Wirth 先生の邦訳本を読んでみる (Qiita)](https://qiita.com/ht_deko/items/3086b7cff08928eca7a9#%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 Einfü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〕、またはメインメニューの [検索 | 置換] で置換ダイアログが開きます。**単語単位で検索**にチェックを入れておくといいでしょう。

![image.png](https://qiita-image-store.s3.amazonaws.com/0/21785/5be382d4-3230-1ab1-2099-3dfb7d5f1dc4.png)

[すべて置換] ボタンを押して全置換します。

### ラベル 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 文字実体参照の置換 (サイトに貼られたコードをコピペした場合)

サイトに貼られているコードは `<` と `>` が変な文字実体参照になってしまっているので、これを置換します。

| 実体参照 | 文字 |
|:---|:---:|
| \&amp;lt; | < |
| \&amp;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 を実行します。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/21785/304b8e93-d928-d053-6d7f-b7ab4e8b128f.png)
標準入力からの入力を待っているので、上記コードをキーボードから入力するか、ソースコードをクリップボードにコピーして貼り付けます (最後に Enter)。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/21785/9507771f-71ba-5e9e-2d2d-91809abfcbf5.png)
結果が表示されます。

オリジナルの PL/0 は入出力ルーチンを持たず、代わりに各変数が変更されるたびに新しい値を出力します。

```
 start pl/0

 ...

 end pl/0
```

`start pl/0` と `end pl/0` に挟まれた行が実行結果です。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/21785/1734fe3b-352c-11d2-bd2c-70404163b463.png)
もちろん 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)](https://qiita.com/ht_deko/items/77052d1f3c3c1a927034)

こちらもぜひ試してみてください。

## 改変ソースコード
念のために、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" は本記事とほぼ同じ修正が行ってあります。
:::