program micro2 (input, output, codefile); (*--------------------------------------------------------------* * main program * *---------------------------------------------------------------*) const (*----------------parser constants------------------* * maxproductions - number of productions * * maxsymbols - number of terminals and nonterminals * * maxtokens - number of tokens * * maxsemaction - number of semantic actions * * pstacksize - maximum depth of the parse stack * * lenofptrace - number of characters in longest term* * or nonterminal in the grammar -- * * used in printing the parse trace * *---------------------------------------------------*) maxproductions = 150; maxsymbols = 128; maxtokens = 64; maxnontokens = 64 (* maxsymbols - maxtokens *) ; maxrhssymbols = 12; maxsemaction = 25; pstacksize = 75; (* arbitrary *) lenofptrace = 18; (* token values *) notoken = 0; eofnum = 1; idnum = 2; realnum = 3; beginnum = 4; endnum = 5; ifnum = 6; thennum = 7; readnum = 8; writenum = 9; assignnum = 10; equalopnum = 11; plusopnum = 12; minusopnum = 13; timesopnum = 14; divideopnum = 15; commanum = 16; seminum = 17; lfparennum = 18; rtparennum = 19; (*---------macc-2 machine organization constants----------* * maxreg - number of largest register * * maxoffset - maximum offset from register * * constbasereg - register to be used as the base of the * * constant area segment of memory * * varbasereg - base of variable area segment * *---------------------------------------------------------*) maxreg = 15; maxoffset = 2000; constbasereg = 14; varbasereg = 15; (*----------------miscellaneous constants--------------* * blank - the blank character * * maxreallen - maximum number of digits in a real * * semstacksize - size of the semantiic stack * * hashsize - size of the hash table * * maxlevel - maximum procedure nesting level * * maxbuf - size of input buffer * * lenidspace - size of id string table * * maxkeywordlen - length of longest keyword * *------------------------------------------------------*) blank = ' '; maxreallen = 15; semstacksize = 20; hashsize = 60; maxlevel = 1; maxbuf = 80; lenidspace = 500; maxkeywordlen = 5; (* mnemonics for addressing modes *) dreg = 0; (* direct register *) dmem = 1; (* direct memory *) indxd = 2; (* indexed *) immed = 3; (* immediate *) ireg = 4; (* indirect register *) imem = 5; (* indirect memory *) iindxd = 6; (* indirect indexed *) pcrel = 7; (* pc relative *) (* mnemonics for op codes used in code generation *) ineg = ' IN '; (* integer negation *) ia = ' IA '; (* integer addition *) is = ' IS '; (* integer subtraction *) im = ' IM '; (* integer multiplication *) id = ' ID '; (* integer division *) fneg = ' FN '; (* floating point negation *) fa = ' FA '; (* floating point addition *) fs = ' FS '; (* floating point subtraction *) fm = ' FM '; (* floating point multiplication *) fd = ' FD '; (* floating point division *) bi = ' BI '; (* bitwise inversion *) bo = ' BO '; (* bitwise or *) ba = ' BA '; (* bitwise and *) ic = ' IC '; (* integer comparison *) fc = ' FC '; (* floating point comparison *) jsr = ' JSR '; (* jump to subroutine *) bkt = ' BKT '; (* block transfer *) ld = ' LD '; (* load *) st = ' STO '; (* store *) lda = ' LDA '; (* load address *) flt = ' FLT '; (* integer to floating point *) fix = ' FIX '; (* floating point to integer *) jmp = ' JMP '; (* unconditional branch *) jlt = ' JLT '; (* branch if < *) jle = ' JLE '; (* <= *) jeq = ' JEQ '; (* = *) jne = ' JNE '; (* <> *) jge = ' JGE '; (* >= *) jgt = ' JGT '; (* > *) nop = ' NOP '; (* no-op *) srz = ' SRZ '; (* shift right, fill with 0 *) sro = ' SRO '; (* fill with 1 *) sre = ' SRE '; (* bit extend *) src = ' SRC '; (* circular *) srcz = ' SRCZ '; (* compound (doubleword) shift, fill with 0 *) srco = ' SRCO '; (* fill with 1 *) srce = ' SRCE '; (* bit extend *) srcc = ' SRCC '; (* circular *) slz = ' SLZ '; (* shift left, fill with 0 *) slo = ' SLO '; (* fill with 1 *) sle = ' SLE '; (* bit extend *) slc = ' SLC '; (* circular *) slcz = ' SLCZ '; (* compound (doubleword) shift, fill with 0 *) slco = ' SLCO '; (* fill with 1 *) slce = ' SLCE '; (* bit extend *) slcc = ' SLCC '; (* circular *) rdi = ' RDI '; (* read decimal integer *) rdf = ' RDF '; (* floating point value *) rdbd = ' RDBD '; (* binary digit *) rdbw = ' RDBW '; (* binary word *) rdod = ' RDOD '; (* octal digit *) rdow = ' RDOW '; (* octal word *) rdhd = ' RDHD '; (* hex digit *) rdhw = ' RDHW '; (* hex word *) rdch = ' RDCH '; (* ascii character *) rdst = ' RDST '; (* ascii string *) rdin = ' RDIN '; (* instruction *) wri = ' WRI '; (* write decimal integer *) wrf = ' WRF '; (* floating point value *) wrbd = ' WRBD '; (* binary digit *) wrbw = ' WRBW '; (* binary word *) wrod = ' WROD '; (* octal digit *) wrow = ' WROW '; (* octal word *) wrhd = ' WRHD '; (* hex digit *) wrhw = ' WRHW '; (* hex word *) wrch = ' WRCH '; (* ascii character *) wrst = ' WRST '; (* ascii string *) wrnl = ' WRNL '; (* newline *) trng = ' TRNG '; (* test that expression is within range *) halt = ' HALT '; (* stop execution *) skip = ' SKIP '; (* skip the next n bytes *) llabel = ' LABEL '; (* symbolic name for program count *) rreal = ' REAL '; (* define a real constant *) int = ' INT '; (* define a integer constant *) string = ' STRING '; (* define a string constant *) type (*--------------------------------------------------* * tokenrange - range of allowable tokens * * link - pointer to symbol pointer * * linklist - array of pointers for the hash table * * identype - id string descriptor * * (index into id string table) * * idrange - range of id string table * * tokenrec - pascal type record defining format of * * the token record * * setofterminals - set ranging over terminal values * * tablelink - pointers to next type * * rhsinfo - info about right-hand sides of prods * * ptracestr - info for use by parser trace * * datakind - allowable types of expressions * * regrange - range of allowable registers * * typekind - types of data allowed (currently * * only integer) * * offsetrange - range of offsets used in addresses * * address - pascal type defining set up for variable* * addressing * * typedesc - type descriptor record (currently only * * integer types used) * * idenrec - the hash table record * * entrytype - defines types in semantic stack * * stackentry - pascal record defining semantic stack* * symbolarraysize - size of array of grammar symbols* *---------------------------------------------------*) regrange = 0..maxreg; idrange = 1..lenidspace; identype = record startpos, length : idrange end; tokenrange = 0..maxtokens; tokenrec = record case number : tokenrange of idnum: (idstring : array [1..maxbuf] of char; length : 1..maxbuf); realnum: (realvalue : real) end; buffertype = array [1..maxbuf] of char; setofterminals = set of 1..maxtokens; symbolarraysize = 1 .. maxsymbols; tablelink = ^rhsinfo; rhsinfo = record setinputterms : setofterminals; lhstoreplace : 1..maxproductions; next : tablelink end; ptracestr = packed array [1..lenofptrace] of char; offsetrange = 0..maxoffset; address = record proclevel : 0..maxlevel; offset : offsetrange end; (* address record *) typekind = (realtype); typeptr = ^typedesc; typedesc = record case kind : typekind of realtype : () end; (* type record *) link = ^idenrec; idenrec = record next : link; idenvalue : identype; dataaddress : address; idtype : typeptr end; (* symbol table record *) linklist = array [1..hashsize] of link; entrytype = (ident, multop, relop, addop, expr); datakind = (constkind, varkind); stackentry = record (* semantic stack record *) case entrykind : entrytype of ident : (* entry for identifier *) (idententry : record symbollength : 1..maxbuf; symbolname : array [1..maxbuf] of char; end ); addop : (* entry for add op *) (addentry : record op : (plus,minus) end ); multop : (* entry for mult op *) (multentry : record op : (times,divide) end ); relop : (* entry for rel op *) (relentry : record op : (equal) end ); expr : (* entry for expression - primary,factor,term,variable *) (exprentry : record datatype : typeptr; case kind : datakind of constkind : (realvalue : real); varkind : (loc : address; indirect : boolean) end ); end; (* semantic stack entries *) var (*--------------------------------------------------* * tab - should be a constant, contains tab character* * savec - boolean used to save the lookahead * * endoffile - flag used to signal end of file * * has been found * * charpos - index used to store character in the * * inputbuffer * * token - variable name representing a token of * * type tokenrec * * inputbuffer - array used to store each line of * * input as it comes in, character by * * character, until the entire line is * * complete * * tokenbuffer - array used to store each token found* * c - the incoming character * * currently being looked at * * codefile - file where assembly code is placed for * * assembler which will generate the * * binary to be used by the interpretor * * base - array of links that will point to the * * linked lists * * listtoken - used to turn output on and off * * listcode - trace for listing code * * idspace - id string table * * nextidpos - used to indicate position for * * inserting next id into string table * * pstacktop, pstack, rhsreplace, parsetable * * - variables used by parser * * stacktrace - used to turn parse trace on and off * * parseaction - used to turn reduction trace on and * * tables - external file of parser tables * * off * * semstack - array representing semantic stack * * stacktop - used to tell position in semstack * * constindex - used to place constants in memory * * constoffset - used to index constants in memory * * constants - a table for holding constants which * * appear after all the code has been * * generated. * * varindex - used to place variables in memory * * labelindex - gives successive jump label numbers * * regindex - used to index into free/used reg array * * freereg - array used to determine which registers * * are free to be used * * pair - array used to determine when a register * * is part of a register pair in use * * realdesc - type pointer used for integer objects * * are being used * * actions, termsandnonterms - uses by parser trace * *---------------------------------------------------*) tab : char; savec : boolean; endoffile : boolean; charpos : integer; token : tokenrec; inputbuffer : packed array [1..maxbuf] of char; tokenbuffer : buffertype; c : char; listtoken : boolean; listcode : boolean; stacktrace, parseaction : boolean; (* control trace output from parser *) pstacktop : 1..pstacksize; pstack : array [1..pstacksize] of integer; rhsreplace : array [1..maxproductions, 1..maxrhssymbols] of -maxsemaction..maxsymbols; parsetable : array [1..maxnontokens] of tablelink; (*-------------------------------------------------------* numproductions - the number of prod in the grammar * numnonterms - the number of nonterms in the grammar * numtokens - the number of terminals in the grammar * numsemaction - the number of semactions in the grammar * *--------------------------------------------------------*) numproductions, numnonterms, numtokens, numsemaction : integer; tables,infile,outfile : text; (* parse tables *) production : integer; actions : array [1..maxsemaction] of ptracestr; termsandnonterms : array [symbolarraysize] of ptracestr; semstack : array [1..semstacksize] of stackentry; stacktop : 1..semstacksize; codefile : text; (* assembly language file generated *) base : linklist; idspace : array [idrange] of char; nextidpos : idrange; (* initialized to 1 *) realdesc : typeptr; constindex : offsetrange; constoffset : offsetrange; constants : array [offsetrange] of record offset : offsetrange; realvalue : real; end; varindex : offsetrange; labelindex : offsetrange; regindex : regrange; pair, freereg : array [regrange] of boolean; (* variables used in driver *) i, semaction, errorstatus : integer; tokenneeded : boolean; templink : tablelink; (****************************************************************) (* forward declarations of procedures called across modules *) (****************************************************************) procedure initgencode; forward; procedure initsemantics; forward; procedure initscanner; forward; procedure initidtable; forward; procedure initparser; forward; procedure semroutine (action : integer); forward; procedure gettoken (var token : tokenrec); forward; procedure writeerror; forward; procedure errorreport; forward; procedure parser; forward; procedure printvar (idstring : identype); forward; (*--------------------------------------------------------------* * hand coded scanner * *---------------------------------------------------------------*) procedure writeerror; (*--------------------------------------------------------------* * writeerror - * * Places a carat under the offending char and writes the * * error message. This is used by the scanner and other * * routines. * *---------------------------------------------------------------*) var errorindex : integer; begin for errorindex := 1 to charpos do write (blank); write ('^'); writeln (' ... error at this character, skipping to next token'); end; (* writeerror *) procedure gettoken; (*--------------------------------------------------------------* * gettoken - * * Procedure gettoken calls getchar, and upon receipt of a * * character calls the appropriate token procedure... unless * * the character is a blank, in which case it calls for * * another token. * *---------------------------------------------------------------*) var (* this variable is added to handle 'otherwise' in 'case' stmt *) nomatch : boolean; function getchar : char; (*--------------------------------------------------------------* * getchar - * * This is the routine which the remainder of the other * * procedures use to get characters for a token. It also * * handles the end of line, and the end of file conditions. * * When an end of line condition is 'called', the entire input* * line is printed. * *---------------------------------------------------------------*) var i : integer; begin if charpos >= maxbuf + 1 then if eof(infile) then begin token.number := eofnum; endoffile := true; getchar := blank end else begin charpos := 1; while ((not eoln(infile)) and (charpos <= maxbuf)) do begin read (infile,inputbuffer [charpos]); charpos := charpos + 1; end; readln(infile); for i := charpos to maxbuf do inputbuffer [i] := blank; write (' ':1); (* write line to listing *) for i := 1 to charpos - 1 do write (inputbuffer [i]:1); writeln; getchar := blank; charpos := 1 end else begin getchar := inputbuffer [charpos]; charpos := charpos + 1; end end; (* get char *) procedure readcomment; (*--------------------------------------------------------------* * readcomment - Finishes reading a comment to the end of line. * *---------------------------------------------------------------*) begin charpos := maxbuf + 1; tokenbuffer[2] := '-'; token.number := notoken; end; (* readcomment *) function keyword (idlgth : integer) : integer; (*--------------------------------------------------------------* * keyword - * * Takes an identifier and checks to see if it is a reserved * * word. A 'brute' force method is used. * *---------------------------------------------------------------*) var idbuffer : packed array [1..maxkeywordlen] of char; i : integer; begin idbuffer := ' '; if idlgth <= 5 then for i := 1 to idlgth do idbuffer[i] := tokenbuffer[i]; keyword := idnum; (* default result *) if idlgth in [2,3,4,5] then case idlgth of 2: begin if idbuffer = 'if ' then keyword := ifnum; end; (* length 2 case *) 3: begin if idbuffer = 'end ' then keyword := endnum; end; (* length 3 case *) 4: begin if idbuffer = 'read ' then keyword := readnum else if idbuffer = 'then ' then keyword := thennum; end; (* length 4 case *) 5: begin if idbuffer = 'begin' then keyword := beginnum else if idbuffer = 'write' then keyword := writenum; end; (* length 5 case *) end (* case statement *) end; (* function keyword *) procedure listatoken (lgth : integer); (*--------------------------------------------------------------* * listatoken - * * This procedure is used to list the token and its associated* * token number and value, if the listtoken trace is turned * * on. * *---------------------------------------------------------------*) var i : integer; begin write (' token : '); write (outfile,' token : '); for i := 1 to lgth do begin write (tokenbuffer[i]); write (outfile,tokenbuffer[i]); end; write (' token number : '); write ( token.number:1); write (outfile,' token number : '); write ( outfile,token.number:1); if token.number in [idnum,realnum] then case token.number of idnum: begin write (' id string : '); write (outfile,' id string : '); for i := 1 to token.length do begin write (token.idstring[i]); write (outfile,token.idstring[i]); end; end; realnum: begin write (' real value : '); write ( token.realvalue); write (outfile,' real value : '); write ( outfile,token.realvalue); end end; (* case and if *) writeln end; (* listatoken *) procedure identifier; (*--------------------------------------------------------------* * identifier - * * forms an identifier token by calling getchar until a non- * * digit or non-letter is encountered. Keyword is then called* * to check for a reserved word. If a reserved word is not * * found, the identifier value is stored as part of the token.* * If listtoken is true, the value and token number is * * printed. * *---------------------------------------------------------------*) var idlgth, i : integer; begin idlgth := 0; while ((c in ['a'..'z']) or (c in ['0'..'9']) and (idlgth < maxbuf)) do begin idlgth := idlgth + 1; tokenbuffer [idlgth] := c; c := getchar end; (* while *) if idlgth > 32 then begin; idlgth := 32; write (' ***** identifier '''); for i := 1 to idlgth do write (tokenbuffer[i]); writeln (''' is more than 32 characters long'); end; savec := true; token.number := keyword (idlgth); if token.number = idnum then begin for i := 1 to idlgth do token.idstring[i] := tokenbuffer[i]; token.length := idlgth; end (* if *); if listtoken then listatoken (idlgth) end; (* identifier *) procedure numbers; (*--------------------------------------------------------------* * numbers - * * Forms a real valued token by calling getchar until a * * non-digit is encountered, expecting it to be a '.' and * * then calling getchar until another non-digit is found. * * The ord function is used to convert the 'character' digit * * to a number. Each number is converted using the method * * discussed in grogono. Upon completion, the value is * * stored as part of the token. If listtoken is true, the * * value is printed. * *---------------------------------------------------------------*) const zero = '0'; var numlgth : integer; radix : real; result : real; begin numlgth := 1; radix := 10.0; result := 0; result := radix * result + ord(c) - ord(zero); c := getchar; while (c in ['0'..'9']) do begin if numlgth < maxreallen then begin (* calculate number *) result := radix * result + ord(c) - ord(zero); numlgth := numlgth + 1; tokenbuffer [numlgth] := c; c := getchar end (* if *) else c := getchar end; (* while *) radix := 0.1; if c <> '.' then writeerror else begin numlgth := numlgth + 1; c := getchar; tokenbuffer [numlgth] := '.'; if not (c in ['0'..'9']) then writeerror else while (c in ['0'..'9']) do begin if numlgth < maxreallen then begin (* calculate number *) result := result + radix * (ord(c) - ord(zero)); radix := radix / 10.0; numlgth := numlgth + 1; tokenbuffer [numlgth] := c; c := getchar end (* if *) else c := getchar end; (* while *) end; if numlgth >= maxreallen then writeerror; savec := true; token.number := realnum; token.realvalue := result; if listtoken then listatoken (numlgth); end; (* number *) procedure alttypes; (*--------------------------------------------------------------* * alttypes - * * Alternate types handles any characters that do not fit into* * the category of letters or digits, but are characters the * * scanner may consider as legal tokens. Upon completion the * * token, token number and operations value is printed, if * * listtoken is true. * *---------------------------------------------------------------*) var toklgth : integer; begin toklgth := 1; case c of '+': begin token.number := plusopnum; end; (* + case *) '-': begin c := getchar; if c = '-' then begin readcomment; toklgth := 2; end else begin token.number := minusopnum; savec := true end end; (* - case *) '*': begin token.number := timesopnum; end; (* * case *) '/': begin token.number := divideopnum; end; (* / case *) '=': begin token.number := equalopnum; end; (* = case *) ';': token.number := seminum; ',': token.number := commanum; ':': begin c := getchar; if c = '=' then begin token.number := assignnum; toklgth := toklgth + 1; tokenbuffer [toklgth] := c end else begin savec := true; writeerror; token.number := notoken (* ':' is an invalid token *) end (* if *) end; (* : case *) '(': token.number := lfparennum; ')': token.number := rtparennum; end; (* case statement *) if listtoken then listatoken (toklgth) end; (* altypes *) procedure compildirect; (*--------------------------------------------------------------* * compildirect - * * To use this, simply type the appropriate letters of the * * traces you want turned on, eg: @+t-c this procedure * * determines which of the compiler directives are to be used * * in the program. The ones currently recognized are: * * (t) listtoken - lists the tokens as they are formed * * (c) listcode - lists the code as it is generated (a final * * list is always generated) * * (s) stacktrace - parse stack dump * * (p) parseaction - parsing actions * * to use one of the above, the symbol '+' or '-' should * * follow the directive. * *---------------------------------------------------------------*) var i, j : integer; begin j := 1; c := getchar; while (c <> blank) and (c <> tab) do begin j := j + 1; tokenbuffer[j] := c; c := getchar end; savec := true; i := 2; (* skip the '@' *) while i < j do begin case tokenbuffer[i] of 'c' : listcode := (tokenbuffer [i+1] = '+'); 'p' : parseaction := (tokenbuffer [i+1] = '+'); 's' : stacktrace := (tokenbuffer[i+1] = '+'); 't' : listtoken := (tokenbuffer [i+1] = '+'); end; (* case *) i := i + 2 end (* while *) end; (* compile directives *) (* body of gettoken follows --------------------------------------------*) begin repeat if savec then savec := false else c := getchar; while (((c = blank) or (c = tab)) and (not endoffile)) do c := getchar; if not endoffile then begin tokenbuffer [1] := c; nomatch := true; case c 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 identifier; nomatch := false; end; '1','2','3','4','5','6','7','8','9','0': begin numbers; nomatch := false; end; '+', '-', '(', ')', ',', '*', '/', '=', ':', ';': begin alttypes; nomatch := false; end; '@': begin compildirect; token.number := notoken; nomatch := false; end; end; (* case *) if nomatch then begin writeerror; token.number := notoken end; end (* if not endoffile *) until token.number <> notoken end; (* gettoken *) procedure initscanner; (*--------------------------------------------------------------* * initscanner - initializes the scanner. * *---------------------------------------------------------------*) var i : integer; begin for i := 1 to maxbuf do inputbuffer [i] := ' '; charpos := maxbuf + 1; (* make getchar think it has seen an entire line *) c := ' '; (* global character c is initialized *) savec := false; tab := chr(9); end; (* initscanner *) (*--------------------------------------------------------------* * parser routines * *---------------------------------------------------------------*) procedure errorreport; (*--------------------------------------------------------------* * errorreport - * * this procedure writes out a message report of what went * * wrong during the parsing of the input string. * *---------------------------------------------------------------*) begin case errorstatus of 1 : writeln('0 the nonterminal on top of the parsestack does ', 'not have a production compatible with the input token'); 2 : writeln('0 the terminal on top of the parsestack does not match', ' the input token'); 3 : writeln('0 the end-of-file token was expected'); end; (* case *) writeln(codefile, halt); (* a preventative measure to ensure code halts *) end; (* errorreport *) procedure builddumparrays (lolimit, hilimit : integer; check : boolean); (*--------------------------------------------------------------* * builddumparrays - * * this procedure builds arrays from terminal, non-terminal, * * and semantic action symbols during the initialization * * phase, so if a dump of the parse stack is necessary, the * * symbol numbers on the parsestack will correspond to array * * indices and the appropriate alphabetic representation will * * be printed. The input comes from the latter part of the * * file containing the parse table input. This procedure is * * called twice by preparefordumptrace, once for the sem- * * actions array and once for the terminal and non-terminal * * array. * *---------------------------------------------------------------*) var i, k, j : integer; ch : char; buffer : ptracestr; begin for i := lolimit to hilimit do begin read (tables, j); read (tables, ch); while ch = ' ' do read (tables, ch); k := 1; while (ch <> ' ') and (not eoln(tables)) do begin buffer [k] := ch; k := k + 1; read (tables, ch) end; (* while *) while k <= lenofptrace do (* fill in buffer *) begin buffer [k] := ' '; k := k + 1 end; if check then actions [j] := buffer else termsandnonterms [j] := buffer; readln (tables) end; (* for *) end; (* builddumparrays *) procedure preparefordumptrace; (*--------------------------------------------------------------* * preparefordumptrace - * * This procedure calls builddumparrays twice to construct * * arrays to be used to dump the parse stack during dumpstack.* *---------------------------------------------------------------*) begin readln (tables); builddumparrays (1, numsemaction, true); builddumparrays (1, numnonterms + numtokens, false) end; (* preparefordumptrace *) procedure initparser; (*--------------------------------------------------------------* * initialize - initializes the parser tables * *---------------------------------------------------------------*) var terminal, lhside : integer; i, j, k, l : integer; tempbuff : array [1..maxbuf] of integer; tempptr, newstate : tablelink; begin readln (tables, numnonterms, numtokens, numsemaction, numproductions); (* following code reads in part of tables used to replace a lhs of a production with its rhs on the parsestack *) for i := 1 to numproductions do begin j := 1; read (tables, tempbuff [j]); while tempbuff [j] <> 1000 do (* 1000 is just an eoln marker *) begin j := j + 1; read (tables, tempbuff [j]) end; rhsreplace [i, j] := 0; (* in tables, a 0 indicates end of the symbols in the rhs *) l := 1; if j <> 1 then (* non-null production *) for k := j-1 downto 1 do begin rhsreplace [i, l] := tempbuff [k]; l := l + 1 end (* this for loop loads the array in reverse order so that when a part of the array is put on the parse stack it goes through the 2nd dimension in order and pushes num- bers on the stack, as encountered, until zero is found *) end; (* for 1 to # productions *) (* now want to build part of parse table to compare non-terminal on parsestack with input token to see which replacement to call in rhs-replace, if any *) for i := 1 to numnonterms do parsetable [i] := nil; (* the first record of each array entry will have a union of all the sets contained in the linked-list for that entry. this is done to facilitate checking for syntax errors before traversing the links for the correct production. there's no traversal if an error exists. *) read (tables, i); while i <> 0 do begin i := i - numtokens; read (tables, terminal); read (tables, lhside); if parsetable [i] = nil then begin new (newstate); newstate^.setinputterms := [terminal]; newstate^.lhstoreplace := 1; newstate^.next := nil; parsetable [i] := newstate end else parsetable [i]^.setinputterms := [terminal] + parsetable [i]^.setinputterms; tempptr := parsetable [i]; while (tempptr^.next <> nil) and (tempptr^.lhstoreplace <> lhside) do tempptr := tempptr^.next; (* several different tokens will cause the same production; hence the use of sets *) if (tempptr^.next = nil) and (tempptr^.lhstoreplace <> lhside) then begin (* add new link *) new (newstate); newstate^.next := nil; newstate^.lhstoreplace := lhside; newstate^.setinputterms := [terminal]; tempptr^.next := newstate end else tempptr^.setinputterms := [terminal] + tempptr^.setinputterms; read (tables, i) end; (* while i <> 0 *) preparefordumptrace; pstack [1] := eofnum; pstack [2] := numtokens + 2; pstacktop := 2; end (* initialize *); procedure dumpstack; (*--------------------------------------------------------------* * dumpstack - * * This procedure is called when stktrace is turned on. It * * dumps out the symbols that are on the parsestack, i.e. * * their names. * *---------------------------------------------------------------*) var temp, tempptr, count : integer; begin tempptr := pstacktop; count := 0; writeln; while tempptr <> 0 do begin temp := pstack [tempptr]; if count = 6 then begin writeln; count := 0 end; if temp < 0 then (* semaction *) write (' [', actions [-temp], ']') else if temp < numtokens + 1 then (* terminal *) write (' ', termsandnonterms [temp]) else (* non-terminal *) write (' <', termsandnonterms [temp], '>'); count := count + 1; tempptr := tempptr - 1 end; (* while *) writeln end; (* dumpstack *) Procedure Openfiles(var infile, outfile, tables:text); (* this procedure opens the input source file for the parser and it asks the user for the name of the source file and the name of the output file for the parser *) Var file1, file2: packed array [1..80] of char; begin (*Openfiles*) write('Enter the name of the source code file ==> '); readln(file1); write('Enter the name of the parser output file => '); readln(file2); reset(infile, file1); rewrite(outfile, file2); write('Enter the name of the grammar table file ==>'); readln(file1); reset(tables, file1); end; (*Openfiles*) begin (* parse driver *) (*--------------------------------------------------------------* * parse driver - * * This is the main program that drives the other procedures. * * All variables are initialized. While the end of the file * * has not been detected, gettoken is called. Once a token * * has been recognized, it is used by the parser. When * * another token is needed and the token is an identifier, * * integer expression, or an operator sign, it is placed * * on the semantic stack. If the semaction number is less * * than 0 the semantic routines are called. Upon * * completion, the driver writes the 'memory' to a file * * (codefile), for use by the interpreter. * * ---------------------------------------------------------------*) Openfiles(infile, outfile, tables); initparser; initscanner; initidtable; nextidpos := 1; parseaction := true; listcode := true; stacktrace := true; listtoken := true; errorstatus := 0; tokenneeded := true; semaction := 0; endoffile := false; production := 0; (* the code which follows drives the compilation *) repeat if tokenneeded then gettoken (token); parser until (errorstatus <> 0) (* parser error *) or (semaction = 1) (* complete program parsed *); if errorstatus = 0 then begin writeln; writeln (' '); end else begin errorreport; rewrite(codefile) end; close(codefile); close(tables);close(infile);close(outfile); end. (* parse driver *)