rsalz@uunet.uu.net (Rich Salz) (03/29/90)
Submitted-by: Dave Gillespie <daveg@csvax.caltech.edu> Posting-number: Volume 21, Issue 64 Archive-name: p2c/part19 #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 19 (of 32)." # Contents: examples/basic.p.1 # Wrapped by rsalz@litchi.bbn.com on Mon Mar 26 14:29:42 1990 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'examples/basic.p.1' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'examples/basic.p.1'\" else echo shar: Extracting \"'examples/basic.p.1'\" \(48192 characters\) sed "s/^X//" >'examples/basic.p.1' <<'END_OF_FILE' X X$ sysprog, ucsd, heap_dispose, partial_eval $ X X{$ debug$} X X Xprogram basic(input, output); X X Xconst X X checking = true; X X varnamelen = 20; X maxdims = 4; X X X Xtype X X varnamestring = string[varnamelen]; X X string255 = string[255]; X string255ptr = ^string255; X X tokenkinds = (tokvar, toknum, tokstr, toksnerr, X X tokplus, tokminus, toktimes, tokdiv, tokup, toklp, tokrp, X tokcomma, toksemi, tokcolon, tokeq, toklt, tokgt, X tokle, tokge, tokne, X X tokand, tokor, tokxor, tokmod, toknot, toksqr, toksqrt, toksin, X tokcos, toktan, tokarctan, toklog, tokexp, tokabs, toksgn, X tokstr_, tokval, tokchr_, tokasc, toklen, tokmid_, tokpeek, X X tokrem, toklet, tokprint, tokinput, tokgoto, tokif, tokend, X tokstop, tokfor, toknext, tokwhile, tokwend, tokgosub, X tokreturn, tokread, tokdata, tokrestore, tokgotoxy, tokon, X tokdim, tokpoke, X X toklist, tokrun, toknew, tokload, tokmerge, toksave, tokbye, X tokdel, tokrenum, X X tokthen, tokelse, tokto, tokstep); X X realptr = ^real; X basicstring = string255ptr; X stringptr = ^basicstring; X numarray = array[0..maxint] of real; X arrayptr = ^numarray; X strarray = array[0..maxint] of basicstring; X strarrayptr = ^strarray; X X tokenptr = ^tokenrec; X lineptr = ^linerec; X varptr = ^varrec; X loopptr = ^looprec; X X tokenrec = X record X next : tokenptr; X case kind : tokenkinds of X tokvar : (vp : varptr); X toknum : (num : real); X tokstr, tokrem : (sp : string255ptr); X toksnerr : (snch : char); X end; X X linerec = X record X num, num2 : integer; X txt : tokenptr; X next : lineptr; X end; X X varrec = X record X name : varnamestring; X next : varptr; X dims : array [1..maxdims] of integer; X numdims : 0..maxdims; X case stringvar : boolean of X false : (arr : arrayptr; val : realptr; rv : real); X true : (sarr : strarrayptr; sval : stringptr; sv : basicstring); X end; X X valrec = X record X case stringval : boolean of X false : (val : real); X true : (sval : basicstring); X end; X X loopkind = (forloop, whileloop, gosubloop); X looprec = X record X next : loopptr; X homeline : lineptr; X hometok : tokenptr; X case kind : loopkind of X forloop : X ( vp : varptr; X max, step : real ); X end; X X X Xvar X X inbuf : string255ptr; X X linebase : lineptr; X varbase : varptr; X loopbase : loopptr; X X curline : integer; X stmtline, dataline : lineptr; X stmttok, datatok, buf : tokenptr; X X exitflag : boolean; X X excp_line ['EXCP_LINE'] : integer; X X X X$if not checking$ X $range off$ X$end$ X X X Xprocedure misc_getioerrmsg(var s : string; io : integer); X external; X Xprocedure misc_printerror(er, io : integer); X external; X Xfunction asm_iand(a, b : integer) : integer; X external; X Xfunction asm_ior(a, b : integer) : integer; X external; X Xprocedure hpm_new(var p : anyptr; size : integer); X external; X Xprocedure hpm_dispose(var p : anyptr; size : integer); X external; X X X Xprocedure restoredata; X begin X dataline := nil; X datatok := nil; X end; X X X Xprocedure clearloops; X var X l : loopptr; X begin X while loopbase <> nil do X begin X l := loopbase^.next; X dispose(loopbase); X loopbase := l; X end; X end; X X X Xfunction arraysize(v : varptr) : integer; X var X i, j : integer; X begin X with v^ do X begin X if stringvar then X j := 4 X else X j := 8; X for i := 1 to numdims do X j := j * dims[i]; X end; X arraysize := j; X end; X X Xprocedure clearvar(v : varptr); X begin X with v^ do X begin X if numdims <> 0 then X hpm_dispose(arr, arraysize(v)) X else if stringvar and (sv <> nil) then X dispose(sv); X numdims := 0; X if stringvar then X begin X sv := nil; X sval := addr(sv); X end X else X begin X rv := 0; X val := addr(rv); X end; X end; X end; X X Xprocedure clearvars; X var X v : varptr; X begin X v := varbase; X while v <> nil do X begin X clearvar(v); X v := v^.next; X end; X end; X X X Xfunction numtostr(n : real) : string255; X var X s : string255; X i : integer; X begin X setstrlen(s, 255); X if (n <> 0) and (abs(n) < 1e-2) or (abs(n) >= 1e12) then X begin X strwrite(s, 1, i, n); X setstrlen(s, i-1); X numtostr := s; X end X else X begin X strwrite(s, 1, i, n:30:10); X repeat X i := i - 1; X until s[i] <> '0'; X if s[i] = '.' then X i := i - 1; X setstrlen(s, i); X numtostr := strltrim(s); X end; X end; X X X Xprocedure parse(inbuf : string255ptr; var buf : tokenptr); X X const X toklength = 20; X X type X chset = set of char; X X const X idchars = chset ['A'..'Z','a'..'z','0'..'9','_','$']; X X var X i, j, k : integer; X token : string[toklength]; X t, tptr : tokenptr; X v : varptr; X ch : char; X n, d, d1 : real; X X begin X tptr := nil; X buf := nil; X i := 1; X repeat X ch := ' '; X while (i <= strlen(inbuf^)) and (ch = ' ') do X begin X ch := inbuf^[i]; X i := i + 1; X end; X if ch <> ' ' then X begin X new(t); X if tptr = nil then X buf := t X else X tptr^.next := t; X tptr := t; X t^.next := nil; X case ch of X 'A'..'Z', 'a'..'z' : X begin X i := i - 1; X j := 0; X setstrlen(token, strmax(token)); X while (i <= strlen(inbuf^)) and (inbuf^[i] in idchars) do X begin X if j < toklength then X begin X j := j + 1; X token[j] := inbuf^[i]; X end; X i := i + 1; X end; X setstrlen(token, j); X if (token = 'and') or (token = 'AND') then t^.kind := tokand X else if (token = 'or') or (token = 'OR') then t^.kind := tokor X else if (token = 'xor') or (token = 'XOR') then t^.kind := tokxor X else if (token = 'not') or (token = 'NOT') then t^.kind := toknot X else if (token = 'mod') or (token = 'MOD') then t^.kind := tokmod X else if (token = 'sqr') or (token = 'SQR') then t^.kind := toksqr X else if (token = 'sqrt') or (token = 'SQRT') then t^.kind := toksqrt X else if (token = 'sin') or (token = 'SIN') then t^.kind := toksin X else if (token = 'cos') or (token = 'COS') then t^.kind := tokcos X else if (token = 'tan') or (token = 'TAN') then t^.kind := toktan X else if (token = 'arctan') or (token = 'ARCTAN') then t^.kind := tokarctan X else if (token = 'log') or (token = 'LOG') then t^.kind := toklog X else if (token = 'exp') or (token = 'EXP') then t^.kind := tokexp X else if (token = 'abs') or (token = 'ABS') then t^.kind := tokabs X else if (token = 'sgn') or (token = 'SGN') then t^.kind := toksgn X else if (token = 'str$') or (token = 'STR$') then t^.kind := tokstr_ X else if (token = 'val') or (token = 'VAL') then t^.kind := tokval X else if (token = 'chr$') or (token = 'CHR$') then t^.kind := tokchr_ X else if (token = 'asc') or (token = 'ASC') then t^.kind := tokasc X else if (token = 'len') or (token = 'LEN') then t^.kind := toklen X else if (token = 'mid$') or (token = 'MID$') then t^.kind := tokmid_ X else if (token = 'peek') or (token = 'PEEK') then t^.kind := tokpeek X else if (token = 'let') or (token = 'LET') then t^.kind := toklet X else if (token = 'print') or (token = 'PRINT') then t^.kind := tokprint X else if (token = 'input') or (token = 'INPUT') then t^.kind := tokinput X else if (token = 'goto') or (token = 'GOTO') then t^.kind := tokgoto X else if (token = 'go to') or (token = 'GO TO') then t^.kind := tokgoto X else if (token = 'if') or (token = 'IF') then t^.kind := tokif X else if (token = 'end') or (token = 'END') then t^.kind := tokend X else if (token = 'stop') or (token = 'STOP') then t^.kind := tokstop X else if (token = 'for') or (token = 'FOR') then t^.kind := tokfor X else if (token = 'next') or (token = 'NEXT') then t^.kind := toknext X else if (token = 'while') or (token = 'WHILE') then t^.kind := tokwhile X else if (token = 'wend') or (token = 'WEND') then t^.kind := tokwend X else if (token = 'gosub') or (token = 'GOSUB') then t^.kind := tokgosub X else if (token = 'return') or (token = 'RETURN') then t^.kind := tokreturn X else if (token = 'read') or (token = 'READ') then t^.kind := tokread X else if (token = 'data') or (token = 'DATA') then t^.kind := tokdata X else if (token = 'restore') or (token = 'RESTORE') then t^.kind := tokrestore X else if (token = 'gotoxy') or (token = 'GOTOXY') then t^.kind := tokgotoxy X else if (token = 'on') or (token = 'ON') then t^.kind := tokon X else if (token = 'dim') or (token = 'DIM') then t^.kind := tokdim X else if (token = 'poke') or (token = 'POKE') then t^.kind := tokpoke X else if (token = 'list') or (token = 'LIST') then t^.kind := toklist X else if (token = 'run') or (token = 'RUN') then t^.kind := tokrun X else if (token = 'new') or (token = 'NEW') then t^.kind := toknew X else if (token = 'load') or (token = 'LOAD') then t^.kind := tokload X else if (token = 'merge') or (token = 'MERGE') then t^.kind := tokmerge X else if (token = 'save') or (token = 'SAVE') then t^.kind := toksave X else if (token = 'bye') or (token = 'BYE') then t^.kind := tokbye X else if (token = 'quit') or (token = 'QUIT') then t^.kind := tokbye X else if (token = 'del') or (token = 'DEL') then t^.kind := tokdel X else if (token = 'renum') or (token = 'RENUM') then t^.kind := tokrenum X else if (token = 'then') or (token = 'THEN') then t^.kind := tokthen X else if (token = 'else') or (token = 'ELSE') then t^.kind := tokelse X else if (token = 'to') or (token = 'TO') then t^.kind := tokto X else if (token = 'step') or (token = 'STEP') then t^.kind := tokstep X else if (token = 'rem') or (token = 'REM') then X begin X t^.kind := tokrem; X new(t^.sp); X t^.sp^ := str(inbuf^, i, strlen(inbuf^)-i+1); X i := strlen(inbuf^)+1; X end X else X begin X t^.kind := tokvar; X v := varbase; X while (v <> nil) and (v^.name <> token) do X v := v^.next; X if v = nil then X begin X new(v); X v^.next := varbase; X varbase := v; X v^.name := token; X v^.numdims := 0; X if token[strlen(token)] = '$' then X begin X v^.stringvar := true; X v^.sv := nil; X v^.sval := addr(v^.sv); X end X else X begin X v^.stringvar := false; X v^.rv := 0; X v^.val := addr(v^.rv); X end; X end; X t^.vp := v; X end; X end; X '"', '''' : X begin X t^.kind := tokstr; X new(t^.sp); X setstrlen(t^.sp^, 255); X j := 0; X while (i <= strlen(inbuf^)) and (inbuf^[i] <> ch) do X begin X j := j + 1; X t^.sp^[j] := inbuf^[i]; X i := i + 1; X end; X setstrlen(t^.sp^, j); X i := i + 1; X end; X '0'..'9', '.' : X begin X t^.kind := toknum; X n := 0; X d := 1; X d1 := 1; X i := i - 1; X while (i <= strlen(inbuf^)) and ((inbuf^[i] in ['0'..'9']) X or ((inbuf^[i] = '.') and (d1 = 1))) do X begin X if inbuf^[i] = '.' then X d1 := 10 X else X begin X n := n * 10 + ord(inbuf^[i]) - 48; X d := d * d1; X end; X i := i + 1; X end; X n := n / d; X if (i <= strlen(inbuf^)) and (inbuf^[i] in ['e','E']) then X begin X i := i + 1; X d1 := 10; X if (i <= strlen(inbuf^)) and (inbuf^[i] in ['+','-']) then X begin X if inbuf^[i] = '-' then X d1 := 0.1; X i := i + 1; X end; X j := 0; X while (i <= strlen(inbuf^)) and (inbuf^[i] in ['0'..'9']) do X begin X j := j * 10 + ord(inbuf^[i]) - 48; X i := i + 1; X end; X for k := 1 to j do X n := n * d1; X end; X t^.num := n; X end; X '+' : t^.kind := tokplus; X '-' : t^.kind := tokminus; X '*' : t^.kind := toktimes; X '/' : t^.kind := tokdiv; X '^' : t^.kind := tokup; X '(', '[' : t^.kind := toklp; X ')', ']' : t^.kind := tokrp; X ',' : t^.kind := tokcomma; X ';' : t^.kind := toksemi; X ':' : t^.kind := tokcolon; X '?' : t^.kind := tokprint; X '=' : t^.kind := tokeq; X '<' : X begin X if (i <= strlen(inbuf^)) and (inbuf^[i] = '=') then X begin X t^.kind := tokle; X i := i + 1; X end X else if (i <= strlen(inbuf^)) and (inbuf^[i] = '>') then X begin X t^.kind := tokne; X i := i + 1; X end X else X t^.kind := toklt; X end; X '>' : X begin X if (i <= strlen(inbuf^)) and (inbuf^[i] = '=') then X begin X t^.kind := tokge; X i := i + 1; X end X else X t^.kind := tokgt; X end; X otherwise X begin X t^.kind := toksnerr; X t^.snch := ch; X end; X end; X end; X until i > strlen(inbuf^); X end; X X X Xprocedure listtokens(var f : text; buf : tokenptr); X var X ltr, ltr0 : boolean; X begin X ltr := false; X while buf <> nil do X begin X if buf^.kind in [tokvar, toknum, toknot..tokrenum] then X begin X if ltr then write(f, ' '); X ltr := (buf^.kind <> toknot); X end X else X ltr := false; X case buf^.kind of X tokvar : write(f, buf^.vp^.name); X toknum : write(f, numtostr(buf^.num)); X tokstr : write(f, '"', buf^.sp^, '"'); X toksnerr : write(f, '{', buf^.snch, '}'); X tokplus : write(f, '+'); X tokminus : write(f, '-'); X toktimes : write(f, '*'); X tokdiv : write(f, '/'); X tokup : write(f, '^'); X toklp : write(f, '('); X tokrp : write(f, ')'); X tokcomma : write(f, ','); X toksemi : write(f, ';'); X tokcolon : write(f, ' : '); X tokeq : write(f, ' = '); X toklt : write(f, ' < '); X tokgt : write(f, ' > '); X tokle : write(f, ' <= '); X tokge : write(f, ' >= '); X tokne : write(f, ' <> '); X tokand : write(f, ' AND '); X tokor : write(f, ' OR '); X tokxor : write(f, ' XOR '); X tokmod : write(f, ' MOD '); X toknot : write(f, 'NOT '); X toksqr : write(f, 'SQR'); X toksqrt : write(f, 'SQRT'); X toksin : write(f, 'SIN'); X tokcos : write(f, 'COS'); X toktan : write(f, 'TAN'); X tokarctan : write(f, 'ARCTAN'); X toklog : write(f, 'LOG'); X tokexp : write(f, 'EXP'); X tokabs : write(f, 'ABS'); X toksgn : write(f, 'SGN'); X tokstr_ : write(f, 'STR$'); X tokval : write(f, 'VAL'); X tokchr_ : write(f, 'CHR$'); X tokasc : write(f, 'ASC'); X toklen : write(f, 'LEN'); X tokmid_ : write(f, 'MID$'); X tokpeek : write(f, 'PEEK'); X toklet : write(f, 'LET'); X tokprint : write(f, 'PRINT'); X tokinput : write(f, 'INPUT'); X tokgoto : write(f, 'GOTO'); X tokif : write(f, 'IF'); X tokend : write(f, 'END'); X tokstop : write(f, 'STOP'); X tokfor : write(f, 'FOR'); X toknext : write(f, 'NEXT'); X tokwhile : write(f, 'WHILE'); X tokwend : write(f, 'WEND'); X tokgosub : write(f, 'GOSUB'); X tokreturn : write(f, 'RETURN'); X tokread : write(f, 'READ'); X tokdata : write(f, 'DATA'); X tokrestore : write(f, 'RESTORE'); X tokgotoxy : write(f, 'GOTOXY'); X tokon : write(f, 'ON'); X tokdim : write(f, 'DIM'); X tokpoke : write(f, 'POKE'); X toklist : write(f, 'LIST'); X tokrun : write(f, 'RUN'); X toknew : write(f, 'NEW'); X tokload : write(f, 'LOAD'); X tokmerge : write(f, 'MERGE'); X toksave : write(f, 'SAVE'); X tokdel : write(f, 'DEL'); X tokbye : write(f, 'BYE'); X tokrenum : write(f, 'RENUM'); X tokthen : write(f, ' THEN '); X tokelse : write(f, ' ELSE '); X tokto : write(f, ' TO '); X tokstep : write(f, ' STEP '); X tokrem : write(f, 'REM', buf^.sp^); X end; X buf := buf^.next; X end; X end; X X X Xprocedure disposetokens(var tok : tokenptr); X var X tok1 : tokenptr; X begin X while tok <> nil do X begin X tok1 := tok^.next; X if tok^.kind in [tokstr, tokrem] then X dispose(tok^.sp); X dispose(tok); X tok := tok1; X end; X end; X X X Xprocedure parseinput(var buf : tokenptr); X var X l, l0, l1 : lineptr; X begin X inbuf^ := strltrim(inbuf^); X curline := 0; X while (strlen(inbuf^) <> 0) and (inbuf^[1] in ['0'..'9']) do X begin X curline := curline * 10 + ord(inbuf^[1]) - 48; X strdelete(inbuf^, 1, 1); X end; X parse(inbuf, buf); X if curline <> 0 then X begin X l := linebase; X l0 := nil; X while (l <> nil) and (l^.num < curline) do X begin X l0 := l; X l := l^.next; X end; X if (l <> nil) and (l^.num = curline) then X begin X l1 := l; X l := l^.next; X if l0 = nil then X linebase := l X else X l0^.next := l; X disposetokens(l1^.txt); X dispose(l1); X end; X if buf <> nil then X begin X new(l1); X l1^.next := l; X if l0 = nil then X linebase := l1 X else X l0^.next := l1; X l1^.num := curline; X l1^.txt := buf; X end; X clearloops; X restoredata; X end; X end; X X X X X Xprocedure errormsg(s : string255); X begin X write(#7, s); X escape(42); X end; X X Xprocedure snerr; X begin X errormsg('Syntax error'); X end; X Xprocedure tmerr; X begin X errormsg('Type mismatch error'); X end; X Xprocedure badsubscr; X begin X errormsg('Bad subscript'); X end; X X X X X X Xprocedure exec; X X var X gotoflag, elseflag : boolean; X t : tokenptr; X ioerrmsg : string255ptr; X X X function factor : valrec; X forward; X X function expr : valrec; X forward; X X function realfactor : real; X var X n : valrec; X begin X n := factor; X if n.stringval then tmerr; X realfactor := n.val; X end; X X function strfactor : basicstring; X var X n : valrec; X begin X n := factor; X if not n.stringval then tmerr; X strfactor := n.sval; X end; X X function stringfactor : string255; X var X n : valrec; X begin X n := factor; X if not n.stringval then tmerr; X stringfactor := n.sval^; X dispose(n.sval); X end; X X function intfactor : integer; X begin X intfactor := round(realfactor); X end; X X function realexpr : real; X var X n : valrec; X begin X n := expr; X if n.stringval then tmerr; X realexpr := n.val; X end; X X function strexpr : basicstring; X var X n : valrec; X begin X n := expr; X if not n.stringval then tmerr; X strexpr := n.sval; X end; X X function stringexpr : string255; X var X n : valrec; X begin X n := expr; X if not n.stringval then tmerr; X stringexpr := n.sval^; X dispose(n.sval); X end; X X function intexpr : integer; X begin X intexpr := round(realexpr); X end; X X X procedure require(k : tokenkinds); X begin X if (t = nil) or (t^.kind <> k) then X snerr; X t := t^.next; X end; X X X procedure skipparen; X label 1; X begin X repeat X if t = nil then snerr; X if (t^.kind = tokrp) or (t^.kind = tokcomma) then X goto 1; X if t^.kind = toklp then X begin X t := t^.next; X skipparen; X end; X t := t^.next; X until false; X 1 : X end; X X X function findvar : varptr; X var X v : varptr; X i, j, k : integer; X tok : tokenptr; X begin X if (t = nil) or (t^.kind <> tokvar) then snerr; X v := t^.vp; X t := t^.next; X if (t <> nil) and (t^.kind = toklp) then X with v^ do X begin X if numdims = 0 then X begin X tok := t; X i := 0; X j := 1; X repeat X if i >= maxdims then badsubscr; X t := t^.next; X skipparen; X j := j * 11; X i := i + 1; X dims[i] := 11; X until t^.kind = tokrp; X numdims := i; X if stringvar then X begin X hpm_new(sarr, j*4); X for k := 0 to j-1 do X sarr^[k] := nil; X end X else X begin X hpm_new(arr, j*8); X for k := 0 to j-1 do X arr^[k] := 0; X end; X t := tok; X end; X k := 0; X t := t^.next; X for i := 1 to numdims do X begin X j := intexpr; X if (j < 0) or (j >= dims[i]) then X badsubscr; X k := k * dims[i] + j; X if i < numdims then X require(tokcomma); X end; X require(tokrp); X if stringvar then X sval := addr(sarr^[k]) X else X val := addr(arr^[k]); X end X else X begin X if v^.numdims <> 0 then X badsubscr; X end; X findvar := v; X end; X X X function inot(i : integer) : integer; X begin X inot := -1 - i; X end; X X function ixor(a, b : integer) : integer; X begin X ixor := asm_ior(asm_iand(a, inot(b)), asm_iand(inot(a), b)); X end; X X X function factor : valrec; X var X v : varptr; X facttok : tokenptr; X n : valrec; X i, j : integer; X tok, tok1 : tokenptr; X s : basicstring; X trick : X record X case boolean of X true : (i : integer); X false : (c : ^char); X end; X begin X if t = nil then snerr; X facttok := t; X t := t^.next; X n.stringval := false; X case facttok^.kind of X toknum : X n.val := facttok^.num; X tokstr : X begin X n.stringval := true; X new(n.sval); X n.sval^ := facttok^.sp^; X end; X tokvar : X begin X t := facttok; X v := findvar; X n.stringval := v^.stringvar; X if n.stringval then X begin X new(n.sval); X n.sval^ := v^.sval^^; X end X else X n.val := v^.val^; X end; X toklp : X begin X n := expr; X require(tokrp); X end; X tokminus : X n.val := - realfactor; X tokplus : X n.val := realfactor; X toknot : X n.val := inot(intfactor); X toksqr : X n.val := sqr(realfactor); X toksqrt : X n.val := sqrt(realfactor); X toksin : X n.val := sin(realfactor); X tokcos : X n.val := cos(realfactor); X toktan : X begin X n.val := realfactor; X n.val := sin(n.val) / cos(n.val); X end; X tokarctan : X n.val := arctan(realfactor); X toklog: X n.val := ln(realfactor); X tokexp : X n.val := exp(realfactor); X tokabs : X n.val := abs(realfactor); X toksgn : X begin X n.val := realfactor; X n.val := ord(n.val > 0) - ord(n.val < 0); X end; X tokstr_ : X begin X n.stringval := true; X new(n.sval); X n.sval^ := numtostr(realfactor); X end; X tokval : X begin X s := strfactor; X tok1 := t; X parse(s, t); X tok := t; X if tok = nil then X n.val := 0 X else X n := expr; X disposetokens(tok); X t := tok1; X dispose(s); X end; X tokchr_ : X begin X n.stringval := true; X new(n.sval); X n.sval^ := ' '; X n.sval^[1] := chr(intfactor); X end; X tokasc : X begin X s := strfactor; X if strlen(s^) = 0 then X n.val := 0 X else X n.val := ord(s^[1]); X dispose(s); X end; X tokmid_ : X begin X n.stringval := true; X require(toklp); X n.sval := strexpr; X require(tokcomma); X i := intexpr; X if i < 1 then i := 1; X j := 255; X if (t <> nil) and (t^.kind = tokcomma) then X begin X t := t^.next; X j := intexpr; X end; X if j > strlen(n.sval^)-i+1 then X j := strlen(n.sval^)-i+1; X if i > strlen(n.sval^) then X n.sval^ := '' X else X n.sval^ := str(n.sval^, i, j); X require(tokrp); X end; X toklen : X begin X s := strfactor; X n.val := strlen(s^); X dispose(s); X end; X tokpeek : X begin X $range off$ X trick.i := intfactor; X n.val := ord(trick.c^); X $if checking$ $range on$ $end$ X end; X otherwise X snerr; X end; X factor := n; X end; X X function upexpr : valrec; X var X n, n2 : valrec; X begin X n := factor; X while (t <> nil) and (t^.kind = tokup) do X begin X if n.stringval then tmerr; X t := t^.next; X n2 := upexpr; X if n2.stringval then tmerr; X if n.val < 0 then X begin X if n2.val <> trunc(n2.val) then n.val := ln(n.val); X n.val := exp(n2.val * ln(-n.val)); X if odd(trunc(n2.val)) then X n.val := - n.val; X end X else X n.val := exp(n2.val * ln(n.val)); X end; X upexpr := n; X end; X X function term : valrec; X var X n, n2 : valrec; X k : tokenkinds; X begin X n := upexpr; X while (t <> nil) and (t^.kind in [toktimes, tokdiv, tokmod]) do X begin X k := t^.kind; X t := t^.next; X n2 := upexpr; X if n.stringval or n2.stringval then tmerr; X if k = tokmod then X n.val := round(n.val) mod round(n2.val) X else if k = toktimes then X n.val := n.val * n2.val X else X n.val := n.val / n2.val; X end; X term := n; X end; X X function sexpr : valrec; X var X n, n2 : valrec; X k : tokenkinds; X begin X n := term; X while (t <> nil) and (t^.kind in [tokplus, tokminus]) do X begin X k := t^.kind; X t := t^.next; X n2 := term; X if n.stringval <> n2.stringval then tmerr; X if k = tokplus then X if n.stringval then X begin X n.sval^ := n.sval^ + n2.sval^; X dispose(n2.sval); X end X else X n.val := n.val + n2.val X else X if n.stringval then X tmerr X else X n.val := n.val - n2.val; X end; X sexpr := n; X end; X X function relexpr : valrec; X var X n, n2 : valrec; X f : boolean; X k : tokenkinds; X begin X n := sexpr; X while (t <> nil) and (t^.kind in [tokeq..tokne]) do X begin X k := t^.kind; X t := t^.next; X n2 := sexpr; X if n.stringval <> n2.stringval then tmerr; X if n.stringval then X begin X f := ((n.sval^ = n2.sval^) and (k in [tokeq, tokge, tokle]) or X (n.sval^ < n2.sval^) and (k in [toklt, tokle, tokne]) or X (n.sval^ > n2.sval^) and (k in [tokgt, tokge, tokne])); X dispose(n.sval); X dispose(n2.sval); X end X else X f := ((n.val = n2.val) and (k in [tokeq, tokge, tokle]) or X (n.val < n2.val) and (k in [toklt, tokle, tokne]) or X (n.val > n2.val) and (k in [tokgt, tokge, tokne])); X n.stringval := false; X n.val := ord(f); X end; X relexpr := n; X end; X X function andexpr : valrec; X var X n, n2 : valrec; X begin X n := relexpr; X while (t <> nil) and (t^.kind = tokand) do X begin X t := t^.next; X n2 := relexpr; X if n.stringval or n2.stringval then tmerr; X n.val := asm_iand(trunc(n.val), trunc(n2.val)); X end; X andexpr := n; X end; X X function expr : valrec; X var X n, n2 : valrec; X k : tokenkinds; X begin X n := andexpr; X while (t <> nil) and (t^.kind in [tokor, tokxor]) do X begin X k := t^.kind; X t := t^.next; X n2 := andexpr; X if n.stringval or n2.stringval then tmerr; X if k = tokor then X n.val := asm_ior(trunc(n.val), trunc(n2.val)) X else X n.val := ixor(trunc(n.val), trunc(n2.val)); X end; X expr := n; X end; X X X procedure checkextra; X begin X if t <> nil then X errormsg('Extra information on line'); X end; X X X function iseos : boolean; X begin X iseos := (t = nil) or (t^.kind in [tokcolon, tokelse]); X end; X X X procedure skiptoeos; X begin X while not iseos do X t := t^.next; X end; X X X function findline(n : integer) : lineptr; X var X l : lineptr; X begin X l := linebase; X while (l <> nil) and (l^.num <> n) do X l := l^.next; X findline := l; X end; X X X function mustfindline(n : integer) : lineptr; X var X l : lineptr; X begin X l := findline(n); X if l = nil then X errormsg('Undefined line'); X mustfindline := l; X end; X X X procedure cmdend; X begin X stmtline := nil; X t := nil; X end; X X X procedure cmdnew; X var X p : anyptr; X begin X cmdend; X clearloops; X restoredata; X while linebase <> nil do X begin X p := linebase^.next; X disposetokens(linebase^.txt); X dispose(linebase); X linebase := p; X end; X while varbase <> nil do X begin X p := varbase^.next; X if varbase^.stringvar then X if varbase^.sval^ <> nil then X dispose(varbase^.sval^); X dispose(varbase); X varbase := p; X end; X end; X X X procedure cmdlist; X var X l : lineptr; X n1, n2 : integer; X begin X repeat X n1 := 0; X n2 := maxint; X if (t <> nil) and (t^.kind = toknum) then X begin X n1 := trunc(t^.num); X t := t^.next; X if (t = nil) or (t^.kind <> tokminus) then X n2 := n1; X end; X if (t <> nil) and (t^.kind = tokminus) then X begin X t := t^.next; X if (t <> nil) and (t^.kind = toknum) then X begin X n2 := trunc(t^.num); X t := t^.next; X end X else X n2 := maxint; X end; X l := linebase; X while (l <> nil) and (l^.num <= n2) do X begin X if (l^.num >= n1) then X begin X write(l^.num:1, ' '); X listtokens(output, l^.txt); X writeln; X end; X l := l^.next; X end; X if not iseos then X require(tokcomma); X until iseos; X end; X X X procedure cmdload(merging : boolean; name : string255); X var X f : text; X buf : tokenptr; X begin X if not merging then X cmdnew; X reset(f, name + '.TEXT', 'shared'); X while not eof(f) do X begin X readln(f, inbuf^); X parseinput(buf); X if curline = 0 then X begin X writeln('Bad line in file'); X disposetokens(buf); X end; X end; X close(f); X end; X X X procedure cmdrun; X var X l : lineptr; X i : integer; X s : string255; X begin X l := linebase; X if not iseos then X begin X if t^.kind = toknum then X l := mustfindline(intexpr) X else X begin X s := stringexpr; X i := 0; X if not iseos then X begin X require(tokcomma); X i := intexpr; X end; X checkextra; X cmdload(false, s); X if i = 0 then X l := linebase X else X l := mustfindline(i) X end X end; X stmtline := l; X gotoflag := true; X clearvars; X clearloops; X restoredata; X end; X X X procedure cmdsave; X var X f : text; X l : lineptr; X begin X rewrite(f, stringexpr + '.TEXT'); X l := linebase; X while l <> nil do X begin X write(f, l^.num:1, ' '); X listtokens(f, l^.txt); X writeln(f); X l := l^.next; X end; X close(f, 'save'); X end; X X X procedure cmdbye; X begin X exitflag := true; X end; X X X procedure cmddel; X var X l, l0, l1 : lineptr; X n1, n2 : integer; X begin X repeat X if iseos then snerr; X n1 := 0; X n2 := maxint; X if (t <> nil) and (t^.kind = toknum) then X begin X n1 := trunc(t^.num); X t := t^.next; X if (t = nil) or (t^.kind <> tokminus) then X n2 := n1; X end; X if (t <> nil) and (t^.kind = tokminus) then X begin X t := t^.next; X if (t <> nil) and (t^.kind = toknum) then X begin X n2 := trunc(t^.num); X t := t^.next; X end X else X n2 := maxint; X end; X l := linebase; X l0 := nil; X while (l <> nil) and (l^.num <= n2) do X begin X l1 := l^.next; X if (l^.num >= n1) then X begin X if l = stmtline then X begin X cmdend; X clearloops; X restoredata; X end; X if l0 = nil then X linebase := l^.next X else X l0^.next := l^.next; X disposetokens(l^.txt); X dispose(l); X end X else X l0 := l; X l := l1; X end; X if not iseos then X require(tokcomma); X until iseos; X end; X X X procedure cmdrenum; X var X l, l1 : lineptr; X tok : tokenptr; X lnum, step : integer; X begin X lnum := 10; X step := 10; X if not iseos then X begin X lnum := intexpr; X if not iseos then X begin X require(tokcomma); X step := intexpr; X end; X end; X l := linebase; X if l <> nil then X begin X while l <> nil do X begin X l^.num2 := lnum; X lnum := lnum + step; X l := l^.next; X end; X l := linebase; X repeat X tok := l^.txt; X repeat X if tok^.kind in [tokgoto, tokgosub, tokthen, tokelse, X tokrun, toklist, tokrestore, tokdel] then X while (tok^.next <> nil) and (tok^.next^.kind = toknum) do X begin X tok := tok^.next; X lnum := round(tok^.num); X l1 := linebase; X while (l1 <> nil) and (l1^.num <> lnum) do X l1 := l1^.next; X if l1 = nil then X writeln('Undefined line ', lnum:1, ' in line ', l^.num2:1) X else X tok^.num := l1^.num2; X if (tok^.next <> nil) and (tok^.next^.kind = tokcomma) then X tok := tok^.next; X end; X tok := tok^.next; X until tok = nil; X l := l^.next; X until l = nil; X l := linebase; X while l <> nil do X begin X l^.num := l^.num2; X l := l^.next; X end; X end; X end; X X X procedure cmdprint; X var X semiflag : boolean; X n : valrec; X begin X semiflag := false; X while not iseos do X begin X semiflag := false; X if t^.kind in [toksemi, tokcomma] then X begin X semiflag := true; X t := t^.next; X end X else X begin X n := expr; X if n.stringval then X begin X write(n.sval^); X dispose(n.sval); X end X else X write(numtostr(n.val), ' '); X end; X end; X if not semiflag then X writeln; X end; X X X procedure cmdinput; X var X v : varptr; X s : string255; X tok, tok0, tok1 : tokenptr; X strflag : boolean; X begin X if (t <> nil) and (t^.kind = tokstr) then X begin X write(t^.sp^); X t := t^.next; X require(toksemi); X end X else X begin X write('? '); X end; X tok := t; X if (t = nil) or (t^.kind <> tokvar) then snerr; X strflag := t^.vp^.stringvar; X repeat X if (t <> nil) and (t^.kind = tokvar) then X if t^.vp^.stringvar <> strflag then snerr; X t := t^.next; X until iseos; X t := tok; X if strflag then X begin X repeat X readln(s); X v := findvar; END_OF_FILE if test 48192 -ne `wc -c <'examples/basic.p.1'`; then echo shar: \"'examples/basic.p.1'\" unpacked with wrong size! fi # end of 'examples/basic.p.1' fi echo shar: End of archive 19 \(of 32\). cp /dev/null ark19isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 32 archives. echo "Now see PACKNOTES and the README" rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 -- Please send comp.sources.unix-related mail to rsalz@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.