Program map (input, output, psource); (* * =====================portable version=================== * ******************************************************** * * program : M A P (Macro Pascal) -- Pascal preprocessor with * constant expressions, macros, included files, and * conditional compilation. (portable version) * * date: February 12, 1978, edited April 30, 1979 * Keyboarded @ UTCS t.i.k May 1981, edit ifd * programer: Doug Comer, Computer Science Dept. Purdue * * input: A Pascal program with expressions allowed in the * const values, and macro definitions and calls. * Macros may be called from the source code by * writing the name prefixed with a dollar sign, with * actual parameters supplied as a string * enclosed in parentheses. The actual parameters * may not contain references to other actual * parameters or macros. Formal parameter references, * also denoted by $name in the body of the macro, * override macro definitions, so a macro with formal * 'a' cannot call macro 'a'. Null argument lists * like () must be used when calling a macro with no * actual parameters. Null parameters will be used * if insufficient actual parameters are specified; * extra actuals are ignored. Note that this differs * from the version cited in S.P.E., Vol 9, p203, 1979 * Input must be in columns 1 - 'rc'. * * output: Output is the file, psource, a compressed version * of the Pascal source deck. The present version * strips all comments except '(*$' and all the * unnecessary blanks in performing the compression. * Also, the source is crammed into 'prc' columns. * * * system : Configured for OMSI PASCAL on RT-11 * * Copyright : (c) 1978. Permission to copy, modify and * distribute, but not for profit, is hereby granted, * provided that this note is included. * * ******************************************************** *) Label 1 (* for aborting *); CONST OutFileName = 'temp.tmp'; arrow = '^'; (*pointer for errors*) blank = ' '; break = ' '; (*break between rc and rest of line*) comma = ','; defexpr = true; (*default is expression evaluation *) deflist = true; (*default is listing *) defprc = 80 ; (*default right column for pascal *) defrc = 80; (*default right column for map input *) dollar = '$'; double = '0'; (*double space carriage control *) equal = '='; DummyName = 'tmptmp.tmp'; errflag = ' '; errprefix= '---> error '; errlen = 40; (*length of error message*) (* error messages *) erabstype = 'evalabs - type error, number needed '; erarith = 'arith - bad type '; eratntype = 'evalatn - type error, number needed '; erbodyeof = 'getbody - end of file in macro body '; erchrtype = 'evalchr - type error, integer needed '; ercklpar = 'ckmacro - left paren expected '; erckrpar = 'ckmacro - right paren expected '; ercodcom = 'docodeif - syntax error, missing comma '; ercodeof = 'docodeif - unexpected end of file '; ercodtype = 'docodeif - type error, boolean needed '; erconvert = 'convert - integer truncated '; ercostype = 'evalcos - type error, number needed '; erdefcom = 'dodefine - missing comma '; erdefname = 'dodefine - syntax error, name needed '; erexptype = 'expression - invalid operand type '; erextype = 'evalexp - type error, number needed '; erfacrpar = 'factor - right paren expected '; erfactype = 'factor - right conflict '; erincname = 'doinclude - file name needed '; erincrpar = 'doinclude - right paren expected '; erindrpar = 'doindex - right paren expected '; erindxtyp = 'doindex - type error, integer needed '; erlentype = 'evallen - type error, string needed '; erlntype = 'evalln - type error, number needed '; erlongstr = 'gettok - string exceeds source line '; ermacname = 'gettok - illegal macro name '; ermacdefn = 'getbsu - undefined macro call '; ermconsyn = 'parsemcon - semicolon expected '; eroctdig = 'gettok - illegal octal digit '; eroddtype = 'evalodd - type error, integer needed '; eropen = 'open - recursive includes ignored '; eropttype = 'dooptions - error in options list '; erordarg = 'evalord - ord requires 1 char.arg. '; erordtype = 'evalord - type error, char. needed '; erover = 'over - table overflow '; erparscon = 'parsecon - equal sign needed '; erparsend = 'parse - unmatched END '; erparseof = 'parse - unexpected end of file '; erparsfwd = 'parse - unmatched forward decl. '; erparsmcon= 'parsemcon - equal sign needed '; erpconsyn = 'parsecon - semicolon expected '; erputtok = 'puttok - token too large '; errelatyp = 'relate - illegal type for rel.oper. '; errelconf = 'relate - type conflict in relation '; erroutype = 'evalrou - type error, real needed '; ersintype = 'evalsin - type error, number needed '; ersqrtype = 'evalsqr - type error, number needed '; erstrtype = 'evalstr - type error, integer needed '; ersyslpar = 'dosysmac - left paren expected '; ertermtyp = 'term - invalid operand type '; ertrutype = 'evaltru - type error, real needed '; ervalexp = 'variable - value or name expected '; ervarfnct = 'variable - unknown FUNCTION, 0 used '; ervarrpar = 'variable - right paren expected '; FFval = 012; (* Form Feed value *) greater = '>'; inname = 'TT:A '; (* Standard input file name *) inlname = ' '; (* Standard input name to print in listing *) LCdiff = 040B; (* ASCII lowercase-LCdiff = ASCII upper case *) letterb = 'B'; lettere = 'E'; lparen = '('; maxcalls = 15; (*max macro call depth*) maxcons = 100; (*max active const defns*) maxcol = 120; (*max right column for input/output*) maxcstr =0500; (*max const string area*) maxdefs = 100; (*max defined macros*) maxdefstr=0500; (*max macro string area*) maxfiles = 3; (*max included file depth*) maxfns = 14; (*max recognizd FUNCTIONs*) maxkeys = 21; (*max recognized language keywords*) maxline = 140; (*max characters per input line*) mincol = 70; (*min right column for input/output*) minus = '-'; ndefconst= 9; (*number of predefined constants*) NewLineVal= 10; (*set to newline character*) newpage = '1'; (*newpage carriage control*) nsysmac = 5; (*number of system macros*) pagesize = 55; (* lines/page not counting heading*) period = '.'; plus = '+'; quote = ''''; rparen = ')'; semi = ';'; space = ' '; (*single space carriage control*) star = '*'; sysinc = 1; (*codes for system macros*) syscodeif= 2; sysindex = 3; sysdefine= 4; sysoption= 5; TabValue = 9; (* Horiz Tab *) title1 = 'MAP '; title1a = ' run on '; title1b = ' at '; title2 = ' include pascal '; title3 = ' line file line line source'; title4 = ' ---- -------------- ---- ------------'; title5 = '--------------------------------------------'; title6 = '-----'; zero = '0'; TYPE alfa = packed array [1..10]of char; (*text = file of char;*) crng = 0..maxcons; (*constant expression stack*) csrng = 0..maxcstr; (*constant expr. string area*) drng = 0..maxdefs; (*macro definition stack *) dsrng = 0..maxdefstr; (*macro def. string area *) flrng = 0..maxfiles; (*included file stack *) fnrng = 0..maxfns; (*builtin FUNCTIONs *) krng = 0..maxkeys; (*keyboards *) lnrng = 0..maxline; (*input line *) mrng = 0..maxcalls; (*macro call stack *) pgrng = 0..pagesize; (*listing page *) msg =packed array [1..40] of char; fptr = ^formal; formal = record fname: alfa; (*name of formal parameter*) fnext: fptr end; fns =(fabs,fatn,fchr,fcos,fexp, (*builtin FUNCTIONs *) flen,fln, fodd, ford, frou, fsin,fsqr,fstr,ftru); lex =(lexadd,lexsub, (*order dependent*) lexand, lexmult, lexdvd, lexmin, lexmax, lexdiv, lexmod, lexalpha, lexint, lexreal, lexst, lexmac, lexbeg, lexcas, lexend, lexrec, lexfun, lexproc, lexcon, lexmcon, lextpe, lexvar, lexfwd, lexor, lexnot, lexlt, lexle, lexeq,lexgt,lexge, lexne, lexsemi, lexother, lexlparen, lexrparen, lexcomma, lexeof); aptr =^arg; arg =record (*actual argument list node*) aform : alfa; (*formal name*) afirst : dsrng; (*start of actual in dstr*) alast : dsrng; anext : aptr end; constyp = (tbl,tch,terr,tin,tot,tre); (*type of const expression*) cset = set of constyp; strng = array[lnrng] of char; errmsg = packed array[1..errlen] of char; var ctab :array [crng] of (*constant table*) record cname : alfa; case ctyp:constyp of tin: (ci :integer); tre: (cr :real); tch: (cfirst:csrng; clen :csrng); tbl: (cb :boolean); tot: (co:alfa) end; ctop, (*current top of ctab and last const*) cvalid : crng; (*last nontemporary constant*) cstr :array [csrng] of char;(*string const storage*) cstop :csrng; FormFeed : Char; fstack :array [flrng] of (*included file stack*) record fname:alfa; (*file name*) ffile:text; fline:integer end; ftop:-1..maxfiles; HorizTab : Char; keywd:array[0..maxkeys] of (*language keywords*) record kname:alfa; (*keyword name*) klex:lex end; mstack:array[mrng] of (*macro calls*) record margs:aptr; (*list of arguments*) mnext:dsrng; (*next char to read*) mlast:dsrng; (*last char in this macro*) matop:dsrng (*actual top upon call*) end; mtop:mrng; (*top of called macro stack*) NewLine : Char; defs :array [drng] of (*macro definitions*) record dname:alfa; (*macro name*) dfirst:dsrng; (*first char in this macro*) dlast:dsrng; (*last char in this macro*) dargs:fptr (*list of formals*) end; dtop :drng; defstr:array[dsrng] of char; (*macro definition bodies*) dstop:dsrng; (*top of defintion string area*) atop:dsrng; (*actual arguments saved in top of defstr*) funct:array[fnrng] of (*list of builtin FUNCTIONs*) record fnnme:alfa; (*FUNCTION name*) fntyp:fns end; inline:strng;(*input line*) last, next:lnrng; (*last char and next char in inline*) ch:char; (*next character from getch*) line:integer; (*last next number*) pline:integer; (*next pascal ouput line number*) tme, (*time of day from system*) dte:alfa; (*date form system*) timein:integer;(*clock value at start of run*) tottme:integer; (*total time used in ms*) linectr:integer;(*clock value at start of run*) nerrors:integer;(*number of errors found*) psource, dummy:text; (*dummy used for real number conversion*) rcopt, prcopt:lnrng;(*right column on input/output*) listopt:boolean; (*list on or off*) expropt:boolean; (*recognize expressions on or off*) lastlex:lex; (*last token type put by puttok*) outpos:lnrng; (*last column pos used by puttok*) lexstr:strng; (*lexical string*) lexlen:lnrng; (*number of chars in lexstr*) lextyp:lex; (*type of token in lexstr*) index:integer; (*for $index macro*) confl : set of lex; (*set of tokens needed blank between*) (*forward declarations for all PROCEDUREs and FUNCTIONs*) PROCEDURE arith; forward; PROCEDURE ckformal(name:alfa; (*formal name*) var found:boolean); forward; PROCEDURE ckmacro(name:alfa; (*macro name*) var found:boolean); forward; PROCEDURE close; forward; PROCEDURE convrt; forward; PROCEDURE convrti; forward; PROCEDURE convrtr; forward; PROCEDURE convrts; forward; PROCEDURE docodeif; forward; PROCEDURE dodefine; forward; PROCEDURE doinclude; forward; PROCEDURE doindex; forward; PROCEDURE dooptions; forward; PROCEDURE dosysmac(d:drng); (*which macro*) forward; PROCEDURE error(err:errmsg); forward; PROCEDURE evalfns(f:fns); forward; PROCEDURE evalabs; forward; PROCEDURE evalatn; forward; PROCEDURE evalchr; forward; PROCEDURE evalcos; forward; PROCEDURE evalexp; forward; PROCEDURE evallen; forward; PROCEDURE evalln; forward; PROCEDURE evalodd;forward; PROCEDURE evalord; forward; PROCEDURE evalrou; forward; PROCEDURE evalsin; forward; PROCEDURE evalsqr; forward; PROCEDURE evalstr; forward; PROCEDURE evaltru; forward; PROCEDURE experror(err:errmsg); forward; PROCEDURE expression; forward; PROCEDURE factor; forward; PROCEDURE findcon(name: alfa; (*name of const*) var found:boolean); forward; PROCEDURE flookup(name:alfa; (*FUNCTION name*) var fun:fns; (*FUNCTION code*) var found: boolean); forward; PROCEDURE flush; forward; PROCEDURE forcereal; forward; PROCEDURE getactuals(f:fptr; (*pointer to next formal*) var act: aptr); (*pointer to actual*) forward; PROCEDURE getbody; forward; PROCEDURE getbsu; forward; PROCEDURE getcdparm; forward; PROCEDURE getch; forward; PROCEDURE getformals(var f:fptr); forward; PROCEDURE getkey; forward; PROCEDURE getline; forward; PROCEDURE getparm; forward; PROCEDURE gettok; forward; PROCEDURE initialize; forward; PROCEDURE need(l:pgrng); forward; PROCEDURE newpg; forward; PROCEDURE open(name:alfa); (*file name to open*) forward; PROCEDURE over(i: integer; (* current value *) maxval:integer); (*max value*) forward; PROCEDURE parse(top:crng; (*ctop upon entry*) tok:lex); (*token causing recursion*) forward; PROCEDURE parsecon; forward; PROCEDURE parsemcon; forward; PROCEDURE pushback; forward; PROCEDURE puttok; forward; PROCEDURE relate; forward; PROCEDURE scanheader; forward; PROCEDURE term; forward; PROCEDURE terminate; forward; PROCEDURE timedate; forward; FUNCTION typesmatch:boolean; forward; FUNCTION typeis(c:cset): boolean; forward; PROCEDURE variable; forward; (*PROCEDUREs and FUNCTIONs*) (* Pack and Unpack are fake under OMSI. *) PROCEDURE unpack(z:alfa;VAR a:strng;i:Integer);VAR j:Integer; BEGIN FOR j:=1 TO 10 DO a[j-1+i]:=z[j] END; PROCEDURE pack(a:strng;i:Integer;VAR z:alfa);var j:Integer; BEGIN FOR j := 1 TO 10 DO z[j] := a[j-1+i] END; (************) (*arith - recognize arithmetic ops in expression*) (************) PROCEDURE arith; var op:lex; begin term; if(lextyp IN [lexor, lexadd,lexsub]) and (not typeis([terr])) then if ((lextyp = lexor) and typeis([tbl])) or ((lextyp in [lexadd, lexsub]) and typeis([tin,tre])) then begin over(ctop, maxcons); WHILE lextyp in [lexor, lexadd, lexsub] do begin ctop:= ctop + 1; op :=lextyp; getkey; term; if (op = lexor) and typeis ([tbl]) then with ctab[ctop -1] do cb:= cb or ctab[ctop].cb else if (op in [lexadd,lexsub]) and typeis ([tin, tre]) then with ctab[ctop-1] do if (ctyp = tin) and (ctab[ctop].ctyp = tin) then case op of lexadd: ci := ci + ctab[ctop].ci; lexsub:ci:= ci - ctab[ctop].ci end (*case*) else begin forcereal; case op of lexadd: cr := cr + ctab[ctop].cr; lexsub : cr := cr - ctab [ctop].cr end (* case*) end else if ctab[ctop].ctyp<> terr then experror (erarith); ctop := ctop -1 end end end (* arith*); (**************) (* ckformal - if reference to formal, push on call stack*) (**************) PROCEDURE ckformal (* name : alfa; var found :boolean*); var a: aptr; begin found := false; if mtop >0 then begin a:= mstack[mtop].margs; WHILE (a <> nil) and (not found) do begin with a^ do if aform = name then begin found := true; pushback; mtop := mtop + 1; with mstack [mtop] do begin margs := nil; mnext := afirst; mlast := alast; matop := atop end; getch end; a:= a^.anext end; if found then gettok end end (* ckformal *); (* ******* *) (* ckmarcro - if macro called, push onto stack *) (* ******* *) PROCEDURE ckmacro (* name: alfa; var found: boolean *); var d: drng (* index to defined macros *); begin d:= dtop; defs[0].dname := name; WHILE defs[d].dname <> name do d := d - 1; if d > 0 then begin found := true; if d <= nsysmac then dosysmac (d) else begin over (mtop, maxcalls); with mstack[mtop + 1], defs[d] do begin margs := nil; mnext :=dfirst; mlast := dlast; matop := atop; WHILE ch = blank do getch; if ch = lparen then begin getch; getactuals (dargs,margs); if ch <> rparen then error (erckrpar) end else error (ercklpar) end; mtop:= mtop + 1; getch end; gettok end end (* ckmacro *); (*********) (*close - close the current file + restore old one *) (********) PROCEDURE close; begin ftop := ftop - 1 end (* close *); (*********) (*convrt - convert constand to pascal input format *) (********) PROCEDURE convrt; var i : integer; c: char; sign: boolean; begin with ctab [ctop] do case ctyp of tin: begin if abs(ci) >= maxint then begin i := maxint; error (erconvert) end else i := ci; if i < 0 then begin sign := true; i := abs (i) end else sign := false; lexlen := 0; WHILE i > 0 do begin lexlen := lexlen +1; lexstr[lexlen]:= chr(ord('0') + (i mod 10)); i := i div 10 end; if sign then begin lexlen := lexlen + 1; lexstr[lexlen] := minus end; for i := 1 to (lexlen div 2) do begin c:= lexstr [i]; lexstr[i] := lexstr[lexlen - i + 1]; lexstr[lexlen - i + 1] := c end; lextyp := lexint end; terr:; tot: begin lexlen :=10; unpack(co, lexstr,1); lextyp:= lexalpha; WHILE lexstr[lexlen] = blank do lexlen := lexlen -1 end; tch: begin lextyp := lexst; lexlen := 1; lexstr[1]:= quote; for i := 0 to clen - 1 do begin lexlen := lexlen + 1; lexstr[lexlen] := cstr[cfirst + i]; if lexstr[lexlen] = quote then begin lexlen:= lexlen + 1; lexstr[lexlen] := quote end end; lexlen := lexlen + 1; lexstr[lexlen] := quote end; tbl: begin lextyp := lexalpha; if cb then begin unpack ('TRUE ',lexstr, 1); lexlen := 4 end else begin unpack ('FALSE ', lexstr, 1); lexlen := 5 end end; tre: begin rewrite(dummy,DummyName); write(dummy, cr, blank); reset(dummy,DummyName); WHILE dummy^ = blank do get (dummy); lexlen := 0; WHILE dummy ^ <> blank do begin lexlen := lexlen + 1; lexstr[lexlen] := dummy^; get (dummy) end; lextyp := lexreal end end (*case*) end (*convrt*); (**********) (*convrti - convert integer token to binary form*) (**********) PROCEDURE convrti; var i: integer; l: lnrng; begin with ctab[ctop] do begin ctyp := tin; ci := 0; for l := 1 to lexlen do ci := 10 * ci + ord (lexstr[l]) - ord(zero) end end (*convrti*); (**********) (*convrtr - convrert real token to bnary from *) (**********) PROCEDURE convrtr; var i : lnrng; begin rewrite(dummy,DummyName); for i := 1 to lexlen do write(dummy, lexstr[i]); write(dummy,blank); reset(dummy,DummyName); with ctab[ctop] do begin ctyp := tre; read(dummy, cr) end end (*convrtr*); (**********) (*convrts - convert quoted string to const string*) (**********) PROCEDURE convrts; var l: lnrng; begin with ctab[ctop] do begin ctyp := tch; clen := 0; cfirst := cstop + 1; l := 2 (*skip leading quote*); WHILE l<= (lexlen - 1) do begin clen := clen + 1; over (cstop, maxcstr); cstop := cstop + 1; cstr[cstop] := lexstr[l]; if lexstr[l] = quote then l := l + 2 else l := l + 1 end end end (*convrts*); (**********) (*docodeif - process $codeif (expr., cod) *) (**********) PROCEDURE docodeif; var a: dsrng(*save area for atop upon entry*); ctr:integer (*left paren count*); begin getkey; over(ctop, maxcons); ctop:= ctop +1; expression; ctop:= ctop - 1; a := atop; if lextyp <> lexcomma then experror(ercodcom) else with ctab[ctop + 1] do if ctyp = tbl then if cb then begin over(mtop,maxcalls); with mstack[mtop + 1] do begin margs := nil; mlast := atop - 1; getcdparm; mnext := atop; matop := a; end; mtop := mtop + 1; getch end else begin ctr := 1; WHILE ctr > 0 do begin if ch = NewLine then begin if (mtop = 0) and (ftop = 0) and eof(fstack[0]. ffile) then begin error(ercodeof); goto 1 end end else if ch = rparen then ctr := ctr - 1 else if ch = lparen then ctr := ctr + 1; getch end end else if ctyp <> terr then error(ercodtype) end (* docodeif*); (**********) (*dodefine - process $define(name(formal parms), string)*) (**********) PROCEDURE dodefine; begin gettok; if lextyp <> lexalpha then error (erdefname) else begin over (dtop,maxdefs); dtop := dtop + 1; with defs[dtop] do begin lexstr[0] := dollar; pack(lexstr, 0, dname); dfirst := dstop + 1; dlast := dstop; gettok; if lextyp = lexlparen then begin gettok; getformals(dargs); gettok end else dargs := nil end; if lextyp <> lexcomma then begin error(erdefcom); dtop := dtop - 1 end else getbody end end (*dodefine*); (*********) (*doinclude - process $include (file) *) (*********) PROCEDURE doinclude; var name : alfa; begin getbsu; if lextyp <> lexalpha then error (erincname) else begin pack (lexstr, 1, name) (*check file name here if desired *); getkey; if lextyp <> lexrparen then error (erincrpar); open (name) end end(*doinclude*); (**********) (*doindex - process $index(expression ) *) (**********) PROCEDURE doindex; var i: lnrng; begin over(ctop,maxcons); ctop:= ctop + 1; getkey; if lextyp=lexrparen then with ctab[ctop] do begin ctyp := tin; ci := 0 end else expression; if lextyp <> lexrparen then error (erindrpar) else begin pushback; with ctab[ctop] do if not (ctyp in [terr,tin]) then error(erindxtyp) else if ctyp = tin then begin index := index + 1; ci := ci+ index; convrt; over(mtop,maxcalls); mtop := mtop + 1; with mstack [mtop] do begin margs := nil; mnext := atop; mlast := atop - 1; matop := atop; for i := lexlen downto 1 do begin mnext := mnext -1; defstr[mnext] := lexstr[i] end; getch end end end; ctop := ctop -1 end (*doindex*); (*********) (*dooptions - process $options (...)*) (*********) PROCEDURE dooptions; var i: integer; begin gettok; WHILE not (lextyp in [lexrparen, lexeof]) do begin if lextyp = lexalpha then if lexstr[1] in ['R','P','N','L','E'] then case lexstr[1] of 'P', 'R': begin WHILE not (ch in ['0'..'9',')']) do getch; i := 0; WHILE ch in ['0' ..'9'] do begin i := 10 * i + ord(ch) - ord('0'); getch end; if (mincol <=i) and (i<= maxcol) then case lexstr[1] of 'P': prcopt :=i; 'R': rcopt := i end (*case*) end; 'N': if lexlen >= 3 then if lexstr [3] = 'L' then listopt := false else if lexstr [3] = 'E' then expropt := false; 'L': listopt := true; 'E': expropt := true end else error(eropttype) else if lextyp <> lexcomma then error(eropttype); gettok end end (*dooptions*); (*********) (*dosysmac - perform proper system macro*) (*********) PROCEDURE dosysmac (*d:drng*); begin gettok; if lextyp <> lexlparen then error (ersyslpar) else case d of sysinc:doinclude; syscodeif: docodeif; sysindex:doindex; sysdefine: dodefine; sysoption:dooptions end end(*dosysmac*); (**********) (*error - write out error message*) (*********) PROCEDURE error (*err:errmsg*); var i:lnrng; begin need(2) (*make sure message fits on page*); if listopt then begin write(space, errflag); for i :=1 to next - 1 do write(blank); writeln(arrow) end else writeln('AT LINE:', line:2, '(Pascal line:', pline:2,')'); writeln(space, errprefix, err); nerrors := nerrors + 1 end (*error*); (**********) (*evalfns - evaluate a builtin FUNCTION *) (**********) PROCEDURE evalfns (*f:fns*); begin case f of fabs: evalabs; fatn: evalatn; fchr: evalchr; fcos: evalcos; fexp: evalexp; flen: evallen(*length of a string*); fln: evalln; fodd: evalodd; ford: evalord; frou: evalrou (*round*); fsin: evalsin; fsqr: evalsqr; fstr: evalstr (*string of - make integer a string*); ftru: evaltru (* truncate*) end(*case*) end (* evalfns*); (**********) (*evalabs - evaluate the abs builtin FUNCTION*) (*********) PROCEDURE evalabs; begin with ctab[ctop] do if typeis([tre, tin]) then case ctyp of tin: ci := abs(ci); tre:cr := abs(cr) end else experror(erabstype) end (*evalabs*); (**********) (* evalatn - evaluate the arctan builtin FUNCTION*) (**********) PROCEDURE evalatn; begin with ctab[ctop] do if typeis([tre,tin]) then case ctyp of tin: begin cr := arctan(ci); ctyp := tre end; tre: cr := arctan(cr) end (*case*) else experror(eratntype) end (*evalatn*); (**********) (*evalchr - evaluate the chr builtin FUNCTION*) (**********) PROCEDURE evalchr; var i:integer; begin with ctab[ctop] do if ctyp = tin then begin i := ci; ctyp := tch; over(cstop, atop); cstop := cstop + 1; clen := 1; cstr[cstop] := chr (i); cfirst := cstop end else experror(erchrtype) end(*evalchr*); (**********) (*evalcos - evaluate the cosine biultin FUNCTION*) (**********) PROCEDURE evalcos; begin with ctab[ctop] do if typeis([tre,tin]) then case ctyp of tin: begin cr:= cos(ci); ctyp := tre end; tre : cr := cos(cr) end (*case*) else experror (ercostype) end (*evalcos*); (**********) (*evalexp - evaluate the exp builtin FUNCTION*) (*********) PROCEDURE evalexp; begin with ctab[ctop] do if typeis([tre,tin]) then case ctyp of tin: begin cr := exp(ci); ctyp := tre end; tre: cr := exp(cr) end (*case*) else experror(erextype) end (*evalexp*); (**********) (* evallen - evaluate the length builtin FUNCTION*) (**********) PROCEDURE evallen; var i:integer; begin with ctab[ctop] do if ctyp = tch then begin i:= clen; cstop:= cfirst -1; ctyp := tin; ci :=i end else experror(erlentype) end (*evallen*); (**********) (*evalln - evaluate the ln builtin FUNCTION*) (**********) PROCEDURE evalln; begin with ctab[ctop] do if typeis ([tre,tin]) then case ctyp of tin: begin cr := ln(ci); ctyp := tre end; tre:cr := ln(cr) end (*case*) else experror(erlntype) end (*evalln*); (*********) (*evalodd - evaluate the odd bultin FUNCTION*) (*********) PROCEDURE evalodd; var i:integer; begin with ctab[ctop] do if ctyp = tin then begin i := ci; ctyp := tbl; cb := odd (i) end else experror(eroddtype) end (*evavodd*); (*********) (*evalord - evaluate the ord builtin FUNCTION*) (*********) PROCEDURE evalord; var c:char; begin with ctab[ctop] do if ctyp = tch then if clen = 1 then begin c := cstr[cfirst]; ctyp := tin; ci := ord(c) end else experror(erordarg) else experror(erordtype) end (*evalord*); (***********) (*evalrou - evaluate the round builtin FUNCTION*) (***********) PROCEDURE evalrou; var r:real; begin with ctab[ctop] do if ctyp = tre then begin r := cr; ctyp:= tin; ci := round(r) end else experror(erroutype) end(*evalrou*); (*********) (*evalsin - evaluate the sin builtin FUNCTION*) (*********) PROCEDURE evalsin; begin with ctab[ctop] do if typeis ([tre,tin]) then case ctyp of tin:begin cr:= sin(ci); ctyp:= tre end; tre:cr := sin(cr) end(*case*) else experror(ersintype) end (*evalsin*); (*********) (*evalsqr - evaluate the sqr builtin FUNCTION*) (*********) PROCEDURE evalsqr; begin with ctab[ctop] do if typeis([tre,tin]) then case ctyp of tin: ci:= sqr (ci); tre:cr:= sqr(cr) end(*case*) else experror(ersqrtype) end (*evalsqr*); (*********) (*evalstr - evaluate the stringof builtin FUNCTION*) (*********) PROCEDURE evalstr; var i:integer; c:char; sgn:boolean; begin with ctab[ctop] do if ctyp <> tin then experror(erstrtype) else begin i:= ci; if i < 0 then begin sgn := true; i := abs(i) end else sgn := false; over(cstop,atop); cstop:= cstop + 1; ctyp := tch; cfirst := cstop; if i = 0 then begin clen := 1; cstr [cstop] := zero end else begin clen :=0; WHILE i > 0 do begin cstr [cstop] := chr(ord(zero) + (i mod 10)); i := i div 10; over (cstop,atop); cstop := cstop + 1 ; clen := clen + 1 end; if sgn then cstr [ cstop] := minus else cstop := cstop -1; for i := 0 to (clen -1) div 2 do begin c:= cstr[i + cfirst]; cstr [i + cfirst] := cstr[cfirst + clen -i -1]; cstr [cfirst + clen -i -1 ] := c end end end end (*evalstr*); (**********) (*evaltru - evaluate trunc builtin FUNCTION*) (**********) PROCEDURE evaltru; var r:real; begin with ctab[ctop] do if ctyp = tre then begin r := cr; ctyp := tin; ci := trunc(r) end else experror(ertrutype) end (*evaltru*); (**********) (*experror - print error for expression and flush*) (**********) PROCEDURE experror (*err:ermsg*); begin error(err);ctab[ctop].ctyp := terr; flush end (*experror*); (**********) (*expression - parse expression; put value in ctabl[ctop]*) (**********) PROCEDURE expression; begin relate; if typeis([tch]) then begin over(ctop,maxcons); ctop := ctop +1; WHILE lextyp in [lexst, lexalpha] do begin relate; if typeis([tch]) then with ctab[ctop - 1] do clen := clen + ctab[ctop].clen else if not typeis ([terr]) then experror(erexptype) end; ctop := ctop -1; end end (*expression*); (***********) (* factor- recognize factor part of expression*) (**********) PROCEDURE factor; var op:lex; begin if lextyp in [lexnot, lexsub] then begin op:= lextyp; getkey; factor; with ctab[ctop] do if typeis([tbl]) and (op = lexnot) then cb:= not cb else if typeis([tin, tre]) and (op = lexsub) then case ctyp of tin: ci := - ci; tre: cr := - cr end (*case*) else if ctyp <> terr then begin ctyp := terr; experror(erfactype) end end else if lextyp = lexlparen then begin getkey;expression; if not typeis([terr]) then if lextyp <> lexrparen then experror(erfacrpar) else getkey end else variable end (*factor*); (**********) (*findcon - find previously defined constand*) (**********) PROCEDURE findcon (* name:alfa; var found: boolean*); var c:crng; i:integer; begin c:= cvalid; ctab [0].cname := name; WHILE ctab [c].cname <> name do c := c - 1; if c > 0 then begin ctab[ctop] := ctab[c]; with ctab[ctop] do if ctyp = tch then begin over(cstop + clen, maxcstr); cfirst := cstop + 1; for i := 0 to clen - 1 do begin cstop := cstop + 1; cstr[cstop] := cstr [ctab[c].cfirst + i] end end; found := true end end (*findon*); (**********) (*flookup - loopup FUNCTION name and return type code*) (**********) PROCEDURE flookup (* name: alfa; var fun:fns;var found:boolean*); var f:fnrng; begin funct[0].fnnme := name; f:= maxfns; WHILE funct[f].fnnme <> name do f := f - 1; if f = 0 then found := false else begin found := true; fun := funct[f].fntyp end end (* flookup*); (**********) (*flush - flush to semicolon*) (**********) PROCEDURE flush; begin WHILE not (lextyp in [lexeof, lexsemi]) do getkey end (*flush*); (*********) (*forcereal - force top two constants on stack to real*) (**********) PROCEDURE forcereal; var i:integer; begin with ctab[ctop] do if ctyp = tin then begin i := ci; ctyp := tre; cr := i end; with ctab [ctop - 1] do if ctyp = tin then begin i := ci; ctyp := tre; cr := i end end (*forcereal*); (**********) (*getactuals - get actual parameters for macro call*) (**********) PROCEDURE getactuals (* f: fptr; var act: aptr*); begin if f = nil then (* if no formals, then no actuals*) else begin new(act); with act^, f^ do begin aform := fname; alast := atop - 1; getparm; afirst := atop; if ch = comma then getch; getactuals(fnext,anext) end end; end (*getactuals*); (***********) (*getbody - get the body of a macro*) (**********) PROCEDURE getbody; var ctr:integer (*left parenthesis counter*); begin if ch = rparen then with defs[dtop] do begin getch; dlast := dstop; dfirst := dstop + 1 end else begin ctr :=1; with defs[dtop] do begin WHILE ctr >0 do begin over (dstop,atop); dstop:= dstop + 1; defstr[dstop] := ch; dlast := dstop; if ch = rparen then ctr := ctr - 1 else if ch = lparen then ctr := ctr + 1 else if (ch = NewLine) and (ftop = 0) and eof(fstack[0]. ffile) then begin error(erbodyeof); goto 1 end; getch end; defstr[dlast] := blank (* replace trailing ")"*) end end end (*getbody*); (***********) (*getbsu - get basic syntatic unit, subst.macro calls*) (**********) PROCEDURE getbsu; var name:alfa; found:boolean; begin gettok; WHILE lextyp = lexmac do begin pack(lexstr, 1,name); ckformal (name, found); if not found then begin ckmacro (name, found); if not found then begin error(ermacdefn);gettok end end; end; end; (*********) (*getcdparm - get "codeif" code and save it*) (*********) PROCEDURE getcdparm; var ctr:integer; d:dsrng; begin d:= dstop; ctr :=0; WHILE (ctr > 0) or (ch <> rparen ) do begin over(d,atop); d:= d + 1; defstr[d] := ch; if ch = lparen then ctr := ctr + 1 else if ch = rparen then ctr := ctr - 1; getch end; if d > dstop then begin over ( d, atop); d := d + 1; defstr[d] := blank; WHILE d > dstop do begin atop := atop -1; defstr[atop] := defstr[d]; d := d - 1 end end end (* getcdparm*); (**********) (*getch - get next charcter and place in ch*) (**********) Procedure GetCH; begin if mtop > 0 then WHILE (mstack[mtop].mnext > mstack[mtop].mlast) and (mtop > 0 ) do begin atop := mstack[mtop].matop; mtop := mtop - 1; end; if mtop >0 then with mstack [mtop] do begin ch := defstr[mnext]; mnext := mnext + 1 end else begin if next > last then getline; ch := inline[next]; next := next + 1 end; IF ch >= 'a' THEN ch := chr(ord(ch)-LCdiff) (* ifd *) end (*getch*); (**********) (* getformals - get formal parameter names*) (**********) PROCEDURE getformals (*var f:fptr*); begin if lextyp <> lexalpha then f := nil else begin new(f); lexstr[0]:= dollar; pack(lexstr,0,f^.fname); gettok; if lextyp = lexcomma then begin gettok; getformals(f^.fnext) end else f^.fnext:= nil end end (*getformals*); (**********) (*getkey - get token and classify language keywords *) (**********) PROCEDURE getkey; var name: alfa (* name of constant*); k:krng (* pointer to keywords*); begin getbsu; if lextyp = lexalpha then begin pack (lexstr,1,name); keywd[0].kname := name; k := maxkeys; WHILE keywd[k].kname <> name do k := k - 1; if k > 0 then lextyp := keywd[k].klex end end (* getkey*); (**********) (*getline - place input line in linline; set next, last*) (**********) PROCEDURE getline; var incol: lnrng; i: integer; begin WHILE eof(fstack[ftop].ffile) and (ftop > 0) do close; if eof(fstack[ftop].ffile) then begin next := 1; last := 0; inline[next] := NewLine; end else with fstack[ftop] do begin line := line + 1; fline := fline + 1; incol := 1; if listopt then begin if linectr >= pagesize then begin linectr := 0; newpg end; linectr := linectr +1; write(space, line:4,' '); for i := 1 to 7 do write (fname[i]); write (fline :5, pline:8,' '); WHILE (not eoln(ffile)) and (incol <= rcopt) and (ffile^ =blank) do begin get(ffile); write (blank); incol := incol + 1 end; next := incol; inline[next]:= NewLine (* in case of empty line*); while (not eoln(ffile)) and (incol <= rcopt) do begin inline [incol] := ffile^; incol := incol + 1; write (ffile^); get(ffile) end; last := incol - 1; if not eoln(ffile) then begin write(break); WHILE not eoln(ffile) and (incol< maxcol) do begin write(ffile^); get(ffile) end end; writeln end else begin WHILE(not eoln(ffile)) and(incol <= rcopt) and (ffile^ = blank) do begin get(ffile); incol := incol + 1 end; next := incol; inline[next] := NewLine (* in case of empty line*); WHILE (not eoln(ffile)) and (incol <= rcopt) do begin inline[incol]:= ffile^; incol := incol + 1; get(ffile) end; last := incol -1 end; readln(ffile); if last >= next then begin last := last + 1; inline[last] := NewLine end end end(*getline*); (**********) (*getparm - get an actual parm and save*) (**********) PROCEDURE getparm; var ctr:integer; d:dsrng; begin d:= dstop; ctr:= 0; WHILE (ctr >0) or not(ch in [comma, rparen]) do begin over(d,atop); d := d + 1; defstr[d] := ch; if ch = lparen then ctr := ctr + 1 else if ch = rparen then ctr := ctr - 1; getch end; if d > dstop then begin over(d, atop); d := d + 1; defstr[d] := blank; WHILE d > dstop do begin (* move parm to right*) atop := atop - 1; defstr[atop] := defstr[d]; d := d -1 end end end (*getparm*); (************) (* gettok - get a token; set lexstr, lexlen, lextyp*) (************) PROCEDURE gettok; var i:integer; num: integer(* value of octal number*); begin lexlen := 0; WHILE lexlen = 0 do begin WHILE (ch = blank) OR (ch=HorizTab) OR (ch=FormFeed) do getch; lexlen := 1; lextyp := lexother; lexstr[1] := ch; IF ch=NewLine THEN BEGIN (* ifd *) if (ftop = 0) and eof(fstack[ftop].ffile) then lextyp := lexeof else begin getch; lexlen := 0 end END ELSE CASE ch OF 'A','B','C','D','E','F','G','H','I','J','K','L','M', 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z': begin getch; lextyp := lexalpha; WHILE ch in ['A' .. 'Z', '0' ..'9'] do begin lexlen := lexlen + 1; lexstr[lexlen] := ch; getch end; if lexlen > 10 then lexlen := 10; for i := lexlen + 1 to 10 do lexstr[i] := blank end; '0','1','2','3','4','5','6','7','8','9': begin getch; lextyp := lexint; WHILE ch in ['0' .. '9'] do begin lexlen := lexlen + 1; lexstr[lexlen] := ch; getch end; if ch = letterb then begin (* octal*) getch; num := 0; for i := 1 to lexlen do if lexstr[i] in ['0' .. '7'] then num := 8 * num + ord(lexstr[i]) - ord(zero) else begin num := 8 * num; error(eroctdig) end; over(ctop, maxcons); ctop:= ctop +1; with ctab[ctop] do begin ctyp := tin; ci := num end; convrt; ctop := ctop -1 end else begin if ch = period then begin getch; if ch = period then pushback else begin lextyp := lexreal; lexlen := lexlen + 1; lexstr[lexlen] := period; WHILE ch in ['0' .. '9'] do begin lexlen := lexlen + 1; lexstr[lexlen] := ch; getch end end end; if ch = lettere then begin lextyp := lexreal; lexlen := lexlen + 1; lexstr[lexlen] := ch; getch; if ch in [plus, minus] then begin lexlen := lexlen + 1; lexstr[lexlen] := ch; getch end; WHILE ch in ['0' .. '9'] do begin lexlen := lexlen + 1; lexstr[lexlen] := ch; getch end end end end; '+': begin lextyp := lexadd; getch end; '-': begin lextyp := lexsub; getch end; '*': begin lextyp := lexmult; getch end; '/': begin lextyp := lexdvd; getch end; '(': begin getch; if ch <> star then lextyp := lexlparen else begin getch; if ch = dollar then begin lexlen := 3; unpack ('(*$ ', lexstr,1); repeat repeat getch; lexlen := lexlen + 1; lexstr[lexlen] := ch until ch = star; getch; lexlen := lexlen + 1; lexstr[lexlen] := ch until ch = rparen; getch end else begin lexlen :=0; repeat WHILE ch <> star do getch; getch until ch = rparen; getch end end end; ')': begin lextyp := lexrparen; getch end; '$': begin getch; if not (ch in['A' ..'Z']) then begin error(ermacname); lexlen := 0 end else begin lextyp := lexmac; WHILE ch in ['A' ..'Z', '0' .. '9'] do begin lexlen := lexlen + 1; lexstr[lexlen] := ch; getch end; if lexlen > 10 then lexlen := 10; for i := lexlen + 1 to 10 do lexstr[i] := blank end end; '=': begin lextyp := lexeq; getch end; ',': begin lextyp := lexcomma; getch end; '.': begin getch; if ch = period then begin lexstr[2] := period; lexlen := 2; getch end end; '''': begin (* extract string including all quotes*) lexlen := 0; repeat over(lexlen, maxline); lexlen := lexlen + 1; lexstr[lexlen] := ch; repeat getch; if ch = NewLine then begin error(erlongstr); pushback; ch := quote (* supply missing quote*) end; over(lexlen, maxline); lexlen := lexlen + 1; lexstr[lexlen] := ch until lexstr[lexlen] = quote; getch until ch <> quote; lextyp := lexst end; ':': begin getch; if ch = equal then begin lexlen := 2; lexstr[2] := equal; getch end end; '#': begin lextyp := lexne; unpack ('<> ',lexstr,1); lexlen := 2; getch end; '!': begin lextyp := lexor; unpack('OR ', lexstr,1); lexlen := 2; getch end; '&': begin lextyp := lexand; unpack('AND ',lexstr,1); lexlen := 3; getch end; '<': begin getch; if ch = equal then begin lexlen := 2; lexstr[2] := equal; lextyp := lexle; getch end else if ch = greater then begin lexlen := 2; lexstr[2] := greater; lextyp := lexne; getch end else lextyp := lexlt end; '>': begin getch; if ch = equal then begin lexlen := 2; lextyp:= lexge; lexstr[2]:= equal; getch end else lextyp:= lexgt end; (*****'@': begin lextyp:= lexle; unpack ('<= ', lexstr,1); lexlen := 2; getch end; '\': begin lextyp:= lexge; unpack('>= ', lexstr,1); lexlen := 2; getch end; *****) '~': begin lextyp := lexnot; unpack ('NOT ', lexstr, 1); lexlen := 3; getch end; ';': begin lextyp:= lexsemi; getch end; '[',']','^','_','?': getch (* all other characters*) end (*case*) end end (* gettok*); (***********) (*initialize - perform all necessary initialization*) (***********) PROCEDURE initialize; var i:integer; begin FormFeed := Chr(FFval); HorizTab := Chr(TabValue); NewLine := Chr(NewLineVal); with ctab[1] do begin cname := 'MM '; ctyp:= tch; clen := 2; cfirst := 1 end; with ctab[2] do begin cname := 'DD '; ctyp := tch; clen := 2; cfirst := 4 end; with ctab[3] do begin cname := 'YY '; ctyp := tch; clen := 2; cfirst := 7 end; with ctab[4] do begin cname := 'TIME '; ctyp := tch; clen := 8; cfirst := 9 end; with ctab[5] do begin cname := 'DATE '; ctyp := tch; clen := 8; cfirst := 1 end; with ctab [6] do begin cname := 'TRUE '; ctyp := tbl; cb := true end; with ctab[7] do begin cname := 'FALSE '; ctyp := tbl; cb := false end; with ctab [8] do begin cname := 'MAXINT '; ctyp := tre; cr := maxint end; with ctab[9] do begin cname := 'MININT '; ctyp := tre; cr := - maxint end; ctop := ndefconst (* number of predefined constants *); cvalid := ndefconst; timedate (* put mm/dd/yyhh:mm:ss into cstr[1..16] *); (*keywords are in order of decreasing frequency of access *) with keywd[16] do begin kname := 'AND '; klex := lexand end; with keywd[20] do begin kname := 'BEGIN '; klex := lexbeg end; with keywd[14] do begin kname := 'CASE '; klex := lexcas end; with keywd[10] do begin kname := 'CONST '; klex := lexcon end; with keywd[11] do begin kname := 'DIV '; klex := lexdiv end; with keywd[21] do begin kname := 'end '; klex := lexEND END; with keywd[ 8] do begin kname := 'EXTERN '; klex := lexfwd end; with keywd[ 2] do begin kname := 'FORTRAN '; klex := lexfwd end; with keywd[15] do begin kname := 'FORWARD '; klex := lexfwd end; with keywd[ 9] do begin kname := 'FUNCTION '; klex := lexfun end; with keywd[ 4] do begin kname := 'MAX '; klex := lexmax end; with keywd[ 3] do begin kname := 'MCONST '; klex := lexmcon end; with keywd[ 5] do begin kname := 'MIN '; klex := lexmin end; with keywd[ 6] do begin kname := 'MOD '; klex := lexmod end; with keywd[17] do begin kname := 'NOT '; klex := lexnot end; with keywd[12] do begin kname := 'OR '; klex := lexor end; with keywd[19] do begin kname := 'PROCEDURE '; klex := lexproc end; with keywd[13] do begin kname := 'RECORD '; klex := lexrec end; with keywd[ 1] do begin kname := 'RUN '; klex := lexfwd end; with keywd[ 7] do begin kname := 'TYPE '; klex := lextpe end; with keywd[18] do begin kname := 'VAR '; klex := lexvar end; mtop := 0; dstop:= 0; defs[sysinc].dname := '$INCLUDE '; defs[sysdefine].dname := '$DEFINE '; defs[sysindex].dname := '$INDEX '; defs[sysoption].dname := '$OPTIONS '; defs[syscodeif].dname := '$CODEIF '; dtop:= nsysmac; atop := maxdefstr (* actuals in rhs of dstr*); with funct[ 1] do begin fnnme := 'ABS '; fntyp := fabs end; with funct[ 2] do begin fnnme := 'ARCTAN '; fntyp := fatn end; with funct[ 3] do begin fnnme := 'CHR '; fntyp := fchr end; with funct[ 4] do begin fnnme := 'COS '; fntyp := fcos end; with funct[ 5] do begin fnnme := 'EXP: '; fntyp := fexp end; with funct[ 6] do begin fnnme := 'LENGTH '; fntyp := flen end; with funct[ 7] do begin fnnme := 'LN '; fntyp := fln end; with funct[ 8] do begin fnnme := 'ODD '; fntyp := fodd end; with funct[ 9] do begin fnnme := 'ORD '; fntyp := ford end; with funct[10] do begin fnnme := 'ROUND '; fntyp := frou end; with funct[11] do begin fnnme := 'SIN '; fntyp := fsin end; with funct[12] do begin fnnme := 'SQR '; fntyp := fsqr end; with funct[13] do begin fnnme := 'STRINGOF '; fntyp := fstr end; with funct[14] do begin fnnme := 'TRUNC '; fntyp := ftru end; line := 0 (*last line number of listing*); pline := 1 (* next not last, pascal line number*); rewrite(psource,OutFileName); rcopt := defrc; prcopt:= defprc; listopt := deflist; expropt := defexpr (* parse const expressions *); outpos := 0 (* last output position used*); lastlex := lexeof (* last token type output *); nerrors := 0; index := 0; confl := [lexalpha, lexreal, lexint, lexand, lexor, lexnot, lexmin, lexmax, lexdiv, lexmod, lexbeg, lexcas, lexend, lexrec, lexfun, lexproc, lexcon, lextpe, lexvar]; linectr := pagesize (* force newpage on listing*); ftop := -1 (* no open files *); open (inname); fstack[0].fname := inlname end (*initalize*); (***********) (* need - need 1 lines: start new page if necessary*) (***********) PROCEDURE need (* l:pgrng*); begin if (linectr + l) > pagesize then begin linectr := l; newpg end else linectr := linectr + l end (*need*); (**********) (* newpg - skip to a new page and print the heading*) (**********) PROCEDURE newpg; begin (****writeln(newpage, title1, title1a, dte: 9, title1b, tme: 9); writeln(double, title2); writeln(space, title3); write(space, title4); writeln(title5,title6) *****)end (*newpg*); (* newpg *) (**********) (* open - open an included file *) (**********) PROCEDURE open (* name : alfa *); var f: flrng; begin over(ftop, maxfiles); fstack[ftop + 1].fname := name; f := 0; WHILE fstack[f].fname <> name do f := f + 1; if f <= ftop then error(eropen) else begin ftop := ftop + 1; with fstack[ftop] do begin fname := name; (* Open an input file here ! *) reset(ffile,fname); fline := 0; last := 0; next := 1; inline[next] := NewLine; mtop := 0; getch end end end(*open*); (**********) (*over - abort on overflow*) (**********) PROCEDURE over (* i:integer; maxval:integer*); begin if i >= maxval then BEGIN error(erover); goto 1 end end (* over*); (**********) (*parse - parse the input program*) (**********) PROCEDURE parse (* top:crng; tok:lex*); begin getkey; WHILE not (lextyp in [lexeof, lexend, lexfwd]) do if lextyp in [lexrec, lexfun, lexproc, lexcon, lexmcon, lexbeg, lexcas] then case lextyp of lexbeg: begin puttok; if tok in [lexproc, lexfun] then begin tok := lexbeg; getkey end else parse(ctop, lexbeg) end; lexcas: begin puttok; if tok = lexrec then getkey else parse(ctop, lexcas) end; lexcon: begin puttok; if expropt then parsecon else getkey end; lexfun: begin puttok; scanheader; parse(ctop, lexfun) end; lexmcon: parsemcon; lexproc: begin puttok; scanheader; parse(ctop, lexproc) end; lexrec: begin puttok; parse(ctop, lextyp) end; end (*case*) else begin puttok; getkey end; puttok; if (lextyp = lexeof) and (tok <> lexeof) then begin error(erparseof); goto 1 end else if (lextyp = lexend) and not (tok in [lexbeg, lexcas, lexrec]) then error(erparsend) else if (lextyp = lexfwd) and not (tok in [lexproc, lexfun]) then error(erparsfwd); if lextyp <> lexeof then getkey; ctop := top; cvalid := top end (*parse*) ; (**********) (*parsecon - mparse a constant declaration with expression*) (***********) PROCEDURE parsecon; var savtyp : lex; savstr: strng; savlen: lnrng; svalid:boolean; consnam: alfa; begin getkey; WHILE lextyp = lexalpha do begin puttok; over(ctop, maxcons); ctop := ctop + 1; pack(lexstr, 1, consnam); getkey; if lextyp <> lexeq then begin error(erparscon); ctab[ctop].ctyp := terr; flush; getkey end else begin puttok; getkey; WHILE ch = blank do getch; if (ch = semi ) and (lextyp in [lexint, lexreal, lexother]) then begin savstr := lexstr; savlen := lexlen; savtyp := lextyp; svalid := true end else svalid := false; expression; if(lextyp <> lexsemi) and (not typeis([terr])) then begin experror(erpconsyn); ctab[ctop].ctyp := terr end; if ctab[ctop].ctyp <> terr then begin if svalid then begin lexstr := savstr; lextyp := savtyp; lexlen := savlen end else convrt; puttok; lextyp := lexsemi; lexstr[1] := semi; lexlen := 1; puttok; ctab[ctop].cname := consnam; cvalid := ctop end else begin lexstr[1] := zero; lexstr[2] := semi; lextyp := lexst; lexlen := 2; puttok end end; if ctab[ctop].ctyp in [terr, tot] then ctop := ctop - 1; getkey end end (*parsecon*); (**********) (* parsemcon - parse an internal constant declaration with expression*) (**********) PROCEDURE parsemcon; var consnam : alfa; begin getkey; WHILE lextyp = lexalpha do begin over(ctop, maxcons); ctop := ctop + 1; pack(lexstr, 1, consnam); getkey; if lextyp <> lexeq then begin error(erparsmcon); ctab[ctop].ctyp := terr; flush; getkey end else begin getkey; WHILE ch = blank do getch; expression; if (lextyp <> lexsemi) and (not typeis([terr])) then begin experror(ermconsyn); ctab[ctop].ctyp := terr end; if ctab[ctop].ctyp <> terr then begin ctab [ctop].cname := consnam; cvalid := ctop end end; if ctab [ctop].ctyp in [terr,tot] then ctop := ctop -1; getkey end end (* parsemcon*); (**********) (* pushback - push character back onto input*) (**********) PROCEDURE pushback; begin if mtop >0 then with mstack [mtop] do mnext := mnext -1 else next := next -1 end (* pushback*); (**********) (*puttok -put out a token for pascal using cols 1-prc*) (**********) PROCEDURE puttok; var i: lnrng; begin if(lastlex in confl) and (lextyp in confl) then begin write(psource, blank) (* space needed between tokens*); outpos := outpos + 1 end; if lextyp = lexeof then begin writeln(psource); outpos := 0 end else begin if (outpos + lexlen ) > prcopt then begin pline := pline + 1; writeln(psource); outpos := 0; if lexlen> prcopt then begin error(erputtok); lexlen := prcopt end end; for i := 1 to lexlen do write(psource , lexstr[i]); outpos := outpos + lexlen; lastlex := lextyp end end (* puttok *); (*********) (*relate- parse subexpression with rel. ops*) (***********) procedure relate; var op:lex; i:integer; r:real; c1, c2:csrng; begin arith; WHILE (lextyp in [lexlt .. lexne]) and (not typeis([terr])) do begin over(ctop, maxcons); ctop := ctop + 1; op := lextyp; getkey; arith; if typesmatch then with ctab[ctop - 1] do case ctyp of tin: begin i := ci; ctyp := tbl; case op of lexlt: cb := i < ctab[ctop].ci; lexle:cb := i <=ctab[ctop].ci; lexeq:cb := i = ctab[ctop].ci; lexge:cb := i>= ctab[ctop].ci; lexgt:cb := i > ctab[ctop].ci; lexne:cb := i <> ctab[ctop].ci end (*case*) end; tre: begin r:= cr; ctyp := tbl; case op of lexlt:cb := r < ctab[ctop].cr; lexle:cb := r <= ctab[ctop].cr; lexeq:cb := r = ctab[ctop].cr; lexge:cb := r >= ctab[ctop].cr; lexgt:cb := r > ctab[ctop].cr; lexne:cb := r <> ctab[ctop].cr; end (*case*) end; tbl: case op of lexlt: cb := cb < ctab [ctop].cb; lexle:cb := cb <= ctab[ctop].cb; lexeq:cb := cb = ctab[ctop].cb; lexge:cb := cb >= ctab[ctop].cb; lexgt:cb := cb > ctab[ctop].cb; lexne:cb := cb <> ctab[ctop].cb; end; tot: begin experror(errelatyp); ctyp := terr end; tch: begin c1 := cfirst; c2 := ctab[ctop].cfirst; i := 1; WHILE (i = cstr[c2]; lexgt:cb := cstr[c1] > cstr[c2]; lexne:cb := cstr[c1] <> cstr[c2] end (*case*) end end (* case*) else if ctab[ctop].ctyp <> terr then begin experror(errelconf); ctab[ctop].ctyp := terr end; ctop := ctop -1 end end (*relate*); (**********) (*scanheader - scan PROCEDURE or FUNCTION heading*) (**********) PROCEDURE scanheader; var ctr:integer; begin getkey (* get name*); puttok (* get name*); getkey (* get paren if parameters*); if lextyp <> lexlparen then puttok else begin ctr := 1; puttok; repeat getkey; if lextyp = lexlparen then ctr := ctr + 1; if lextyp = lexrparen then ctr := ctr - 1; puttok until ctr = 0 end end (* scanheader*); (**********) (* term- process multiplication ops in expression*) (**********) PROCEDURE term; var op:lex; begin factor; if(lextyp in [lexand .. lexmod]) and ( not typeis([terr])) then if (typeis([tbl]) and (lextyp = lexand)) or ( typeis ([ tre]) and ( lextyp in [lexmult .. lexmax])) or (typeis([tin]) and (lextyp in [lexmult .. lexmod])) then WHILE lextyp in [ lexand .. lexmod] do begin ctop := ctop + 1; op := lextyp; getkey; factor; with ctab[ctop-1] do if (op = lexand) and (ctyp = tbl) then cb := cb and ctab[ctop].cb else if (op in [lexdiv .. lexmod]) and (ctyp = tin) then case op of lexdiv : ci := ci div ctab[ctop].ci; lexmod : ci := ci mod ctab[ctop].ci end (* case*) else if (op in [lexmult .. lexmax ]) and typeis([tin,tre]) then begin if (ctyp = tin) and typeis([tin]) and (op <> lexdvd) then case op of lexmult: ci := ci * ctab[ctop].ci; lexmin: if ctab[ctop].ci < ci then ci := ctab[ctop].ci; lexmax: if ctab[ctop].ci > ci then ci := ctab[ctop].ci end (* case*) else begin forcereal; case op of lexmult: cr := cr * ctab[ctop].cr; lexdvd: cr := cr / ctab[ctop].cr; lexmin: if ctab[ctop].cr < cr then cr := ctab[ctop].cr; lexmax: if ctab[ctop].cr > cr then cr := ctab[ctop].cr end (* case*) end end else if ctab[ctop].ctyp <> terr then experror(ertermtyp); ctop := ctop -1 end else error(ertermtyp) end (* term*); (**********) (* terminate - print statistics and close files*) (**********) PROCEDURE terminate; var ratio : real (* lines/sec ratio *); begin if outpos > 0 then writeln(psource); if nerrors > 0 then begin need (2); writeln(double, '---> there were ', nerrors: 1, ' errors detected by map'); end; tottme := 0 - timein; (* ifd *) IF tottme = 0 then ratio := 0.0 else ratio := 1000 * line / tottme; need(2); writeln(double, '---> end run: ', line:5, ' input lines,',pline:6, ' output lines'); end (* terminate*); (***********) (*timedate- get time and ate and store in cstr*) (***********) PROCEDURE timedate; begin(* get time and date from system and make*) (*cstr[1 .. 6] mm/dd/yyhh:mm:ss *) (* *) (* global variables tme and dte should be *) (* set to time and date for the listing *) (* temporary time and date *) (*unpack ('MM/DD/YYHH:MM:SS ', cstr, 1);*) tme := '*TIME* '; dte := '81-06-03 ' end (* timedate*); (***********) (* typeis - return true if type of top of stack is in set *) (**********) FUNCTION typeis (* :boolean*); begin typeis := ctab[ctop].ctyp in c end (* typeis*); (***********) (* typesmatch - return true if types of top operands compatible*) (**********) FUNCTION typesmatch (*: boolean*); begin typesmatch := false; with ctab[ctop - 1] do if ctyp = ctab[ctop].ctyp then if ctyp <> tch then typesmatch := true else if clen = ctab[ctop].clen then typesmatch := true end (* typesmatch*); (**********) (*variable- recognize variable in expression*) (**********) PROCEDURE variable; var name:alfa; found:boolean; fun : fns; begin if not(lextyp in [lexalpha, lexint, lexreal, lexst]) then begin experror(ervalexp); ctab[ctop].ctyp := terr end else case lextyp of lexint: begin convrti; getkey end; lexreal: begin convrtr; getkey end; lexst: begin convrts; getkey end; lexalpha: begin pack(lexstr, 1, name); getkey; found:= false; if lextyp <> lexlparen then begin findcon(name, found); if not found then with ctab[ctop] do begin ctyp := tot; co := name end end else begin flookup(name, fun, found) (* FUNCTION call*); if not found then experror( ervarfnct) else begin getkey; expression; if lextyp <> lexrparen then experror(ervarrpar) else begin getkey; evalfns(fun) end end end end end(* case*) end (* variable*); begin (* main *) initialize; parse(ctop, lexeof); 1:terminate end.