はじめに
Basic-S という 1,300 行程度の Pascal で書かれた Tiny Basic があります。Pascal-S の改変版を公開されている S.A.MOORE 氏の作です。
本記事はその Basic-S を Delphi でコンパイルしてみようという趣旨です。使用する Delphi は 2009 以降であれば大丈夫だと思います。最新版の 10.3 Rio でも大丈夫ですし、無償版の Community Edition でももちろん大丈夫です。
修正
Basic-S のソースコード をそのままコンパイルできる Pascal コンパイラは以下の 3 つです。ISO 7185 に準拠していればそのままコンパイルできると思います。
Delphi ではちょっとした修正を行わないとコンパイルが通りません。
以降で修正を行いますので、まずはファイルを適当な場所に展開しておいてください。
プロジェクトを開く
Basic-S は単一のソースファイル (basicss.pas) で構成されているので、これを Delphi で開けるように拡張子を *dpr に変更します。
[ファイル | プロジェクトを開く] で basics.dpr を開きます。
コードの修正 (コンパイルエラーの除去)
まずはコンパイルエラーになる箇所をすべて潰します。
コンソールアプリケーションの指定
コンソールアプリケーションとして動作させるために、{$APPTYPE CONSOLE} を追加します。
...
program basics(input, output);
{$APPTYPE CONSOLE} // 追加
label 88, 77, 99;
...
ラベルを削除
goto による大域ジャンプが行われていますので、これを修正します...判りにくいので修正の前にメインブロックを整形します。
...
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() で置き換えます。まずはラベルの宣言を削除します。
...
program basics(input, output);
{$APPTYPE CONSOLE}
// label 88, 77, 99; // 削除
...
stat() の中を書き換えます。
...
clet: let;
//cbye: goto 99 // 削除
cbye: begin // 追加
Writeln; // 追加
Halt; // 追加
end; // 追加
end
end else let { default let }
end; { stat }
メインブロックの中のラベルを削除します。
...
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 か所しか使われておらず大域ジャンプでもないのでそのままでもいいのですが、面倒なのでなくします。
...
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 では例外を投げるようにし、例外処理でループさせるようにします。
メインブロックはこうなります。
...
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 してください。
program basics(input, output);
{$APPTYPE CONSOLE}
uses // 追加
System.SysUtils; // 追加
//label 88, 77, 99;
...
prterr() 内を書き換えます。
...
end;
//goto 88 { loop to ready } // 削除
raise Exception.Create('88'); { loop to ready } // 追加
end;
stat() 内を書き換えます。
...
//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 では例外を投げるようにしましょう。
...
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 なら再度例外を投げて外側のメインブロックでも例外処理に引っかかるようにします。
...
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() は実行しなきゃいけないのでこうします。
...
function chknxt(c : char) : boolean;
begin
chknxt := c = chkchr;
// if c = chkchr then c := getchr // 削除
if c = chkchr then getchr // 追加
end;
skpspc() も同様。変数も要らないので削除します。
...
procedure skpspc;
//var c: char; // 削除
begin
//while (chkchr = ' ') and not chkend do c := getchr; // 削除
while (chkchr = ' ') and not chkend do getchr; // 追加
end;
stat() の中のも同様です。
...
procedure stat;
var x, y: integer;
c: char;
s: string80;
//b: boolean; 削除
こちらは chknxt() の戻り値を利用していません。
...
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() も同様です。
...
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 も削除しておきます。
...
procedure exec;
//label 1; { exit procedure } // 削除
//var c: char; // 削除
実行
これで Basic-S が実行できるようになりました！
Basic-S を抜けるには bye とタイプしましょう。
おわりに
ソースコードのヘッダコメントにはイロイロと注意点が書いてありますのでよく読む事をオススメします。なお、本記事は Pascal-S の記事のほぼコピペです。
- Delphi で Pascal-S をコンパイルする (Qiita)
- Delphi で Pascal-S をコンパイルする (ANSI 版 Delphi) (Qiita)
- Delphi で Pascal-S をコンパイルする (16bit 版 Delphi) (Qiita)
TinyBasic と言えば、Arduino の Tiny Basic も面白いですよね。
改変ソースコード
basics.pas は Delphi のコードフォーマッタを使うとインデントが崩れる箇所があります。古の記述方法がダメなようです。以下に手動で整形したソースコードを置いておきます。
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 <variable> 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 <expr> [,<expr].. [;] Prints the expression. The expression can be *
* integer or string. If a trailing ";" exists, the next *
* print will resume on the same line. Any number of *
* items may appear to be printed on the same line, *
* separated by ",". *
* *
* goto <integer> Control resumes at the line specified by the integer. *
* Note that no "calculated gotos" are allowed. *
* *
* if <expr> then <statement> 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 <line> 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 [<start>[,<end>]] 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] <var> = <expr> 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$(<str>, <expr>) The leftmost characters of the string. *
* right$(<str>, <expr>) The rightmost characters of the string. *
* mid$(<str>, <start>, <len>) The middle characters of the string. *
* str$(<expr>) The string form of the integer expression. *
* val(<str>) The integer equivalent of the string. *
* chr(<str>) 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 のソースコードに慣れてない方にはちょっと読みづらいかもしれません