home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Usenet 1994 October
/
usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso
/
unix
/
volume21
/
p2c
/
part19
< prev
next >
Wrap
Text File
|
1990-04-05
|
52KB
|
1,609 lines
Subject: v21i064: Pascal to C translator, Part19/32
Newsgroups: comp.sources.unix
Approved: rsalz@uunet.UU.NET
X-Checksum-Snefru: da6cea1c d014eb81 886e97ce e7773e24
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
