$ sysprog, ucsd, heap_dispose, partial_eval $
{$ debug$}
program basic(input, output);
const
checking = true;
varnamelen = 20;
maxdims = 4;
type
varnamestring = string[varnamelen];
string255 = string[255];
string255ptr = ^string255;
tokenkinds = (tokvar, toknum, tokstr, toksnerr,
tokplus, tokminus, toktimes, tokdiv, tokup, toklp, tokrp,
tokcomma, toksemi, tokcolon, tokeq, toklt, tokgt,
tokle, tokge, tokne,
tokand, tokor, tokxor, tokmod, toknot, toksqr, toksqrt, toksin,
tokcos, toktan, tokarctan, toklog, tokexp, tokabs, toksgn,
tokstr_, tokval, tokchr_, tokasc, toklen, tokmid_, tokpeek,
tokrem, toklet, tokprint, tokinput, tokgoto, tokif, tokend,
tokstop, tokfor, toknext, tokwhile, tokwend, tokgosub,
tokreturn, tokread, tokdata, tokrestore, tokgotoxy, tokon,
tokdim, tokpoke,
toklist, tokrun, toknew, tokload, tokmerge, toksave, tokbye,
tokdel, tokrenum,
tokthen, tokelse, tokto, tokstep);
realptr = ^real;
basicstring = string255ptr;
stringptr = ^basicstring;
numarray = array[0..maxint] of real;
arrayptr = ^numarray;
strarray = array[0..maxint] of basicstring;
strarrayptr = ^strarray;
tokenptr = ^tokenrec;
lineptr = ^linerec;
varptr = ^varrec;
loopptr = ^looprec;
tokenrec =
record
next : tokenptr;
case kind : tokenkinds of
tokvar : (vp : varptr);
toknum : (num : real);
tokstr, tokrem : (sp : string255ptr);
toksnerr : (snch : char);
end;
linerec =
record
num, num2 : integer;
txt : tokenptr;
next : lineptr;
end;
varrec =
record
name : varnamestring;
next : varptr;
dims : array [1..maxdims] of integer;
numdims : 0..maxdims;
case stringvar : boolean of
false : (arr : arrayptr; val : realptr; rv : real);
true : (sarr : strarrayptr; sval : stringptr; sv : basicstring);
end;
valrec =
record
case stringval : boolean of
false : (val : real);
true : (sval : basicstring);
end;
loopkind = (forloop, whileloop, gosubloop);
looprec =
record
next : loopptr;
homeline : lineptr;
hometok : tokenptr;
case kind : loopkind of
forloop :
( vp : varptr;
max, step : real );
end;
var
inbuf : string255ptr;
linebase : lineptr;
varbase : varptr;
loopbase : loopptr;
curline : integer;
stmtline, dataline : lineptr;
stmttok, datatok, buf : tokenptr;
exitflag : boolean;
excp_line ['EXCP_LINE'] : integer;
$if not checking$
$range off$
$end$
procedure misc_getioerrmsg(var s : string; io : integer);
external;
procedure misc_printerror(er, io : integer);
external;
function asm_iand(a, b : integer) : integer;
external;
function asm_ior(a, b : integer) : integer;
external;
procedure hpm_new(var p : anyptr; size : integer);
external;
procedure hpm_dispose(var p : anyptr; size : integer);
external;
procedure restoredata;
begin
dataline := nil;
datatok := nil;
end;
procedure clearloops;
var
l : loopptr;
begin
while loopbase <> nil do
begin
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
end;
end;
function arraysize(v : varptr) : integer;
var
i, j : integer;
begin
with v^ do
begin
if stringvar then
j := 4
else
j := 8;
for i := 1 to numdims do
j := j * dims[i];
end;
arraysize := j;
end;
procedure clearvar(v : varptr);
begin
with v^ do
begin
if numdims <> 0 then
hpm_dispose(arr, arraysize(v))
else if stringvar and (sv <> nil) then
dispose(sv);
numdims := 0;
if stringvar then
begin
sv := nil;
sval := addr(sv);
end
else
begin
rv := 0;
val := addr(rv);
end;
end;
end;
procedure clearvars;
var
v : varptr;
begin
v := varbase;
while v <> nil do
begin
clearvar(v);
v := v^.next;
end;
end;
function numtostr(n : real) : string255;
var
s : string255;
i : integer;
begin
setstrlen(s, 255);
if (n <> 0) and (abs(n) < 1e-2) or (abs(n) >= 1e12) then
begin
strwrite(s, 1, i, n);
setstrlen(s, i-1);
numtostr := s;
end
else
begin
strwrite(s, 1, i, n:30:10);
repeat
i := i - 1;
until s[i] <> '0';
if s[i] = '.' then
i := i - 1;
setstrlen(s, i);
numtostr := strltrim(s);
end;
end;
procedure parse(inbuf : string255ptr; var buf : tokenptr);
const
toklength = 20;
type
chset = set of char;
const
idchars = chset ['A'..'Z','a'..'z','0'..'9','_','$'];
var
i, j, k : integer;
token : string[toklength];
t, tptr : tokenptr;
v : varptr;
ch : char;
n, d, d1 : real;
begin
tptr := nil;
buf := nil;
i := 1;
repeat
ch := ' ';
while (i <= strlen(inbuf^)) and (ch = ' ') do
begin
ch := inbuf^[i];
i := i + 1;
end;
if ch <> ' ' then
begin
new(t);
if tptr = nil then
buf := t
else
tptr^.next := t;
tptr := t;
t^.next := nil;
case ch of
'A'..'Z', 'a'..'z' :
begin
i := i - 1;
j := 0;
setstrlen(token, strmax(token));
while (i <= strlen(inbuf^)) and (inbuf^[i] in idchars) do
begin
if j < toklength then
begin
j := j + 1;
token[j] := inbuf^[i];
end;
i := i + 1;
end;
setstrlen(token, j);
if (token = 'and') or (token = 'AND') then t^.kind := tokand
else if (token = 'or') or (token = 'OR') then t^.kind := tokor
else if (token = 'xor') or (token = 'XOR') then t^.kind := tokxor
else if (token = 'not') or (token = 'NOT') then t^.kind := toknot
else if (token = 'mod') or (token = 'MOD') then t^.kind := tokmod
else if (token = 'sqr') or (token = 'SQR') then t^.kind := toksqr
else if (token = 'sqrt') or (token = 'SQRT') then t^.kind := toksqrt
else if (token = 'sin') or (token = 'SIN') then t^.kind := toksin
else if (token = 'cos') or (token = 'COS') then t^.kind := tokcos
else if (token = 'tan') or (token = 'TAN') then t^.kind := toktan
else if (token = 'arctan') or (token = 'ARCTAN') then t^.kind := tokarctan
else if (token = 'log') or (token = 'LOG') then t^.kind := toklog
else if (token = 'exp') or (token = 'EXP') then t^.kind := tokexp
else if (token = 'abs') or (token = 'ABS') then t^.kind := tokabs
else if (token = 'sgn') or (token = 'SGN') then t^.kind := toksgn
else if (token = 'str$') or (token = 'STR$') then t^.kind := tokstr_
else if (token = 'val') or (token = 'VAL') then t^.kind := tokval
else if (token = 'chr$') or (token = 'CHR$') then t^.kind := tokchr_
else if (token = 'asc') or (token = 'ASC') then t^.kind := tokasc
else if (token = 'len') or (token = 'LEN') then t^.kind := toklen
else if (token = 'mid$') or (token = 'MID$') then t^.kind := tokmid_
else if (token = 'peek') or (token = 'PEEK') then t^.kind := tokpeek
else if (token = 'let') or (token = 'LET') then t^.kind := toklet
else if (token = 'print') or (token = 'PRINT') then t^.kind := tokprint
else if (token = 'input') or (token = 'INPUT') then t^.kind := tokinput
else if (token = 'goto') or (token = 'GOTO') then t^.kind := tokgoto
else if (token = 'go to') or (token = 'GO TO') then t^.kind := tokgoto
else if (token = 'if') or (token = 'IF') then t^.kind := tokif
else if (token = 'end') or (token = 'END') then t^.kind := tokend
else if (token = 'stop') or (token = 'STOP') then t^.kind := tokstop
else if (token = 'for') or (token = 'FOR') then t^.kind := tokfor
else if (token = 'next') or (token = 'NEXT') then t^.kind := toknext
else if (token = 'while') or (token = 'WHILE') then t^.kind := tokwhile
else if (token = 'wend') or (token = 'WEND') then t^.kind := tokwend
else if (token = 'gosub') or (token = 'GOSUB') then t^.kind := tokgosub
else if (token = 'return') or (token = 'RETURN') then t^.kind := tokreturn
else if (token = 'read') or (token = 'READ') then t^.kind := tokread
else if (token = 'data') or (token = 'DATA') then t^.kind := tokdata
else if (token = 'restore') or (token = 'RESTORE') then t^.kind := tokrestore
else if (token = 'gotoxy') or (token = 'GOTOXY') then t^.kind := tokgotoxy
else if (token = 'on') or (token = 'ON') then t^.kind := tokon
else if (token = 'dim') or (token = 'DIM') then t^.kind := tokdim
else if (token = 'poke') or (token = 'POKE') then t^.kind := tokpoke
else if (token = 'list') or (token = 'LIST') then t^.kind := toklist
else if (token = 'run') or (token = 'RUN') then t^.kind := tokrun
else if (token = 'new') or (token = 'NEW') then t^.kind := toknew
else if (token = 'load') or (token = 'LOAD') then t^.kind := tokload
else if (token = 'merge') or (token = 'MERGE') then t^.kind := tokmerge
else if (token = 'save') or (token = 'SAVE') then t^.kind := toksave
else if (token = 'bye') or (token = 'BYE') then t^.kind := tokbye
else if (token = 'quit') or (token = 'QUIT') then t^.kind := tokbye
else if (token = 'del') or (token = 'DEL') then t^.kind := tokdel
else if (token = 'renum') or (token = 'RENUM') then t^.kind := tokrenum
else if (token = 'then') or (token = 'THEN') then t^.kind := tokthen
else if (token = 'else') or (token = 'ELSE') then t^.kind := tokelse
else if (token = 'to') or (token = 'TO') then t^.kind := tokto
else if (token = 'step') or (token = 'STEP') then t^.kind := tokstep
else if (token = 'rem') or (token = 'REM') then
begin
t^.kind := tokrem;
new(t^.sp);
t^.sp^ := str(inbuf^, i, strlen(inbuf^)-i+1);
i := strlen(inbuf^)+1;
end
else
begin
t^.kind := tokvar;
v := varbase;
while (v <> nil) and (v^.name <> token) do
v := v^.next;
if v = nil then
begin
new(v);
v^.next := varbase;
varbase := v;
v^.name := token;
v^.numdims := 0;
if token[strlen(token)] = '$' then
begin
v^.stringvar := true;
v^.sv := nil;
v^.sval := addr(v^.sv);
end
else
begin
v^.stringvar := false;
v^.rv := 0;
v^.val := addr(v^.rv);
end;
end;
t^.vp := v;
end;
end;
'"', '''' :
begin
t^.kind := tokstr;
new(t^.sp);
setstrlen(t^.sp^, 255);
j := 0;
while (i <= strlen(inbuf^)) and (inbuf^[i] <> ch) do
begin
j := j + 1;
t^.sp^[j] := inbuf^[i];
i := i + 1;
end;
setstrlen(t^.sp^, j);
i := i + 1;
end;
'0'..'9', '.' :
begin
t^.kind := toknum;
n := 0;
d := 1;
d1 := 1;
i := i - 1;
while (i <= strlen(inbuf^)) and ((inbuf^[i] in ['0'..'9'])
or ((inbuf^[i] = '.') and (d1 = 1))) do
begin
if inbuf^[i] = '.' then
d1 := 10
else
begin
n := n * 10 + ord(inbuf^[i]) - 48;
d := d * d1;
end;
i := i + 1;
end;
n := n / d;
if (i <= strlen(inbuf^)) and (inbuf^[i] in ['e','E']) then
begin
i := i + 1;
d1 := 10;
if (i <= strlen(inbuf^)) and (inbuf^[i] in ['+','-']) then
begin
if inbuf^[i] = '-' then
d1 := 0.1;
i := i + 1;
end;
j := 0;
while (i <= strlen(inbuf^)) and (inbuf^[i] in ['0'..'9']) do
begin
j := j * 10 + ord(inbuf^[i]) - 48;
i := i + 1;
end;
for k := 1 to j do
n := n * d1;
end;
t^.num := n;
end;
'+' : t^.kind := tokplus;
'-' : t^.kind := tokminus;
'*' : t^.kind := toktimes;
'/' : t^.kind := tokdiv;
'^' : t^.kind := tokup;
'(', '[' : t^.kind := toklp;
')', ']' : t^.kind := tokrp;
',' : t^.kind := tokcomma;
';' : t^.kind := toksemi;
':' : t^.kind := tokcolon;
'?' : t^.kind := tokprint;
'=' : t^.kind := tokeq;
'<' :
begin
if (i <= strlen(inbuf^)) and (inbuf^[i] = '=') then
begin
t^.kind := tokle;
i := i + 1;
end
else if (i <= strlen(inbuf^)) and (inbuf^[i] = '>') then
begin
t^.kind := tokne;
i := i + 1;
end
else
t^.kind := toklt;
end;
'>' :
begin
if (i <= strlen(inbuf^)) and (inbuf^[i] = '=') then
begin
t^.kind := tokge;
i := i + 1;
end
else
t^.kind := tokgt;
end;
otherwise
begin
t^.kind := toksnerr;
t^.snch := ch;
end;
end;
end;
until i > strlen(inbuf^);
end;
procedure listtokens(var f : text; buf : tokenptr);
var
ltr, ltr0 : boolean;
begin
ltr := false;
while buf <> nil do
begin
if buf^.kind in [tokvar, toknum, toknot..tokrenum] then
begin
if ltr then write(f, ' ');
ltr := (buf^.kind <> toknot);
end
else
ltr := false;
case buf^.kind of
tokvar : write(f, buf^.vp^.name);
toknum : write(f, numtostr(buf^.num));
tokstr : write(f, '"', buf^.sp^, '"');
toksnerr : write(f, '{', buf^.snch, '}');
tokplus : write(f, '+');
tokminus : write(f, '-');
toktimes : write(f, '*');
tokdiv : write(f, '/');
tokup : write(f, '^');
toklp : write(f, '(');
tokrp : write(f, ')');
tokcomma : write(f, ',');
toksemi : write(f, ';');
tokcolon : write(f, ' : ');
tokeq : write(f, ' = ');
toklt : write(f, ' < ');
tokgt : write(f, ' > ');
tokle : write(f, ' <= ');
tokge : write(f, ' >= ');
tokne : write(f, ' <> ');
tokand : write(f, ' AND ');
tokor : write(f, ' OR ');
tokxor : write(f, ' XOR ');
tokmod : write(f, ' MOD ');
toknot : write(f, 'NOT ');
toksqr : write(f, 'SQR');
toksqrt : write(f, 'SQRT');
toksin : write(f, 'SIN');
tokcos : write(f, 'COS');
toktan : write(f, 'TAN');
tokarctan : write(f, 'ARCTAN');
toklog : write(f, 'LOG');
tokexp : write(f, 'EXP');
tokabs : write(f, 'ABS');
toksgn : write(f, 'SGN');
tokstr_ : write(f, 'STR$');
tokval : write(f, 'VAL');
tokchr_ : write(f, 'CHR$');
tokasc : write(f, 'ASC');
toklen : write(f, 'LEN');
tokmid_ : write(f, 'MID$');
tokpeek : write(f, 'PEEK');
toklet : write(f, 'LET');
tokprint : write(f, 'PRINT');
tokinput : write(f, 'INPUT');
tokgoto : write(f, 'GOTO');
tokif : write(f, 'IF');
tokend : write(f, 'END');
tokstop : write(f, 'STOP');
tokfor : write(f, 'FOR');
toknext : write(f, 'NEXT');
tokwhile : write(f, 'WHILE');
tokwend : write(f, 'WEND');
tokgosub : write(f, 'GOSUB');
tokreturn : write(f, 'RETURN');
tokread : write(f, 'READ');
tokdata : write(f, 'DATA');
tokrestore : write(f, 'RESTORE');
tokgotoxy : write(f, 'GOTOXY');
tokon : write(f, 'ON');
tokdim : write(f, 'DIM');
tokpoke : write(f, 'POKE');
toklist : write(f, 'LIST');
tokrun : write(f, 'RUN');
toknew : write(f, 'NEW');
tokload : write(f, 'LOAD');
tokmerge : write(f, 'MERGE');
toksave : write(f, 'SAVE');
tokdel : write(f, 'DEL');
tokbye : write(f, 'BYE');
tokrenum : write(f, 'RENUM');
tokthen : write(f, ' THEN ');
tokelse : write(f, ' ELSE ');
tokto : write(f, ' TO ');
tokstep : write(f, ' STEP ');
tokrem : write(f, 'REM', buf^.sp^);
end;
buf := buf^.next;
end;
end;
procedure disposetokens(var tok : tokenptr);
var
tok1 : tokenptr;
begin
while tok <> nil do
begin
tok1 := tok^.next;
if tok^.kind in [tokstr, tokrem] then
dispose(tok^.sp);
dispose(tok);
tok := tok1;
end;
end;
procedure parseinput(var buf : tokenptr);
var
l, l0, l1 : lineptr;
begin
inbuf^ := strltrim(inbuf^);
curline := 0;
while (strlen(inbuf^) <> 0) and (inbuf^[1] in ['0'..'9']) do
begin
curline := curline * 10 + ord(inbuf^[1]) - 48;
strdelete(inbuf^, 1, 1);
end;
parse(inbuf, buf);
if curline <> 0 then
begin
l := linebase;
l0 := nil;
while (l <> nil) and (l^.num < curline) do
begin
l0 := l;
l := l^.next;
end;
if (l <> nil) and (l^.num = curline) then
begin
l1 := l;
l := l^.next;
if l0 = nil then
linebase := l
else
l0^.next := l;
disposetokens(l1^.txt);
dispose(l1);
end;
if buf <> nil then
begin
new(l1);
l1^.next := l;
if l0 = nil then
linebase := l1
else
l0^.next := l1;
l1^.num := curline;
l1^.txt := buf;
end;
clearloops;
restoredata;
end;
end;
procedure errormsg(s : string255);
begin
write(#7, s);
escape(42);
end;
procedure snerr;
begin
errormsg('Syntax error');
end;
procedure tmerr;
begin
errormsg('Type mismatch error');
end;
procedure badsubscr;
begin
errormsg('Bad subscript');
end;
procedure exec;
var
gotoflag, elseflag : boolean;
t : tokenptr;
ioerrmsg : string255ptr;
function factor : valrec;
forward;
function expr : valrec;
forward;
function realfactor : real;
var
n : valrec;
begin
n := factor;
if n.stringval then tmerr;
realfactor := n.val;
end;
function strfactor : basicstring;
var
n : valrec;
begin
n := factor;
if not n.stringval then tmerr;
strfactor := n.sval;
end;
function stringfactor : string255;
var
n : valrec;
begin
n := factor;
if not n.stringval then tmerr;
stringfactor := n.sval^;
dispose(n.sval);
end;
function intfactor : integer;
begin
intfactor := round(realfactor);
end;
function realexpr : real;
var
n : valrec;
begin
n := expr;
if n.stringval then tmerr;
realexpr := n.val;
end;
function strexpr : basicstring;
var
n : valrec;
begin
n := expr;
if not n.stringval then tmerr;
strexpr := n.sval;
end;
function stringexpr : string255;
var
n : valrec;
begin
n := expr;
if not n.stringval then tmerr;
stringexpr := n.sval^;
dispose(n.sval);
end;
function intexpr : integer;
begin
intexpr := round(realexpr);
end;
procedure require(k : tokenkinds);
begin
if (t = nil) or (t^.kind <> k) then
snerr;
t := t^.next;
end;
procedure skipparen;
label 1;
begin
repeat
if t = nil then snerr;
if (t^.kind = tokrp) or (t^.kind = tokcomma) then
goto 1;
if t^.kind = toklp then
begin
t := t^.next;
skipparen;
end;
t := t^.next;
until false;
1 :
end;
function findvar : varptr;
var
v : varptr;
i, j, k : integer;
tok : tokenptr;
begin
if (t = nil) or (t^.kind <> tokvar) then snerr;
v := t^.vp;
t := t^.next;
if (t <> nil) and (t^.kind = toklp) then
with v^ do
begin
if numdims = 0 then
begin
tok := t;
i := 0;
j := 1;
repeat
if i >= maxdims then badsubscr;
t := t^.next;
skipparen;
j := j * 11;
i := i + 1;
dims[i] := 11;
until t^.kind = tokrp;
numdims := i;
if stringvar then
begin
hpm_new(sarr, j*4);
for k := 0 to j-1 do
sarr^[k] := nil;
end
else
begin
hpm_new(arr, j*8);
for k := 0 to j-1 do
arr^[k] := 0;
end;
t := tok;
end;
k := 0;
t := t^.next;
for i := 1 to numdims do
begin
j := intexpr;
if (j < 0) or (j >= dims[i]) then
badsubscr;
k := k * dims[i] + j;
if i < numdims then
require(tokcomma);
end;
require(tokrp);
if stringvar then
sval := addr(sarr^[k])
else
val := addr(arr^[k]);
end
else
begin
if v^.numdims <> 0 then
badsubscr;
end;
findvar := v;
end;
function inot(i : integer) : integer;
begin
inot := -1 - i;
end;
function ixor(a, b : integer) : integer;
begin
ixor := asm_ior(asm_iand(a, inot(b)), asm_iand(inot(a), b));
end;
function factor : valrec;
var
v : varptr;
facttok : tokenptr;
n : valrec;
i, j : integer;
tok, tok1 : tokenptr;
s : basicstring;
trick :
record
case boolean of
true : (i : integer);
false : (c : ^char);
end;
begin
if t = nil then snerr;
facttok := t;
t := t^.next;
n.stringval := false;
case facttok^.kind of
toknum :
n.val := facttok^.num;
tokstr :
begin
n.stringval := true;
new(n.sval);
n.sval^ := facttok^.sp^;
end;
tokvar :
begin
t := facttok;
v := findvar;
n.stringval := v^.stringvar;
if n.stringval then
begin
new(n.sval);
n.sval^ := v^.sval^^;
end
else
n.val := v^.val^;
end;
toklp :
begin
n := expr;
require(tokrp);
end;
tokminus :
n.val := - realfactor;
tokplus :
n.val := realfactor;
toknot :
n.val := inot(intfactor);
toksqr :
n.val := sqr(realfactor);
toksqrt :
n.val := sqrt(realfactor);
toksin :
n.val := sin(realfactor);
tokcos :
n.val := cos(realfactor);
toktan :
begin
n.val := realfactor;
n.val := sin(n.val) / cos(n.val);
end;
tokarctan :
n.val := arctan(realfactor);
toklog:
n.val := ln(realfactor);
tokexp :
n.val := exp(realfactor);
tokabs :
n.val := abs(realfactor);
toksgn :
begin
n.val := realfactor;
n.val := ord(n.val > 0) - ord(n.val < 0);
end;
tokstr_ :
begin
n.stringval := true;
new(n.sval);
n.sval^ := numtostr(realfactor);
end;
tokval :
begin
s := strfactor;
tok1 := t;
parse(s, t);
tok := t;
if tok = nil then
n.val := 0
else
n := expr;
disposetokens(tok);
t := tok1;
dispose(s);
end;
tokchr_ :
begin
n.stringval := true;
new(n.sval);
n.sval^ := ' ';
n.sval^[1] := chr(intfactor);
end;
tokasc :
begin
s := strfactor;
if strlen(s^) = 0 then
n.val := 0
else
n.val := ord(s^[1]);
dispose(s);
end;
tokmid_ :
begin
n.stringval := true;
require(toklp);
n.sval := strexpr;
require(tokcomma);
i := intexpr;
if i < 1 then i := 1;
j := 255;
if (t <> nil) and (t^.kind = tokcomma) then
begin
t := t^.next;
j := intexpr;
end;
if j > strlen(n.sval^)-i+1 then
j := strlen(n.sval^)-i+1;
if i > strlen(n.sval^) then
n.sval^ := ''
else
n.sval^ := str(n.sval^, i, j);
require(tokrp);
end;
toklen :
begin
s := strfactor;
n.val := strlen(s^);
dispose(s);
end;
tokpeek :
begin
$range off$
trick.i := intfactor;
n.val := ord(trick.c^);
$if checking$ $range on$ $end$
end;
otherwise
snerr;
end;
factor := n;
end;
function upexpr : valrec;
var
n, n2 : valrec;
begin
n := factor;
while (t <> nil) and (t^.kind = tokup) do
begin
if n.stringval then tmerr;
t := t^.next;
n2 := upexpr;
if n2.stringval then tmerr;
if n.val < 0 then
begin
if n2.val <> trunc(n2.val) then n.val := ln(n.val);
n.val := exp(n2.val * ln(-n.val));
if odd(trunc(n2.val)) then
n.val := - n.val;
end
else
n.val := exp(n2.val * ln(n.val));
end;
upexpr := n;
end;
function term : valrec;
var
n, n2 : valrec;
k : tokenkinds;
begin
n := upexpr;
while (t <> nil) and (t^.kind in [toktimes, tokdiv, tokmod]) do
begin
k := t^.kind;
t := t^.next;
n2 := upexpr;
if n.stringval or n2.stringval then tmerr;
if k = tokmod then
n.val := round(n.val) mod round(n2.val)
else if k = toktimes then
n.val := n.val * n2.val
else
n.val := n.val / n2.val;
end;
term := n;
end;
function sexpr : valrec;
var
n, n2 : valrec;
k : tokenkinds;
begin
n := term;
while (t <> nil) and (t^.kind in [tokplus, tokminus]) do
begin
k := t^.kind;
t := t^.next;
n2 := term;
if n.stringval <> n2.stringval then tmerr;
if k = tokplus then
if n.stringval then
begin
n.sval^ := n.sval^ + n2.sval^;
dispose(n2.sval);
end
else
n.val := n.val + n2.val
else
if n.stringval then
tmerr
else
n.val := n.val - n2.val;
end;
sexpr := n;
end;
function relexpr : valrec;
var
n, n2 : valrec;
f : boolean;
k : tokenkinds;
begin
n := sexpr;
while (t <> nil) and (t^.kind in [tokeq..tokne]) do
begin
k := t^.kind;
t := t^.next;
n2 := sexpr;
if n.stringval <> n2.stringval then tmerr;
if n.stringval then
begin
f := ((n.sval^ = n2.sval^) and (k in [tokeq, tokge, tokle]) or
(n.sval^ < n2.sval^) and (k in [toklt, tokle, tokne]) or
(n.sval^ > n2.sval^) and (k in [tokgt, tokge, tokne]));
dispose(n.sval);
dispose(n2.sval);
end
else
f := ((n.val = n2.val) and (k in [tokeq, tokge, tokle]) or
(n.val < n2.val) and (k in [toklt, tokle, tokne]) or
(n.val > n2.val) and (k in [tokgt, tokge, tokne]));
n.stringval := false;
n.val := ord(f);
end;
relexpr := n;
end;
function andexpr : valrec;
var
n, n2 : valrec;
begin
n := relexpr;
while (t <> nil) and (t^.kind = tokand) do
begin
t := t^.next;
n2 := relexpr;
if n.stringval or n2.stringval then tmerr;
n.val := asm_iand(trunc(n.val), trunc(n2.val));
end;
andexpr := n;
end;
function expr : valrec;
var
n, n2 : valrec;
k : tokenkinds;
begin
n := andexpr;
while (t <> nil) and (t^.kind in [tokor, tokxor]) do
begin
k := t^.kind;
t := t^.next;
n2 := andexpr;
if n.stringval or n2.stringval then tmerr;
if k = tokor then
n.val := asm_ior(trunc(n.val), trunc(n2.val))
else
n.val := ixor(trunc(n.val), trunc(n2.val));
end;
expr := n;
end;
procedure checkextra;
begin
if t <> nil then
errormsg('Extra information on line');
end;
function iseos : boolean;
begin
iseos := (t = nil) or (t^.kind in [tokcolon, tokelse]);
end;
procedure skiptoeos;
begin
while not iseos do
t := t^.next;
end;
function findline(n : integer) : lineptr;
var
l : lineptr;
begin
l := linebase;
while (l <> nil) and (l^.num <> n) do
l := l^.next;
findline := l;
end;
function mustfindline(n : integer) : lineptr;
var
l : lineptr;
begin
l := findline(n);
if l = nil then
errormsg('Undefined line');
mustfindline := l;
end;
procedure cmdend;
begin
stmtline := nil;
t := nil;
end;
procedure cmdnew;
var
p : anyptr;
begin
cmdend;
clearloops;
restoredata;
while linebase <> nil do
begin
p := linebase^.next;
disposetokens(linebase^.txt);
dispose(linebase);
linebase := p;
end;
while varbase <> nil do
begin
p := varbase^.next;
if varbase^.stringvar then
if varbase^.sval^ <> nil then
dispose(varbase^.sval^);
dispose(varbase);
varbase := p;
end;
end;
procedure cmdlist;
var
l : lineptr;
n1, n2 : integer;
begin
repeat
n1 := 0;
n2 := maxint;
if (t <> nil) and (t^.kind = toknum) then
begin
n1 := trunc(t^.num);
t := t^.next;
if (t = nil) or (t^.kind <> tokminus) then
n2 := n1;
end;
if (t <> nil) and (t^.kind = tokminus) then
begin
t := t^.next;
if (t <> nil) and (t^.kind = toknum) then
begin
n2 := trunc(t^.num);
t := t^.next;
end
else
n2 := maxint;
end;
l := linebase;
while (l <> nil) and (l^.num <= n2) do
begin
if (l^.num >= n1) then
begin
write(l^.num:1, ' ');
listtokens(output, l^.txt);
writeln;
end;
l := l^.next;
end;
if not iseos then
require(tokcomma);
until iseos;
end;
procedure cmdload(merging : boolean; name : string255);
var
f : text;
buf : tokenptr;
begin
if not merging then
cmdnew;
reset(f, name + '.TXT', 'shared');
while not eof(f) do
begin
readln(f, inbuf^);
parseinput(buf);
if curline = 0 then
begin
writeln('Bad line in file');
disposetokens(buf);
end;
end;
close(f);
end;
procedure cmdrun;
var
l : lineptr;
i : integer;
s : string255;
begin
l := linebase;
if not iseos then
begin
if t^.kind = toknum then
l := mustfindline(intexpr)
else
begin
s := stringexpr;
i := 0;
if not iseos then
begin
require(tokcomma);
i := intexpr;
end;
checkextra;
cmdload(false, s);
if i = 0 then
l := linebase
else
l := mustfindline(i)
end
end;
stmtline := l;
gotoflag := true;
clearvars;
clearloops;
restoredata;
end;
procedure cmdsave;
var
f : text;
l : lineptr;
begin
rewrite(f, stringexpr + '.TXT');
l := linebase;
while l <> nil do
begin
write(f, l^.num:1, ' ');
listtokens(f, l^.txt);
writeln(f);
l := l^.next;
end;
close(f, 'save');
end;
procedure cmdbye;
begin
exitflag := true;
end;
procedure cmddel;
var
l, l0, l1 : lineptr;
n1, n2 : integer;
begin
repeat
if iseos then snerr;
n1 := 0;
n2 := maxint;
if (t <> nil) and (t^.kind = toknum) then
begin
n1 := trunc(t^.num);
t := t^.next;
if (t = nil) or (t^.kind <> tokminus) then
n2 := n1;
end;
if (t <> nil) and (t^.kind = tokminus) then
begin
t := t^.next;
if (t <> nil) and (t^.kind = toknum) then
begin
n2 := trunc(t^.num);
t := t^.next;
end
else
n2 := maxint;
end;
l := linebase;
l0 := nil;
while (l <> nil) and (l^.num <= n2) do
begin
l1 := l^.next;
if (l^.num >= n1) then
begin
if l = stmtline then
begin
cmdend;
clearloops;
restoredata;
end;
if l0 = nil then
linebase := l^.next
else
l0^.next := l^.next;
disposetokens(l^.txt);
dispose(l);
end
else
l0 := l;
l := l1;
end;
if not iseos then
require(tokcomma);
until iseos;
end;
procedure cmdrenum;
var
l, l1 : lineptr;
tok : tokenptr;
lnum, step : integer;
begin
lnum := 10;
step := 10;
if not iseos then
begin
lnum := intexpr;
if not iseos then
begin
require(tokcomma);
step := intexpr;
end;
end;
l := linebase;
if l <> nil then
begin
while l <> nil do
begin
l^.num2 := lnum;
lnum := lnum + step;
l := l^.next;
end;
l := linebase;
repeat
tok := l^.txt;
repeat
if tok^.kind in [tokgoto, tokgosub, tokthen, tokelse,
tokrun, toklist, tokrestore, tokdel] then
while (tok^.next <> nil) and (tok^.next^.kind = toknum) do
begin
tok := tok^.next;
lnum := round(tok^.num);
l1 := linebase;
while (l1 <> nil) and (l1^.num <> lnum) do
l1 := l1^.next;
if l1 = nil then
writeln('Undefined line ', lnum:1, ' in line ', l^.num2:1)
else
tok^.num := l1^.num2;
if (tok^.next <> nil) and (tok^.next^.kind = tokcomma) then
tok := tok^.next;
end;
tok := tok^.next;
until tok = nil;
l := l^.next;
until l = nil;
l := linebase;
while l <> nil do
begin
l^.num := l^.num2;
l := l^.next;
end;
end;
end;
procedure cmdprint;
var
semiflag : boolean;
n : valrec;
begin
semiflag := false;
while not iseos do
begin
semiflag := false;
if t^.kind in [toksemi, tokcomma] then
begin
semiflag := true;
t := t^.next;
end
else
begin
n := expr;
if n.stringval then
begin
write(n.sval^);
dispose(n.sval);
end
else
write(numtostr(n.val), ' ');
end;
end;
if not semiflag then
writeln;
end;
procedure cmdinput;
var
v : varptr;
s : string255;
tok, tok0, tok1 : tokenptr;
strflag : boolean;
begin
if (t <> nil) and (t^.kind = tokstr) then
begin
write(t^.sp^);
t := t^.next;
require(toksemi);
end
else
begin
write('? ');
end;
tok := t;
if (t = nil) or (t^.kind <> tokvar) then snerr;
strflag := t^.vp^.stringvar;
repeat
if (t <> nil) and (t^.kind = tokvar) then
if t^.vp^.stringvar <> strflag then snerr;
t := t^.next;
until iseos;
t := tok;
if strflag then
begin
repeat
readln(s);
v := findvar;
if v^.sval^ <> nil then
dispose(v^.sval^);
new(v^.sval^);
v^.sval^^ := s;
if not iseos then
begin
require(tokcomma);
write('?? ');
end;
until iseos;
end
else
begin
readln(s);
parse(addr(s), tok);
tok0 := tok;
repeat
v := findvar;
while tok = nil do
begin
write('?? ');
readln(s);
disposetokens(tok0);
parse(addr(s), tok);
tok0 := tok;
end;
tok1 := t;
t := tok;
v^.val^ := realexpr;
if t <> nil then
if t^.kind = tokcomma then
t := t^.next
else
snerr;
tok := t;
t := tok1;
if not iseos then
require(tokcomma);
until iseos;
disposetokens(tok0);
end;
end;
procedure cmdlet(implied : boolean);
var
v : varptr;
old : basicstring;
begin
if implied then
t := stmttok;
v := findvar;
require(tokeq);
if v^.stringvar then
begin
old := v^.sval^;
v^.sval^ := strexpr;
if old <> nil then
dispose(old);
end
else
v^.val^ := realexpr;
end;
procedure cmdgoto;
begin
stmtline := mustfindline(intexpr);
t := nil;
gotoflag := true;
end;
procedure cmdif;
var
n : real;
i : integer;
begin
n := realexpr;
require(tokthen);
if n = 0 then
begin
i := 0;
repeat
if t <> nil then
begin
if t^.kind = tokif then
i := i + 1;
if t^.kind = tokelse then
i := i - 1;
t := t^.next;
end;
until (t = nil) or (i < 0);
end;
if (t <> nil) and (t^.kind = toknum) then
cmdgoto
else
elseflag := true;
end;
procedure cmdelse;
begin
t := nil;
end;
function skiploop(up, dn : tokenkinds) : boolean;
label 1;
var
i : integer;
saveline : lineptr;
begin
saveline := stmtline;
i := 0;
repeat
while t = nil do
begin
if (stmtline = nil) or (stmtline^.next = nil) then
begin
skiploop := false;
stmtline := saveline;
goto 1;
end;
stmtline := stmtline^.next;
t := stmtline^.txt;
end;
if t^.kind = up then
i := i + 1;
if t^.kind = dn then
i := i - 1;
t := t^.next;
until i < 0;
skiploop := true;
1 :
end;
procedure cmdfor;
var
l : loopptr;
lr : looprec;
saveline : lineptr;
i, j : integer;
begin
lr.vp := findvar;
if lr.vp^.stringvar then snerr;
require(tokeq);
lr.vp^.val^ := realexpr;
require(tokto);
lr.max := realexpr;
if (t <> nil) and (t^.kind = tokstep) then
begin
t := t^.next;
lr.step := realexpr;
end
else
lr.step := 1;
lr.homeline := stmtline;
lr.hometok := t;
lr.kind := forloop;
lr.next := loopbase;
with lr do
if ((step >= 0) and (vp^.val^ > max)) or ((step <= 0) and (vp^.val^ < max)) then
begin
saveline := stmtline;
i := 0;
j := 0;
repeat
while t = nil do
begin
if (stmtline = nil) or (stmtline^.next = nil) then
begin
stmtline := saveline;
errormsg('FOR without NEXT');
end;
stmtline := stmtline^.next;
t := stmtline^.txt;
end;
if t^.kind = tokfor then
if (t^.next <> nil) and (t^.next^.kind = tokvar) and (t^.next^.vp = vp) then
j := j + 1
else
i := i + 1;
if (t^.kind = toknext) then
if (t^.next <> nil) and (t^.next^.kind = tokvar) and (t^.next^.vp = vp) then
j := j - 1
else
i := i - 1;
t := t^.next;
until (i < 0) or (j < 0);
skiptoeos;
end
else
begin
new(l);
l^ := lr;
loopbase := l;
end;
end;
procedure cmdnext;
var
v : varptr;
found : boolean;
l : loopptr;
begin
if not iseos then
v := findvar
else
v := nil;
repeat
if (loopbase = nil) or (loopbase^.kind = gosubloop) then
errormsg('NEXT without FOR');
found := (loopbase^.kind = forloop) and
((v = nil) or (loopbase^.vp = v));
if not found then
begin
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
end;
until found;
with loopbase^ do
begin
vp^.val^ := vp^.val^ + step;
if ((step >= 0) and (vp^.val^ > max)) or ((step <= 0) and (vp^.val^ < max)) then
begin
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
end
else
begin
stmtline := homeline;
t := hometok;
end;
end;
end;
procedure cmdwhile;
var
l : loopptr;
begin
new(l);
l^.next := loopbase;
loopbase := l;
l^.kind := whileloop;
l^.homeline := stmtline;
l^.hometok := t;
if not iseos then
if realexpr = 0 then
begin
if not skiploop(tokwhile, tokwend) then
errormsg('WHILE without WEND');
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
skiptoeos;
end;
end;
procedure cmdwend;
var
tok : tokenptr;
tokline : lineptr;
l : loopptr;
found : boolean;
begin
repeat
if (loopbase = nil) or (loopbase^.kind = gosubloop) then
errormsg('WEND without WHILE');
found := (loopbase^.kind = whileloop);
if not found then
begin
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
end;
until found;
if not iseos then
if realexpr <> 0 then
found := false;
tok := t;
tokline := stmtline;
if found then
begin
stmtline := loopbase^.homeline;
t := loopbase^.hometok;
if not iseos then
if realexpr = 0 then
found := false;
end;
if not found then
begin
t := tok;
stmtline := tokline;
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
end;
end;
procedure cmdgosub;
var
l : loopptr;
begin
new(l);
l^.next := loopbase;
loopbase := l;
l^.kind := gosubloop;
l^.homeline := stmtline;
l^.hometok := t;
cmdgoto;
end;
procedure cmdreturn;
var
l : loopptr;
found : boolean;
begin
repeat
if loopbase = nil then
errormsg('RETURN without GOSUB');
found := (loopbase^.kind = gosubloop);
if not found then
begin
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
end;
until found;
stmtline := loopbase^.homeline;
t := loopbase^.hometok;
l := loopbase^.next;
dispose(loopbase);
loopbase := l;
skiptoeos;
end;
procedure cmdread;
var
v : varptr;
tok : tokenptr;
found : boolean;
begin
repeat
v := findvar;
tok := t;
t := datatok;
if dataline = nil then
begin
dataline := linebase;
t := dataline^.txt;
end;
if (t = nil) or (t^.kind <> tokcomma) then
repeat
while t = nil do
begin
if (dataline = nil) or (dataline^.next = nil) then
errormsg('Out of Data');
dataline := dataline^.next;
t := dataline^.txt;
end;
found := (t^.kind = tokdata);
t := t^.next;
until found and not iseos
else
t := t^.next;
if v^.stringvar then
begin
if v^.sval^ <> nil then
dispose(v^.sval^);
v^.sval^ := strexpr;
end
else
v^.val^ := realexpr;
datatok := t;
t := tok;
if not iseos then
require(tokcomma);
until iseos;
end;
procedure cmddata;
begin
skiptoeos;
end;
procedure cmdrestore;
begin
if iseos then
restoredata
else
begin
dataline := mustfindline(intexpr);
datatok := dataline^.txt;
end;
end;
procedure cmdgotoxy;
var
i : integer;
begin
i := intexpr;
require(tokcomma);
gotoxy(i, intexpr);
end;
procedure cmdon;
var
i : integer;
l : loopptr;
begin
i := intexpr;
if (t <> nil) and (t^.kind = tokgosub) then
begin
new(l);
l^.next := loopbase;
loopbase := l;
l^.kind := gosubloop;
l^.homeline := stmtline;
l^.hometok := t;
t := t^.next;
end
else
require(tokgoto);
if i < 1 then
skiptoeos
else
begin
while (i > 1) and not iseos do
begin
require(toknum);
if not iseos then
require(tokcomma);
i := i - 1;
end;
if not iseos then
cmdgoto;
end;
end;
procedure cmddim;
var
i, j, k : integer;
v : varptr;
done : boolean;
begin
repeat
if (t = nil) or (t^.kind <> tokvar) then snerr;
v := t^.vp;
t := t^.next;
with v^ do
begin
if numdims <> 0 then
errormsg('Array already dimensioned');
j := 1;
i := 0;
require(toklp);
repeat
k := intexpr + 1;
if k < 1 then badsubscr;
if i >= maxdims then badsubscr;
i := i + 1;
dims[i] := k;
j := j * k;
done := (t <> nil) and (t^.kind = tokrp);
if not done then
require(tokcomma);
until done;
t := t^.next;
numdims := i;
if stringvar then
begin
hpm_new(sarr, j*4);
for i := 0 to j-1 do
sarr^[i] := nil;
end
else
begin
hpm_new(arr, j*8);
for i := 0 to j-1 do
arr^[i] := 0;
end;
end;
if not iseos then
require(tokcomma);
until iseos;
end;
procedure cmdpoke;
var
trick :
record
case boolean of
true : (i : integer);
false : (c : ^char);
end;
begin
$range off$
trick.i := intexpr;
require(tokcomma);
trick.c^ := chr(intexpr);
$if checking$ $range on$ $end$
end;
begin {exec}
try
repeat
repeat
gotoflag := false;
elseflag := false;
while (stmttok <> nil) and (stmttok^.kind = tokcolon) do
stmttok := stmttok^.next;
t := stmttok;
if t <> nil then
begin
t := t^.next;
case stmttok^.kind of
tokrem : ;
toklist : cmdlist;
tokrun : cmdrun;
toknew : cmdnew;
tokload : cmdload(false, stringexpr);
tokmerge : cmdload(true, stringexpr);
toksave : cmdsave;
tokbye : cmdbye;
tokdel : cmddel;
tokrenum : cmdrenum;
toklet : cmdlet(false);
tokvar : cmdlet(true);
tokprint : cmdprint;
tokinput : cmdinput;
tokgoto : cmdgoto;
tokif : cmdif;
tokelse : cmdelse;
tokend : cmdend;
tokstop : escape(-20);
tokfor : cmdfor;
toknext : cmdnext;
tokwhile : cmdwhile;
tokwend : cmdwend;
tokgosub : cmdgosub;
tokreturn : cmdreturn;
tokread : cmdread;
tokdata : cmddata;
tokrestore : cmdrestore;
tokgotoxy : cmdgotoxy;
tokon : cmdon;
tokdim : cmddim;
tokpoke : cmdpoke;
otherwise
errormsg('Illegal command');
end;
end;
if not elseflag and not iseos then
checkextra;
stmttok := t;
until t = nil;
if stmtline <> nil then
begin
if not gotoflag then
stmtline := stmtline^.next;
if stmtline <> nil then
stmttok := stmtline^.txt;
end;
until stmtline = nil;
recover
begin
if escapecode = -20 then
begin
write('Break');
end
else if escapecode = 42 then
begin end
else
case escapecode of
-4 : write(#7'Integer overflow');
-5 : write(#7'Divide by zero');
-6 : write(#7'Real math overflow');
-7 : write(#7'Real math underflow');
-8, -19..-15 : write(#7'Value range error');
-10 :
begin
new(ioerrmsg);
misc_getioerrmsg(ioerrmsg^, ioresult);
write(#7, ioerrmsg^);
dispose(ioerrmsg);
end;
otherwise
begin
if excp_line <> -1 then
writeln(excp_line);
escape(escapecode);
end;
end;
if stmtline <> nil then
write(' in ', stmtline^.num:1);
writeln;
end;
end; {exec}
begin {main}
new(inbuf);
linebase := nil;
varbase := nil;
loopbase := nil;
writeln('Chipmunk BASIC 1.0');
writeln;
exitflag := false;
repeat
try
repeat
write('>');
readln(inbuf^);
parseinput(buf);
if curline = 0 then
begin
stmtline := nil;
stmttok := buf;
if stmttok <> nil then
exec;
disposetokens(buf);
end;
until exitflag or eof(input);
recover
if escapecode <> -20 then
misc_printerror(escapecode, ioresult)
else
writeln;
until exitflag or eof(input);
end.
