# Delphi で Basic-S (Tiny Basic) をコンパイルする --- tags: Delphi programming BASIC embarcadero objectpascal created_at: 2019-02-12 updated_at: 2022-01-28 --- # はじめに Basic-S という 1,300 行程度の Pascal で書かれた Tiny Basic があります。Pascal-S の改変版を公開されている S.A.MOORE 氏の作です。 - [Basic-S (standardpascaline.org)](http://www.standardpascaline.org/basics.pas) - [THE ISO 7185 STANDARD PASCAL PAGE (standardpascaline.org)](http://www.standardpascaline.org) 本記事はその Basic-S を Delphi でコンパイルしてみようという趣旨です。使用する Delphi は 2009 以降であれば大丈夫だと思います。最新版の 10.3 Rio でも大丈夫ですし、無償版の Community Edition でももちろん大丈夫です。 - [Delphi (Embarcadero)](https://www.embarcadero.com/jp/products/delphi) - [Delphi Community Edition (Embarcadero)](https://www.embarcadero.com/jp/products/delphi/starter) - [Delphi (Wikipedia)](https://ja.wikipedia.org/wiki/Delphi) # 修正 [Basic-S](http://www.standardpascaline.org/basics.pas) のソースコード をそのままコンパイルできる Pascal コンパイラは以下の 3 つです。ISO 7185 に準拠していればそのままコンパイルできると思います。 - [GNU Pascal](http://www.gnu-pascal.de/gpc/h-index.html) - [Free Pascal (Lazarus)](https://www.lazarus-ide.org/) - [IP Pascal](http://www.moorecad.com/ippas/) Delphi ではちょっとした修正を行わないとコンパイルが通りません。 - [What are the differences between Borland Delphi and the ISO 7185 standard? (standardpascaline.org](http://www.standardpascaline.org/pascalfaq.html#Q.%20What%20are%20the%20differences%20between%20Borland%20Del) 以降で修正を行いますので、まずはファイルを適当な場所に展開しておいてください。 ## プロジェクトを開く Basic-S は単一のソースファイル (basicss.pas) で構成されているので、これを Delphi で開けるように拡張子を *dpr に変更します。  [ファイル | プロジェクトを開く] で basics.dpr を開きます。  ## コードの修正 (コンパイルエラーの除去) まずはコンパイルエラーになる箇所をすべて潰します。 ### コンソールアプリケーションの指定 コンソールアプリケーションとして動作させるために、`{$APPTYPE CONSOLE}` を追加します。 ```pascal ... program basics(input, output); {$APPTYPE CONSOLE} // 追加 label 88, 77, 99; ... ``` ### ラベルを削除 **goto** による大域ジャンプが行われていますので、これを修正します...判りにくいので修正の前にメインブロックを整形します。 ```pascal ... begin { executive } clear; { initalize keys } keywd[cinput] := 'input '; keywd[cprint] := 'print '; keywd[cgoto] := 'goto '; keywd[cif] := 'if '; keywd[crem] := 'rem '; keywd[cstop] := 'stop '; keywd[crun] := 'run '; keywd[clist] := 'list '; keywd[cnew] := 'new '; keywd[clet] := 'let '; keywd[cbye] := 'bye '; keywd[clequ] := '<= '; keywd[cgequ] := '>= '; keywd[cequ] := '= '; keywd[cnequ] := '<> '; keywd[cltn] := '< '; keywd[cgtn] := '> '; keywd[cadd] := '+ '; keywd[csub] := '- '; keywd[cmult] := '* '; keywd[cdiv] := '/ '; keywd[cmod] := 'mod '; keywd[cleft] := 'left$ '; keywd[cright] := 'right$ '; keywd[cmid] := 'mid$ '; keywd[cthen] := 'then '; keywd[cstr] := 'str$ '; keywd[cval] := 'val '; keywd[cchr] := 'chr '; writeln; writeln('Tiny basic interpreter vs. 0.1 Copyright (C) 1994 S. A. Moore'); writeln; 88: while true do begin writeln('Ready'); 77: prgmc := 0; linec := 1; top := 0; { get user lines until non-blank } repeat inpstr(prgm[0]) until not null(prgm[0]); keycom(prgm[0]); if lint(prgm[0]) > 0 then begin enter(prgm[0]); goto 77 end else repeat exec; if (prgmc > maxpgm) then prgmc := 0 else if null(prgm[prgmc]) then prgmc := 0 until prgmc = 0 end; 99: writeln end. ``` 順に見ていきましょう。 ### goto 99 `goto 99` は 1 箇所でしか使われていませんし、プログラムの最後へのジャンプなので `Halt()` で置き換えます。まずはラベルの宣言を削除します。 ```pascal ... program basics(input, output); {$APPTYPE CONSOLE} // label 88, 77, 99; // 削除 ... ``` stat() の中を書き換えます。 ```pascal ... clet: let; //cbye: goto 99 // 削除 cbye: begin // 追加 Writeln; // 追加 Halt; // 追加 end; // 追加 end end else let { default let } end; { stat } ``` メインブロックの中のラベルを削除します。 ```pascal ... else repeat exec; if (prgmc > maxpgm) then prgmc := 0 else if null(prgm[prgmc]) then prgmc := 0 until prgmc = 0 end; //99: // 削除 // writeln // 削除 end. ``` ### goto 77 `goto 77` は 1 か所しか使われておらず大域ジャンプでもないのでそのままでもいいのですが、面倒なのでなくします。 ```pascal ... 88: while true do begin writeln('Ready'); while true do // もう一段追加 begin prgmc := 0; linec := 1; top := 0; { get user lines until non-blank } repeat inpstr(prgm[0]) until not null(prgm[0]); keycom(prgm[0]); if lint(prgm[0]) > 0 then begin enter(prgm[0]); Continue; // Continue で goto の代わりにする end else repeat exec; if (prgmc > maxpgm) then prgmc := 0 else if null(prgm[prgmc]) then prgmc := 0 until prgmc = 0; Break; // ループしない end; end; end. ``` 無限ループを設置し、Continue と Break で goto の代わりにします。 ### goto 88 `goto 88` では例外を投げるようにし、例外処理でループさせるようにします。 - [例外 (Delphi) (DocWiki)](http://docwiki.embarcadero.com/RADStudio/ja/%E4%BE%8B%E5%A4%96%EF%BC%88Delphi%EF%BC%89) メインブロックはこうなります。 ```pascal ... begin { executive } clear; { initalize keys } keywd[cinput] := 'input '; keywd[cprint] := 'print '; keywd[cgoto] := 'goto '; keywd[cif] := 'if '; keywd[crem] := 'rem '; keywd[cstop] := 'stop '; keywd[crun] := 'run '; keywd[clist] := 'list '; keywd[cnew] := 'new '; keywd[clet] := 'let '; keywd[cbye] := 'bye '; keywd[clequ] := '<= '; keywd[cgequ] := '>= '; keywd[cequ] := '= '; keywd[cnequ] := '<> '; keywd[cltn] := '< '; keywd[cgtn] := '> '; keywd[cadd] := '+ '; keywd[csub] := '- '; keywd[cmult] := '* '; keywd[cdiv] := '/ '; keywd[cmod] := 'mod '; keywd[cleft] := 'left$ '; keywd[cright] := 'right$ '; keywd[cmid] := 'mid$ '; keywd[cthen] := 'then '; keywd[cstr] := 'str$ '; keywd[cval] := 'val '; keywd[cchr] := 'chr '; writeln; writeln('Tiny basic interpreter vs. 0.1 Copyright (C) 1994 S. A. Moore'); writeln; while true do begin try // 例外処理 writeln('Ready'); while true do begin prgmc := 0; linec := 1; top := 0; { get user lines until non-blank } repeat inpstr(prgm[0]) until not null(prgm[0]); keycom(prgm[0]); if lint(prgm[0]) > 0 then begin enter(prgm[0]); Continue; end else repeat exec; if (prgmc > maxpgm) then prgmc := 0 else if null(prgm[prgmc]) then prgmc := 0 until prgmc = 0; Break; end; except // except ブロック end; end; end. ``` 例外の基本クラスである `Exception` は `System.SysUtils` で定義されているので **uses** に追加します。Delphi XE 以前では単に `SysUtils` を **uses** してください。 ```pascal program basics(input, output); {$APPTYPE CONSOLE} uses // 追加 System.SysUtils; // 追加 //label 88, 77, 99; ... ``` prterr() 内を書き換えます。 ```pascal ... end; //goto 88 { loop to ready } // 削除 raise Exception.Create('88'); { loop to ready } // 追加 end; ``` stat() 内を書き換えます。 ```pascal ... //cstop: goto 88; // 削除　　 cstop: raise Exception.Create('88'); // 追加 ... // cnew: begin clear; goto 88 end; // 削除　 cnew: begin clear; raise Exception.Create('88'); end; // 追加 ... ``` ### goto 1 `goto 1` も例外を投げるようにしますが、メインブロックの内側なので `goto 88` を処理できなくなります。簡単に言えば `goto 1` は 1 段外、`goto 88` は 2 段外に抜ける必要があります。とりあえず `goto 1` では例外を投げるようにしましょう。 ```pascal ... cgoto: begin prgmc := schlab(getint); //goto 1 // 削除 raise Exception.Create('1'); // 追加 end; ... cif: begin expr; if temp[top].typ <> tint then prterr(eexmi); if temp[top].int = 0 then begin top := top - 1; { go next line } if prgmc > 0 then prgmc := prgmc + 1; //goto 1 // 削除 raise Exception.Create('1'); // 追加 end; top := top - 1; b := chknxt(chr(cthen)); stat end; crem: begin if prgmc > 0 then prgmc := prgmc + 1; { go next line } //goto 1 { exit line executive } // 削除 raise Exception.Create('1'); // 追加 end; cstop: raise Exception.Create('88'); //crun: begin clrvar; prgmc := 1; goto 1 end; // 削除 crun: begin clrvar; prgmc := 1; raise Exception.Create('1'); end; // 追加 ... ``` exec() 内では例外を調べ `88` なら再度例外を投げて外側のメインブロックでも例外処理に引っかかるようにします。 ```pascal ... begin { exec } try // 例外処理 linec := 1; while digit(chkchr) do c := getchr; { skip label } repeat stat until getchr <> ':'; skpspc; if not chkend then prterr(eedlexp); { should be at line end } if prgmc > 0 then prgmc := prgmc + 1; except // except ブロック on E: Exception do begin if E.Message = '88' then // '88' なら raise; // 再度例外を投げる。 end; end; end; { exec } ``` 上記の例外処理は本当のエラーすら握りつぶしてしまう(よくない)コードなのですが、今回のはサンプルなのでこれでよしとしておきます。 ## ワーニングを潰す 幾つかワーニングが出ます。ウザイので潰します。 まずは chknxt()。`c に代入された値は使われていません`、と。 戻り値は利用しませんが `getchr()` は実行しなきゃいけないのでこうします。 ```pascal ... function chknxt(c : char) : boolean; begin chknxt := c = chkchr; // if c = chkchr then c := getchr // 削除 if c = chkchr then getchr // 追加 end; ``` `skpspc()` も同様。変数も要らないので削除します。 ```pascal ... procedure skpspc; //var c: char; // 削除 begin //while (chkchr = ' ') and not chkend do c := getchr; // 削除 while (chkchr = ' ') and not chkend do getchr; // 追加 end; ``` `stat()` の中のも同様です。 ```pascal ... procedure stat; var x, y: integer; c: char; s: string80; //b: boolean; 削除 ``` こちらは `chknxt()` の戻り値を利用していません。 ```pascal ... cif: begin expr; if temp[top].typ <> tint then prterr(eexmi); if temp[top].int = 0 then begin top := top - 1; { go next line } if prgmc > 0 then prgmc := prgmc + 1; //goto 1 raise Exception.Create('1'); end; top := top - 1; //b := chknxt(chr(cthen)); // 削除 chknxt(chr(cthen)); // 追加 stat end; ``` `exec()` の中の `getchr()` も同様です。 ```pascal ... begin { exec } try linec := 1; //while digit(chkchr) do c := getchr; { skip label } // 削除 while digit(chkchr) do getchr; { skip label } // 追加 repeat stat until getchr <> ':'; skpspc; if not chkend then prterr(eedlexp); { should be at line end } if prgmc > 0 then prgmc := prgmc + 1; except on E: Exception do begin if E.Message = '88' then raise; end; end; end; { exec } ``` 変数も不要です。ラベル 1 も削除しておきます。 ```pascal ... procedure exec; //label 1; { exit procedure } // 削除 //var c: char; // 削除 ``` ## 実行 これで Basic-S が実行できるようになりました！  Basic-S を抜けるには `bye` とタイプしましょう。 # おわりに ソースコードのヘッダコメントにはイロイロと注意点が書いてありますのでよく読む事をオススメします。なお、本記事は Pascal-S の記事のほぼコピペです。 - [Delphi で Pascal-S をコンパイルする (Qiita)](./77052d1f3c3c1a927034.md) - [Delphi で Pascal-S をコンパイルする (ANSI 版 Delphi) (Qiita)](./f4391f6f8b4b87a1fcf0.md) - [Delphi で Pascal-S をコンパイルする (16bit 版 Delphi) (Qiita)](./7b8db26fb7ce91542dd9.md) TinyBasic と言えば、Arduino の Tiny Basic も面白いですよね。 - [Tiny Basic を動かしてみる](https://ht-deko.com/arduino/tinybasic.html) - [Tiny Basic Plus を動かしてみる](https://ht-deko.com/arduino/tinybasicplus.html) ## 改変ソースコード basics.pas は Delphi のコードフォーマッタを使うとインデントが崩れる箇所があります。古の記述方法がダメなようです。以下に手動で整形したソースコードを置いておきます。 ```pascal:basics.dpr {****************************************************************************** * * * TINY PASCAL BASIC * * * * 1980 S. A. MOORE * * * * Implements a small basic in Pascal. An example of how small a program can * * be to implement a simple language. * * Variables are allowed, using the letters "a" thru "z". Integers are denoted * * by the letters alone. Strings are denoted by "a$" form. * * The following statements are implemented: * * * * input Reads the contents of the variable from the user. * * If the variable is integer, a line is read from the * * user, then any spaces on the line skipped, then a * * number read. * * If the variable is string, the entire line is * * assigned to it, including any spaces. * * * * print [, Control resumes at the line specified by the integer. * * Note that no "calculated gotos" are allowed. * * * * if then The expression must be a integer. If the * * condition is 0, control resumes on the next line. * * if the condition is not 0, the statement after "then" * * is executed (as well as the rest of the line). * * * * rem The entire rest of the line is ignored. * * * * stop Terminates program execution. The values of variables * * are not cleared. * * * * run All variables are cleared, with integers becoming 0, * * and strings becoming empty. Then control passes to * * the first statement in the program. * * * * list [[,]] Lists all program lines between the given lines. * * The default if no lines are given is the starting * * and ending lines of the entire program. * * * * new Clears the entire program and stops execution. * * * * [let] = Assigns the value of the expression to the * * variable. The variable must be the same type (string * * or integer) as the expression. The "let" keyword is * * optional. * * * * bye Exits basic for the operating system. * * * * Expressions can contain the following operators: * * * * <, >, =, <>, <=, >= Comparision. * * +, -, *, /, mod Basic math. * * left$(, ) The leftmost characters of the string. * * right$(, ) The rightmost characters of the string. * * mid$(, , ) The middle characters of the string. * * str$() The string form of the integer expression. * * val() The integer equivalent of the string. * * chr() The ascii value of the first character. * * * * The internal form of the program is keyword compressed for effiency, which * * both allows for a smaller internal program, and simplifies the decoding of * * keywords. * * * * * * Notes: * * * * 1. If the program store were of the same form as basic strings, routines * * that handle both in common could be used (example: getting a number from * * the string). * * * ******************************************************************************} program basics(input, output); {$APPTYPE CONSOLE} uses System.SysUtils; const maxlin = 9999; { maximum line number } maxpgm = 100; { maximum line store } maxstk = 10; { maximum temp count } maxkey = 29; { maximum key store } { key codes } cinput = 1; cprint = 2; cgoto = 3; cif = 4; crem = 5; cstop = 6; crun = 7; clist = 8; cnew = 9; clet = 10; cbye = 11; clequ = 12; cgequ = 13; cequ = 14; cnequ = 15; cltn = 16; cgtn = 17; cadd = 18; csub = 19; cmult = 20; cdiv = 21; cmod = 22; cleft = 23; cright = 24; cmid = 25; cthen = 26; cstr = 27; cval = 28; cchr = 29; type string10 = packed array [1..10] of char; { key } string80 = packed array [1..80] of char; { general string } bstring80 = record len : integer; str : string80 end; vartyp = (tint, tstr); { variable type } { error codes } errcod = (eitp, estate, eexmi, eeque, estyp, epbful, eiovf, evare, elabnf, einte, econv, elntl, ewtyp, erpe, eexc, emqu, eifact, elintl, estrovf, eedlexp, elpe, ecmaexp, estre, estrinx); var prgm: array [0..maxpgm] of string80; { program store } strs: array ['a'..'z'] of bstring80; { string store } ints: array ['a'..'z'] of integer; { integer store } keywd: array [cinput..cchr] of string10; { keywords } temp: array [1..maxstk] of record typ : vartyp; int : integer; bstr : bstring80 end; prgmc, { program counter (0 = input line) } top, { current temps top } linec: integer; { character position } { print key compressed line } procedure prtlin(var str: string80); var i, j: integer; procedure prtkey(var str: string10); var i, j: integer; begin { prtkey } j := 10; while (str[j] = ' ') and (j > 0) do j := j - 1; j := j + 1; i := 1; while i < j do begin write(str[i]); i := i + 1 end end; { prtkey } begin { prtlin } j := 80; while (str[j] = ' ') and (j > 0) do j := j - 1; j := j + 1; i := 1; while i < j do begin if ord(str[i]) < ord(' ') then prtkey(keywd[ord(str[i])]) else write(str[i]); i := i + 1 end; writeln end; { prtlin } { print error } procedure prterr(err: errcod); begin if prgmc <> 0 then prtlin(prgm[prgmc]); write('*** '); case err of eitp: writeln('Interpreter error'); estate: writeln('Statement expected'); eexmi: writeln('Expression must be integer'); eeque: writeln('"=" expected'); estyp: writeln('Operands not of same type'); epbful: writeln('Program buffer full'); eiovf: writeln('Input overflow'); evare: writeln('Variable expected'); elabnf: writeln('Statement label not found'); einte: writeln('Integer expected'); econv: writeln('Conversion error'); elntl: writeln('Line number too large'); ewtyp: writeln('Operand(s) of wrong type'); erpe: writeln('")" expected'); eexc: writeln('Expression too complex'); emqu: writeln('Missing quote'); eifact: writeln('Invalid factor'); elintl: writeln('Line number too large'); estrovf: writeln('String overflow'); eedlexp: writeln('End of line expected'); elpe: writeln('"(" expected'); ecmaexp: writeln('"," expected'); estre: writeln('String expected'); estrinx: writeln('String indexing error') end; raise Exception.Create('88'); { loop to ready } end; { prterr } { check character } function chkchr: char; var c: char; begin if linec <= 80 then c := prgm[prgmc][linec] else c := ' '; chkchr := c end; { chkchr } { check end of line } function chkend: boolean; begin chkend := linec > 80 { past end of line } end; { chkend } { get character } function getchr: char; begin getchr := chkchr; if not chkend then linec := linec + 1 end; { getchr } { check next character } function chknxt(c: char): boolean; begin chknxt := c = chkchr; if c = chkchr then getchr end; { chknxt } { skip spaces } procedure skpspc; begin while (chkchr = ' ') and not chkend do getchr; end; { skpspc } { check end of statement } function chksend: boolean; begin skpspc; { skip spaces } chksend := chkend or (chkchr = ':') { check eoln or ':' } end; { chksend } { check null string } function null(var str: string80): boolean; var i: integer; f: boolean; begin f := true; for i := 1 to 80 do if str[i] <> ' ' then f := false; null := f end; { null } { check digit } function digit(c: char): boolean; begin digit := (ord(c) >= ord('0')) and (ord(c) <= ord('9')) end; { digit } { convert to lower case } function lcase(c: char): char; begin if (ord(c) >= ord('A')) and (ord(c) <= ord('Z')) then c := chr(ord(c) - ord('A') + ord('a')); lcase := c end; { lcase } { check alphabetical } function alpha(c: char): boolean; begin alpha := (ord(lcase(c)) >= ord('a')) and (ord(c) <= ord('z')) end; { alpha } { parse leading integer } function lint(var str: string80): integer; var i, v: integer; b: boolean; begin v := 0; i := 1; while (i < 80) and (str[i] = ' ') do i := i + 1; repeat if digit(str[i]) then begin v := v * 10 + (ord(str[i]) - ord('0')); if i <> 80 then begin i := i + 1; b := false end else b := true end else b := true until b; lint := v end; { lint } { search label } function schlab(lab: integer): integer; var i: integer; begin i := 1; while (lab <> lint(prgm[i])) and (i <= maxpgm) do i := i + 1; if lab <> lint(prgm[i]) then prterr(elabnf); schlab := i end; { schlab } { input string } procedure inpstr(var str: string80); var i: integer; begin for i := 1 to 80 do str[i] := ' '; i := 1; while (i <= 80) and not eoln do begin read(str[i]); i := i + 1 end; readln; if (i > 80) then prterr(eiovf) end; { inpstr } { parse variable reference } function getvar: char; begin if not alpha(chkchr) then prterr(evare); getvar := lcase(getchr) end; { getvar } { enter line to store } procedure enter(var str: string80); var line, i, j, k: integer; f: boolean; begin line := lint(str); if line > maxlin then prterr(elintl); { input line number to large } i := 1; f := false; repeat if null(prgm[i]) then f := true else if lint(prgm[i]) < line then begin i := i + 1; if i > maxpgm then f := true end else f := true until f; if i > maxpgm then prterr(epbful); if null(prgm[i]) then prgm[i] := str else if lint(prgm[i]) = line then begin j := 1; while (str[j] = ' ') and (j < 80) do j := j + 1; while digit(str[j]) and (j < 80) do j := j + 1; while (str[j] = ' ') and (j < 80) do j := j + 1; if j = 80 then begin for k := i to maxpgm - 1 do prgm[k] := prgm[k + 1]; for j := 1 to 80 do prgm[maxpgm][j] := ' ' end else prgm[i] := str end else if not null(prgm[maxpgm]) then prterr(epbful) else begin for k := maxpgm downto i + 1 do prgm[k] := prgm[k - 1]; prgm[i] := str end end; { enter } { compress keys } procedure keycom(var str: string80); var ts: string80; k, i1, i2: integer; f: boolean; c: char; function matstr(var stra: string80; var i: integer; var strb: string10): boolean; var i1, i2: integer; f: boolean; begin { matstr } i1 := i; i2 := 1; repeat if strb[i2] = ' ' then f := false else if lcase(stra[i1]) = lcase(strb[i2]) then begin f := true; i1 := i1 + 1; i2 := i2 + 1 end else f := false until not f or (i1 > 80) or (i2 > 10); if i2 > 10 then begin f := true; i := i1 end else if strb[i2] = ' ' then begin f := true; i := i1 end else f := false; matstr := f end; { matstr } begin { keycom } for i2 := 1 to 80 do ts[i2] := ' '; i1 := 1; i2 := 1; repeat if str[i1] = '"' then begin ts[i2] := '"'; i1 := i1 + 1; i2 := i2 + 1; c := ' '; while (i1 <= 80) and (c <> '"') do begin c := str[i1]; ts[i2] := str[i1]; i1 := i1 + 1; i2 := i2 + 1 end end else if str[i1] = ' ' then begin ts[i2] := str[i1]; i1 := i1 + 1; i2 := i2 + 1 end else begin k := 1; f := false; while (k <= maxkey) and not f do begin f := matstr(str, i1, keywd[k]); k := k + 1 end; if f then ts[i2] := chr(k - 1) else begin ts[i2] := str[i1]; i1 := i1 + 1 end; i2 := i2 + 1 end until i1 > 80; for i1 := 1 to 80 do str[i1] := ts[i1] { this diagnostic prints the resulting tolken sequence } { ;for i1 := 1 to 80 do write(ord(str[i1]), ' '); } end; { keycom } { get integer } function getint: integer; var v: integer; begin v := 0; skpspc; if not digit(chkchr) then prterr(einte); repeat v := v * 10 + (ord(getchr) - ord('0')) until not digit(chkchr); getint := v end; { getint } { get integer from string } function getval(var str: string80): integer; var i: integer; begin i := 1; while (i <= 80) and (str[i] = ' ') do i := i + 1; if not digit(str[i]) then prterr(einte); getval := lint(str); while (i < 80) and digit(str[i]) do i := i + 1; while (i < 80) and (str[i] = ' ') do i := i + 1; if i <> 80 then prterr(econv) end; { getval } { get integer from basic string } function getbval(var str: bstring80): integer; var i, v: integer; begin i := 1; while (i <= str.len) and (str.str[i] = ' ') do i := i + 1; { skip spaces } if not digit(str.str[i]) then prterr(einte); { number not present } v := 0; { clear result } while (i <= str.len) and digit(str.str[i]) do begin { parse digit } v := v * 10 + ord(str.str[i]) - ord('0'); { scale, convert and add in digit } i := i + 1 { next character } end; while (i <= str.len) and (str.str[i] = ' ') do i := i + 1; if i <= str.len then prterr(econv); getbval := v { return result } end; { getbval } { place integer to string } procedure putbval(var str: bstring80; v: integer); var p: integer; { power holder } i: integer; { string index } begin str.len := 0; { clear result string } p := 10000; { set maximum power } i := 1; { set 1st character } if v < 0 then begin { negative } str.str[i] := '-'; { place minus sign } i := i + 1; { next character } v := -v { negate number } end; while p <> 0 do begin { fit powers } str.str[i] := chr(v div p + ord('0')); { place digit } if str.str[1] = '-' then begin { negative } if (str.str[2] <> '0') or (p = 1) then i := i + 1; { next digit } end else { positive } if (str.str[1] <> '0') or (p = 1) then i := i + 1; { next digit } v := v mod p; { remove from value } p := p div 10 { find next power } end; str.len := i - 1 { set length of string } end; { putbval } { print basic string } procedure prtbstr(var bstr: bstring80); var i: integer; begin for i := 1 to bstr.len do write(bstr.str[i]); end; { prtbstr } { input basic string } procedure inpbstr(var bstr: bstring80); var i: integer; begin for i := 1 to 80 do bstr.str[i] := ' '; i := 1; while (i < 80) and not eoln do begin read(bstr.str[i]); i := i + 1 end; if (i > 80) and not eoln then prterr(eiovf); readln; bstr.len := i end; { inpbstr } { concatenate basic strings } procedure cat(var bstra, bstrb: bstring80); var i: integer; { index for string } begin if (bstra.len + bstrb.len) > 80 then prterr(estrovf); { string overflow } { copy source after destination } for i := 1 to bstrb.len do bstra.str[bstra.len + i] := bstrb.str[i]; bstra.len := bstra.len + bstrb.len { set new length } end; { cat } { check stack items equal } function chkequ: boolean; begin if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then prterr(ewtyp); chkequ := temp[top - 1].int = temp[top].int end; { chkequ } { check stack items less than } function chkltn: boolean; begin if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then prterr(ewtyp); chkltn := temp[top - 1].int < temp[top].int end; { chkltn } { check stack items greater than } function chkgtn: boolean; begin if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then prterr(ewtyp); chkgtn := temp[top - 1].int > temp[top].int end; { chkgtn } { set tos true } procedure settrue; begin temp[top].typ := tint; temp[top].int := 1 end; { settrue } { set tos false } procedure setfalse; begin temp[top].typ := tint; temp[top].int := 0 end; { setfalse } { clear program store } procedure clear; var x, y: integer; c: char; begin for x := 1 to maxpgm do for y := 1 to 80 do prgm[x][y] := ' '; for c := 'a' to 'z' do strs[c].len := 0; for c := 'a' to 'z' do ints[c] := 0; prgmc := 0; linec := 1; top := 1 end; { clear } { clear variable store } procedure clrvar; var c: char; begin for c := 'a' to 'z' do strs[c].len := 0; for c := 'a' to 'z' do ints[c] := 0; prgmc := 0; linec := 1; top := 1 end; { clrvar } { execute string } procedure exec; { execute statement } procedure stat; var x, y: integer; c: char; s: string80; { parse expression } procedure expr; { parse simple expression } procedure sexpr; { parse term } procedure term; { parse factor } procedure factor; var i: integer; c: char; begin { factor } skpspc; c := chkchr; { save starting character } if chknxt('(') then begin expr; if not chknxt(')') then prterr(erpe) end else if chknxt(chr(cadd)) then begin factor; if temp[top].typ <> tint then prterr(ewtyp) end else if chknxt(chr(csub)) then begin factor; if temp[top].typ <> tint then prterr(ewtyp); temp[top].int := -temp[top].int end else if chknxt('"') then begin top := top + 1; if top > maxstk then prterr(eexc); temp[top].typ := tstr; i := 1; while (i <= 80) and (chkchr <> '"') do begin temp[top].bstr.str[i] := getchr; i := i + 1 end; if not chknxt('"') then prterr(emqu); temp[top].bstr.len := i - 1 end else if digit(chkchr) then begin top := top + 1; if top > maxstk then prterr(eexc); temp[top].typ := tint; temp[top].int := getint end else if alpha(chkchr) then begin top := top + 1; if top > maxstk then prterr(eexc); c := getvar; if chknxt('$') then begin temp[top].typ := tstr; temp[top].bstr := strs[c] end else begin temp[top].typ := tint; temp[top].int := ints[c] end end else if chknxt(chr(cleft)) or chknxt(chr(cright)) or chknxt(chr(cmid)) then begin { left$, right$ } skpspc; { skip spaces } if not chknxt('(') then prterr(elpe); { '(' expected } expr; { parse expression } if temp[top].typ <> tstr then prterr(estre); { string expected } skpspc; { skip spaces } if not chknxt(',') then prterr(ecmaexp); { ',' expected } expr; { parse expression } if temp[top].typ <> tint then prterr(einte); { integer expected } skpspc; { skip spaces } if c <> chr(cmid) then begin { left$ or right$ } if not chknxt(')') then prterr(erpe); { ')' expected } if temp[top].int > temp[top - 1].bstr.len then prterr(estrinx); if c = chr(cright) then { right$ } for i := 1 to temp[top].int do { move string left } temp[top - 1].bstr.str[i] := temp[top - 1].bstr.str[i + temp[top - 1].bstr.len - temp[top].int]; temp[top - 1].bstr.len := temp[top].int; { set new length left } top := top - 1 { clean stack } end else begin { mid$ } if not chknxt(',') then prterr(ecmaexp); { ',' expected } expr; { parse end expression } if temp[top].typ <> tint then prterr(einte); { integer expected } skpspc; { skip spaces } if not chknxt(')') then prterr(erpe); { ')' expected } { check requested length > string length } if temp[top].int + temp[top - 1].int - 1 > temp[top - 2].bstr.len then prterr(estrinx); for i := 1 to temp[top].int do { move string left } temp[top - 2].bstr.str[i] := temp[top - 2].bstr.str[i + temp[top - 1].int - 1]; temp[top - 2].bstr.len := temp[top].int; { set new length left } top := top - 2 { clean stack } end end else if chknxt(chr(cchr)) then begin { chr } if not chknxt('(') then prterr(elpe); { '(' expected } expr; { parse expression } if temp[top].typ <> tstr then prterr(estre); { string expected } skpspc; { skip spaces } if not chknxt(')') then prterr(erpe); { ')' expected } if temp[top].bstr.len < 1 then prterr(estrinx); { check valid } c := temp[top].bstr.str[1]; { get the 1st character } temp[top].typ := tint; { change to integer } temp[top].int := ord(c) { place result } end else if chknxt(chr(cval)) then begin { val } if not chknxt('(') then prterr(elpe); { '(' expected } expr; { parse expression } if temp[top].typ <> tstr then prterr(estre); { string expected } skpspc; { skip spaces } if not chknxt(')') then prterr(erpe); { ')' expected } i := getbval(temp[top].bstr); { get string value } temp[top].typ := tint; { change to integer } temp[top].int := i { place result } end else if chknxt(chr(cstr)) then begin { str$ } if not chknxt('(') then prterr(elpe); { '(' expected } expr; { parse expression } if temp[top].typ <> tint then prterr(einte); { integer expected } skpspc; { skip spaces } if not chknxt(')') then prterr(erpe); { ')' expected } i := temp[top].int; { get value } temp[top].typ := tstr; { change to string } putbval(temp[top].bstr, i) { place value in ascii } end else prterr(eifact) end; { factor } begin { term } factor; skpspc; while ord(chkchr) in [cmult, cdiv, cmod] do begin case ord(getchr) of { tolken } cmult: begin { * } factor; if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then prterr(ewtyp); temp[top - 1].int := temp[top - 1].int * temp[top].int; top := top - 1 end; cdiv: begin { / } factor; if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then prterr(ewtyp); temp[top - 1].int := temp[top - 1].int div temp[top].int; top := top - 1 end; cmod: begin { mod } factor; if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then prterr(ewtyp); temp[top - 1].int := temp[top - 1].int mod temp[top].int; top := top - 1 end end; skpspc { skip spaces } end end; { term } begin { sexpr } term; skpspc; while ord(chkchr) in [cadd, csub] do begin case ord(getchr) of { tolken } cadd: begin term; if temp[top].typ = tstr then begin if temp[top - 1].typ <> tstr then prterr(estyp); cat(temp[top - 1].bstr, temp[top].bstr); top := top - 1 end else begin if temp[top - 1].typ <> tint then prterr(estyp); temp[top - 1].int := temp[top - 1].int + temp[top].int; top := top - 1; end end; csub: begin { - } term; if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then prterr(ewtyp); temp[top - 1].int := temp[top - 1].int - temp[top].int; top := top - 1 end end; skpspc { skip spaces } end end; { sexpr } begin { expr } sexpr; { parse simple expression } skpspc; { skip spaces } while ord(chkchr) in [cequ, cnequ, cltn, cgtn, clequ, cgequ] do begin case ord(getchr) of { tolken } cequ: begin sexpr; if chkequ then begin top := top - 1; settrue end else begin top := top - 1; setfalse end end; cnequ: begin sexpr; if chkequ then begin top := top - 1; setfalse end else begin top := top - 1; settrue end end; cltn: begin sexpr; if chkltn then begin top := top - 1; settrue end else begin top := top - 1; setfalse end end; cgtn: begin sexpr; if chkgtn then begin top := top - 1; settrue end else begin top := top - 1; setfalse end end; clequ: begin sexpr; if chkgtn then begin top := top - 1; setfalse end else begin top := top - 1; settrue end end; cgequ: begin sexpr; if chkltn then begin top := top - 1; setfalse end else begin top := top - 1; settrue end end end; skpspc { skip spaces } end end; { expr } { process "let" function } procedure let; begin skpspc; c := getvar; if chknxt('$') then begin skpspc; if not chknxt(chr(cequ)) then prterr(eeque); expr; if temp[top].typ <> tstr then prterr(estyp); strs[c] := temp[top].bstr; top := top - 1 end else begin skpspc; if not chknxt(chr(cequ)) then prterr(eeque); expr; if temp[top].typ <> tint then prterr(estyp); ints[c] := temp[top].int; top := top - 1 end end; begin { stat } skpspc; if ord(chkchr) < ord(' ') then begin if ord(chkchr) > cbye then prterr(estate); case ord(getchr) of { statement } cinput: begin skpspc; c := getvar; if chknxt('$') then inpbstr(strs[c]) else begin inpstr(s); ints[c] := getval(s) end end; cprint: begin repeat { list items } expr; if temp[top].typ = tstr then prtbstr(temp[top].bstr) else write(temp[top].int); top := top - 1; skpspc until not chknxt(','); { until not ',' } if not chknxt(';') then writeln end; cgoto: begin prgmc := schlab(getint); raise Exception.Create('1'); end; cif: begin expr; if temp[top].typ <> tint then prterr(eexmi); if temp[top].int = 0 then begin top := top - 1; { go next line } if prgmc > 0 then prgmc := prgmc + 1; raise Exception.Create('1'); end; top := top - 1; chknxt(chr(cthen)); stat end; crem: begin if prgmc > 0 then prgmc := prgmc + 1; { go next line } raise Exception.Create('1'); end; cstop: raise Exception.Create('88'); crun: begin clrvar; prgmc := 1; raise Exception.Create('1'); end; clist: begin x := 1; { set default list swath } y := maxpgm; if not chksend then begin { list swath is specified } x := schlab(getint); skpspc; { check if end line is specified } if chknxt(',') then y := schlab(getint) end; for x := x to y do { print specified lines } if not null(prgm[x]) then { line exists in buffer } prtlin(prgm[x]) { print } end; cnew: begin clear; raise Exception.Create('88'); end; clet: let; cbye: begin writeln; Halt; end; end end else let { default let } end; { stat } begin { exec } try linec := 1; while digit(chkchr) do getchr; { skip label } repeat stat until getchr <> ':'; skpspc; if not chkend then prterr(eedlexp); { should be at line end } if prgmc > 0 then prgmc := prgmc + 1; except on E: Exception do begin if E.Message = '88' then raise; end; end; end; { exec } begin { executive } clear; { initalize keys } keywd[cinput] := 'input '; keywd[cprint] := 'print '; keywd[cgoto] := 'goto '; keywd[cif] := 'if '; keywd[crem] := 'rem '; keywd[cstop] := 'stop '; keywd[crun] := 'run '; keywd[clist] := 'list '; keywd[cnew] := 'new '; keywd[clet] := 'let '; keywd[cbye] := 'bye '; keywd[clequ] := '<= '; keywd[cgequ] := '>= '; keywd[cequ] := '= '; keywd[cnequ] := '<> '; keywd[cltn] := '< '; keywd[cgtn] := '> '; keywd[cadd] := '+ '; keywd[csub] := '- '; keywd[cmult] := '* '; keywd[cdiv] := '/ '; keywd[cmod] := 'mod '; keywd[cleft] := 'left$ '; keywd[cright] := 'right$ '; keywd[cmid] := 'mid$ '; keywd[cthen] := 'then '; keywd[cstr] := 'str$ '; keywd[cval] := 'val '; keywd[cchr] := 'chr '; writeln; writeln('Tiny basic interpreter vs. 0.1 Copyright (C) 1994 S. A. Moore'); writeln; while true do begin try writeln('Ready'); while true do begin prgmc := 0; linec := 1; top := 0; { get user lines until non-blank } repeat inpstr(prgm[0]) until not null(prgm[0]); keycom(prgm[0]); if lint(prgm[0]) > 0 then begin enter(prgm[0]); Continue; end else repeat exec; if (prgmc > maxpgm) then prgmc := 0 else if null(prgm[prgmc]) then prgmc := 0 until prgmc = 0; Break; end; except end; end; end. ``` 空行をかなり抜いたので、整形しても行数はあまり変わりませんね。ふんだんに関数内関数が使われているので、Pascal のソースコードに慣れてない方にはちょっと読みづらいかもしれません