Power-Programmierung

home *** CD-ROM | disk | FTP | other *** search

/ Power-Programmierung / CD1.mdf / forth / dada / dada.pas < prev next >

Wrap

Pascal/Delphi Source File | 1994-05-05 | 48.6 KB | 1,008 lines

{ PROGRAM: DADA.PAS AUTHOR: Brian Hayes DATE BEGUN: September 17, 1985 FOR COMPILATION BY: Turbo Pascal v 3.0 } { DESCRIPTION: A compiler for a toy language called Dada, which adopts much of the vocabulary of Pascal but lacks many of its features, most notably functions, local variables, defined types and a facility for passing parameters to procedures. The "object code" produced by the compiler consists of Forth words. For additional detail see the comments below and the accompanying file DADA.DOC. This program is intended for demonstration purposes only. It has been compiled and casually tested, but it is certainly not guaranteed to be error-free. Testing was done with version 3.0 of Borland International's Turbo Pascal, but I have tried to avoid features peculiar to Borland's implementation. Adaptation to other Pascal compilers should be easy. The compatibility of the object code with various Forth systems is more difficult to assess. See the comments on the code gen- erator and DADA.DOC Note 7. } { COMPILER DIRECTIVES (Valid for Turbo Pascal only) } (* {$B+} {B+ assigns StdIn/StdOut to CON, B- to TRM; default +} {$C+} {C+ allows ^C and ^S during Read/ReadLn; default +} {$I+} {I+ enables automatic I/O error checking; default +} {$R-} {R+ enables run-time checking of index bounds; default -} {$V-} {V+ requires string parameters to match declared length; default +} {$U-} {U+ allows ^C interrupt at any time; default -} {$D+} {D+ unbuffers I/O for devices; default +} {$F16} {Fn sets maximum number of files open simultaneously; default 16} {$K+} {K+ enables checking for stack-heap collision; default +} *) program Dada; USES Crt; {*****************************************************************************} {***************** GLOBAL CONSTANTS *****************} {*****************************************************************************} const MaxIdentLen = 31; { only the first 31 chars saved } MaxKeyLen = 9; { longest keyword } MaxErrorLen = 35; { longest error message } {*****************************************************************************} {***************** GLOBAL TYPES *****************} {*****************************************************************************} type IdentStr = string[MaxIdentLen]; KeyStr = string[MaxKeyLen]; ErrorStr = string[MaxErrorLen]; ForthStr = string[64]; { for Forth output; see procedure Gen } { ErrCode identifies error messages in the array ErrorList; see DADA.DOC Note 1. } ErrCode = (Disk, QChar, XPgm, XIdent, XVar, XInt, XBool, XColon, XType, XSemi, XBegin, XSemEnd, XThen, XDo, XAssgn, XStmt, DupDec, UnDec, Match, XFactor, XParen, XDot, UnXEOF); { TokCode lists all symbols that can possibly be returned by the scanner. Null is a placeholder that can appear in a few fields of symbol-table entries. } TokCode = (Null, Ident, Number, PgmSym, VarSym, ProcSym, BeginSym, EndSym, IfSym, ThenSym, ElseSym, WhileSym, DoSym, IntSym, BoolSym, TrueSym, FalseSym, EQ, GT, GE, NE, LE, LT, Plus, Minus, OrSym, Times, Divide, AndSym, ModSym, NotSym, AssignOp, Colon, LeftParen, RightParen, Semi, Dot, ReadSym, WriteSym); TokenRec = record { Definition of the mailbox where the scanner } Name : IdentStr; { leaves dope on the current token and where } Code : TokCode; { the parser picks it up. } end; SymClass = (Variable, Proc); { Every symbol must be one or the other. } SymPtr = ^Symbol; { Points to a symbol-table entry. } { Format of a symbol-table entry. See DADA.DOC Note 2 } Symbol = record Name : IdentStr; { UpCase string of name as read } Class : SymClass; { either Variable or Proc } VarType : TokCode; { either IntSym or BoolSym } Scope : integer; { zero for global, then 1,2,3...} Next : SymPtr; { pointer to next table entry } end; { The output buffer represents a Forth "screen" of 16 lines by 64 characters. } OutBufLines = 1..16; OutBufChars = 1..64; OutBufArray = array[OutBufLines] of array[OutBufChars] of char; {*****************************************************************************} {***************** GLOBAL VARIABLES *****************} {*****************************************************************************} var OutLine : OutBufLines; { Declared global becaused called by } OutPoint : OutBufChars; { both InitOutBuf and Gen. } OutBuf : OutBufArray; InFile : Text; { source code } OutFile : file of OutBufArray; { object code } TK : TokenRec; { where dope on the current token is stashed } CH : char; { current scanner input } LineCount : integer; { number of lines in source text } TypeSet : set of TokCode; { sets defined for convenience } TFset : set of TokCode; { in the parsing logic } RelOpSet : set of TokCode; AddOpSet : set of TokCode; MultOpSet : set of TokCode; FirstSym : SymPtr; { link to the start of the symbol-table chain } CurrentScope : integer; { nesting depth of procedures } Keywords : array[TokCode] of KeyStr; ErrorList : array[ErrCode] of ErrorStr; {*****************************************************************************} {*****************************************************************************} {***************** *****************} {***************** UTILITY ROUTINES *****************} {***************** *****************} {*****************************************************************************} {*****************************************************************************} { The Keywords and ErrorList arrays must be initialized when the program is started. So must the five small sets used to form symbols into groups. } procedure InitKeywords; begin Keywords[PgmSym] := 'PROGRAM'; Keywords[VarSym] := 'VAR'; Keywords[IntSym] := 'INTEGER'; Keywords[BoolSym] := 'BOOLEAN'; Keywords[BeginSym] := 'BEGIN'; Keywords[EndSym] := 'END'; Keywords[IfSym] := 'IF'; Keywords[ThenSym] := 'THEN'; Keywords[ElseSym] := 'ELSE'; Keywords[WhileSym] := 'WHILE'; Keywords[DoSym] := 'DO'; Keywords[NotSym] := 'NOT'; Keywords[OrSym] := 'OR'; Keywords[AndSym] := 'AND'; Keywords[ModSym] := 'MOD'; Keywords[ProcSym] := 'PROCEDURE'; Keywords[TrueSym] := 'TRUE'; Keywords[FalseSym] := 'FALSE'; Keywords[ReadSym] := 'READLN'; Keywords[WriteSym] := 'WRITELN'; end; procedure InitErrorList; begin ErrorList[Disk ] := 'Trouble with file or disk.'; ErrorList[QChar ] := 'Unrecognized character in input.'; ErrorList[Xpgm ] := 'No program header.'; ErrorList[XIdent ] := 'Identifier expected.'; ErrorList[XVar ] := 'Variable expected.'; ErrorList[XInt ] := 'Integer value expected.'; ErrorList[XBool ] := 'Boolean value expected.'; ErrorList[XColon ] := 'Colon expected.'; ErrorList[XType ] := 'Type designator expected.'; ErrorList[XSemi ] := 'Semicolon expected.'; ErrorList[XBegin ] := '"Begin" expected.'; ErrorList[XSemEnd] := 'Semicolon or "end" expected.'; ErrorList[XThen ] := '"Then" expected.'; ErrorList[XDo ] := '"Do" expected.'; ErrorList[XAssgn ] := 'Assignment statement expected.'; ErrorList[XStmt ] := 'Statement expected.'; ErrorList[DupDec ] := 'Duplicate declaration.'; ErrorList[UnDec ] := 'Undeclared variable or procedure.'; ErrorList[Match ] := 'Type mismatch.'; ErrorList[XFactor] := 'Factor expected.'; ErrorList[XParen ] := 'Closing parenthesis expected.'; ErrorList[XDot ] := 'Period expected.'; ErrorList[UnXEOF ] := 'Unexpected end of file.'; end; procedure InitSets; begin TypeSet := [IntSym, BoolSym]; TFset := [TrueSym, FalseSym]; RelOpSet := [EQ..LT]; AddOpSet := [Plus..OrSym]; MultOpSet := [Times..ModSym]; end; { The error-handling given here is minimal. Procedure Error is handed a code and prints the corresponding string. The only information supplied on what might have caused the error is a line number. The program then halts. See DADA.DOC Note 3. } procedure Error(Problem : ErrCode); begin WriteLn('ERROR IN LINE ',LineCount,': ',ErrorList[Problem]); WriteLn; WriteLn('Compilation aborted.'); Halt; end; procedure SayHello; begin ClrScr; WriteLn; WriteLn; WriteLn('DADA: A demonstration compiler'); WriteLn; WriteLn('This program is described in Computer Language, December, 1985'); WriteLn; WriteLn; WriteLn; end; { The file handling is as rudimentary as the error routine. Further- more, the version given here depends on features peculiar to Turbo Pascal. See DADA.DOC Note 4. } procedure OpenFiles; var FileOK : boolean; InFileName : string[14]; OutFileName : string[14]; begin Write('Enter the name of the file to be compiled: '); ReadLn(InFileName); Assign(InFile, InFileName); {$I-} Reset(InFile); {$I+} FileOK := (IoResult = 0); if not FileOK then Error(Disk); WriteLn; Write('Enter the name of the output file: '); ReadLn(OutFileName); Assign(OutFile, OutFileName); {$I-} ReWrite(OutFile); {$I+}; FileOK := (IoResult = 0); if not FileOK then Error(Disk); WriteLn; WriteLn; end; procedure CloseFiles; begin Close(InFile); Close(OutFile); end; {*****************************************************************************} {*****************************************************************************} {***************** *****************} {***************** LEXICAL ANALYZER *****************} {***************** *****************} {*****************************************************************************} {*****************************************************************************} { Procedure GetTK constitutes the scanner, or lexical analyzer. It calls on GetCH to read the next character from the input stream and uses Recognize to set up the two global-variable fields TK.Code and TK.Name. The main routine first strips out all com- ments and whitespace characters and then enters a state deter- mined by the first character of the remaining input. Each state corresponds to one clause of the case statement. Note that GetCH converts all alphabetic characters to upper case, so that the compiler in insensitive to case. Two errors can be issued by the scanner. Error(QChar) is called if a character outside the recog nized set appears in the input (except in comments). Error(UnXEOF) is reported if the scanner encounters end-of-file. Since GetTK is not called after the final period marking the end of a pro- gram, the scanner should never read the end of the file. NOTE: Each time the scanner is called, it goes to work on the character already in variable CH, not on the next character from the stream. When GetTK exits, CH holds the first char- acter beyond the token returned. In other words, the file pointer is pre-incremented. See also DADA.DOC Note 5. } procedure GetTK; var I : TokCode; { used in a FOR loop to check for keywords } procedure GetCH; begin if Eof(InFile) then CH := #0 else Read(InFile, CH); { get next if possible} CH := Upcase(CH); { make case immaterial} if CH = #13 then LineCount := LineCount + 1; { count for Error } end; procedure Recognize(Tok: TokCode); { Called once for each character } begin { scanned, adding it to the string } TK.Code := Tok; { in TK.Name and recording the } TK.Name := Concat(TK.Name,CH); { current analysis in TK.Code. Note} GetCH; { that TK.Code is not actually } end; { valid until GetTK returns. } { The first section of GetTK strips out comments and the whitespace characters #9 (tab), #10 (line feed), #12 (form feed), #13 (carriage return) and $32 (space). For comments any characters following a left brace are ignored up to the first right brace. Note that this means comments cannot be nested: Any number of opening braces will be canceled by the first closing brace. The nested while loops are needed because comments and whitespace can be interspersed in any sequence. } begin { GetTK } while (CH in ['{',#9,#10,#12,#13,#32]) do { loop while comment, space } begin if CH = '{' then repeat GetCH until CH = '}'; { eat up the comment } GetCH; { toss out the right brace } while (CH in [#9,#10,#12,#13,#32]) do GetCH; { eat the whitespace } end; TK.Name := ''; { reset the identifier string to null } case CH of { look at the current char from stream} 'A'..'Z' : begin { Ident or keyword} while (CH in ['A'..'Z','0'..'9']) do { add chars to the} Recognize(Ident); { TK.Name string } for I := PgmSym to WriteSym do { An Ident unless } if Keywords[I] = TK.Name then TK.Code := I; { listed here } end; '0'..'9' : while (CH in ['0'..'9']) do Recognize(Number); { numeric literal} '>' : begin Recognize(GT); { With two-symbol oper- } if CH = '=' then Recognize(GE); { ators, start by assum-} end; { ing the one-symbol } '<' : begin { form and then revise } Recognize(LT); { the verdict if the } if CH = '>' then Recognize(NE) { second character is } else if CH = '=' then Recognize(LE) { found. } end; ':' : begin Recognize(Colon); if CH = '=' then Recognize(AssignOp); end; '=' : Recognize(EQ); '+' : Recognize(Plus); '-' : Recognize(Minus); '*' : Recognize(Times); '/' : Recognize(Divide); '(' : Recognize(LeftParen); ')' : Recognize(RightParen); ';' : Recognize(Semi); '.' : Recognize(Dot); #0 : Error(UnXEOF); { Program has ended without a period } else Error(QChar); { Queer character; can't digest it } end; end; {*****************************************************************************} {*****************************************************************************} {***************** *****************} {***************** SYMBOL TABLE *****************} {***************** *****************} {*****************************************************************************} {*****************************************************************************} { The three routines Find, Declare and Blot manage the symbol table. The table is organized as a linked list in which FirstSym always points to the most recently added entry. The Next field points to the next-youngest entry, so that following the chain of Nexts ultimately leads to the first entry, which is always the declaration of the program header. Because all variables in Dada are global, the symbol table has a fixed, predictable structure: the program declaration is followed by variable declarations and then by procedure declarations. See DADA.DOC Note 6. } { Find is passed an identifier string and returns either a pointer to the corresponding symbol-table entry or nil if the identifier does not exist. It traverses the chain of entries beginning with FirstSym, and so the first matching entry will be found. } function Find(ID: IdentStr): SymPtr; var ThisSym : SymPtr; begin ThisSym := FirstSym; { start with the latest entry } while ((ID<>ThisSym^.Name) and { loop if no match and... } (ThisSym<>nil)) do { we're not at the end of list } ThisSym := ThisSym^.Next; { get next record } Find := ThisSym; { a match if there is one, or nil } end; { Declare installs both variable names and procedure names in the symbol table. ID is the name of the Identifier, as given in TK.Name; CL is either "Proc" or "Variable"; Kind is "IntSym" or "BoolSym" for variables, "Null" for procedures. } procedure Declare(ID: IdentStr; CL: SymClass; Kind: TokCode); var ThisSym : SymPtr; begin ThisSym := Find(ID); { See if it already exists } if ThisSym <> nil then Error(DupDec); { Call error & halt if it does } New(ThisSym); { Create a new record } ThisSym^.Next := FirstSym; { Swap pointers to put the... } FirstSym := ThisSym; { ...new record first in list } with FirstSym^ do begin Name := ID; { Plug in the values passed... } Class := CL; { ...as arguments... } VarType := Kind; Scope := CurrentScope; { ...and a value from a global } end; end; { Blot is called when the "end" of a block is reached and removes from the symbol table all names whose scope is confined to that block. The global variable CurrentScope is initialized to zero and incremented each time ParseBlock is called. Blot decrements CurrentScope and unlinks from the symbol table any entry whose Scope field is numerically greater than CurrentScope. } procedure Blot; var TrashSym : SymPtr; begin CurrentScope := CurrentScope - 1; { back to scope of next outer block} while FirstSym^.Scope > CurrentScope do { erase entries for closed block } begin TrashSym := FirstSym; { Give the pointer an alias } FirstSym := FirstSym^.Next; { Unlink the record } Dispose(TrashSym); { Free the allocated memory } end; end; {*****************************************************************************} {*****************************************************************************} {***************** *****************} {***************** CODE GENERATOR *****************} {***************** *****************} {*****************************************************************************} {*****************************************************************************} { The code generator is simple to the point of triviality, largely because the Forth virtual machine offers a very powerful assembly language. All address calculations, for instance, are done by the Forth interpreter. With a Forth system that accepts input as a sequence of CR/LF-delimited lines, the code generator could be reduced to a one-line procedure: WriteLn(OutFile,Forth). The routines given here produce Forth "screens," or blocks of 1,024 bytes filled out with blanks (ASCII #32). For more on this for- matting see DADA.DOC Note 7. The main procedure of the code generator is Gen, which is called by the various parsing routines; the argument is a string to be written to the output file. The string is actually appended to a buffer that holds 16 lines of 64 characters (the standard .SCR format). When a line exceeds 62 characters, a new line is started; when line 16 is reached, the continuation symbol "-->" is written and the buffer is flushed to the disk and then reset to all blanks. To make the generated code more readable, the symbol "|" is defined as a control character that forces Gen to start a new line. The parsing routines issue Gen('|') after each colon definition. InitOutBuf sets the 1,024 bytes of the output buffer to the ASCII blank character (#32) and resets the two array indices OutLine and OutPoint to 1, which corresponds to the upper left-hand corner of a Forth screen. The procedure is not made local to Gen because it is called from the main initializing routine at program startup. } procedure InitOutBuf; begin for OutLine := 1 to 16 do for OutPoint := 1 to 64 do OutBuf[Outline,OutPoint] := #32; OutLine := 1; OutPoint := 1; end; procedure Gen(Forth : ForthStr); var FileOK : boolean; I, TempPoint, TempLine : integer; { two temps for testing length } { WriteBuf, like OpenFiles, is written with a Turbo-specific error-checking method. It simply writes the accumulated buffer to the output file and, if there is no disk error, calls InitOutBuf to reinitialize the array. } procedure WriteBuf; begin {$I-} Write(OutFile,OutBuf); {$I+} FileOK := (IoResult = 0); if not FileOK then Error(Disk); InitOutBuf; end; { NewLine resets the character counter and tests the line count; if we are on line 15, the recursive call Gen('-->') flushes the buffer and starts a new screen. } procedure NewLine; begin OutPoint := 1; TempLine := OutLine + 1; if TempLine >= 15 then Gen('-->') else OutLine := TempLine; end; begin { Gen } if Forth = '|' then begin NewLine; exit; end; { force new line & leave } TempPoint := OutPoint + Length(Forth); { Temp avoids out-of-range } if TempPoint > 62 then NewLine; { 62 (not 64) to allow blanks} for I := 1 to Length(Forth) do begin OutBuf[OutLine,OutPoint] := Forth[I]; { copy the string into buffer} OutPoint := OutPoint + 1; end; OutPoint := OutPoint + 1; { allow one blank after code } if ((Forth = '-->') or (Forth = ';S')) then WriteBuf; end; { GenHeader creates a "run-time library" that precedes the object code for all Dada programs. Some Forth systems may need additional or different definitions here. The READ routine provides keyboard input of signed integers. It could readily be improved. } procedure GenHeader(PgmName : IdentStr); begin Gen('( Output of Dada compiler )'); Gen('|'); { Screen 0 comments } Gen(Concat('( To execute type: 1 LOAD ',PgmName,' )')); Gen(';S'); Gen('FORTH DEFINITIONS DECIMAL'); Gen('|'); Gen('1 CONSTANT TRUE '); { } Gen('0 CONSTANT FALSE'); { These synonyms will } Gen(': NEGATE MINUS ;'); Gen('|'); { not be needed by all } Gen(': NOT 0= ;'); { Forth systems; others } Gen(': <> = NOT ;'); { may be required. } Gen(': >= < NOT ;'); { } Gen(': <= > NOT ;'); Gen('|'); { } Gen(': READ KEY DUP 45 = IF TRUE SWAP EMIT KEY ELSE FALSE SWAP'); Gen('|'); Gen(' THEN 0 SWAP BEGIN DUP 13 = NOT WHILE DUP 48 < OVER'); Gen('|'); Gen(' 57 > OR IF DROP 7 EMIT ELSE DUP EMIT 48 - SWAP 10 * +'); Gen('|'); Gen(' THEN KEY REPEAT DROP SWAP IF NEGATE THEN SWAP ! ;'); Gen('|'); Gen(': WRITE @ . CR ;'); Gen('-->'); end; {*****************************************************************************} {*****************************************************************************} {***************** *****************} {***************** PARSER *****************} {***************** *****************} {*****************************************************************************} {*****************************************************************************} { ParseProgram and the routines nested under it constitute the main driver of DADA.PAS. The organization is outlined in DADA.DOC Note 8. Each routine calls on GetTK (the scanner). Statements haveing to do with parsing proper are interleaved with those for type checking and code generation. } procedure ParseProgram; var HoldID : IdentStr; { hangs onto the program name } { ParseVariables is called once by ParseProgram. If the current token is not "var," there are no variables in the program and the routine exits. Otherwise each declaration is checked for proper form and a statement "0 VARIABLE IDENT" is generated to allocate 16 bits of storage and record its address under the name IDENT in the Forth dictionary. } procedure ParseVariables; var HoldVar : IdentStr; begin if TK.Code = VarSym then { else no variables in entire program } begin GetTK; { eat the "var" token } repeat { loop for arbitrary number of variables } if TK.Code <> Ident then Error(XIdent); { format is "Ident: Type;" } HoldVar := TK.Name; GetTK; { hang onto identifier } if TK.Code <> Colon then Error(XColon); GetTK; if not (TK.Code in TypeSet) then Error(XType); { TypeSet=IntSym,BoolSym } Declare(HoldVar,Variable,TK.Code); GetTK; { install in symbol table} Gen(Concat('0 VARIABLE ',HoldVar)); Gen('|'); { gen code & new line } if TK.Code <> Semi then Error(XSemi); GetTK; { every decl. must have } until (TK.Code in [ProcSym,BeginSym]); { no more variables } end; end; procedure ParseBlock(Caller: IdentStr); { "Caller" will be the Ident gen-} var { erated when "begin" is reached.} HoldID : IdentStr; { HoldID passed as Caller to } { next nested block. } procedure ParseStatement; var IdentPtr : SymPtr; { used to check symbol table } HoldID : IdentStr; { hold while class & type checked } HoldType : TokCode; { hold while exp. type is checked } { All the routines from ParseExpression on down are defined as functions rather than procedures. They return the type (integer or boolean) deduced from the operations specified. The "HoldOp" variables are needed to delay code generation for postfix notation. The "HoldType" variables record the type of the first operand so that it can be compared with the type of the second operand. } function ParseExpression: TokCode; var HoldRelOp : IdentStr; HoldType : TokCode; function ParseSimpleExpr: TokCode; var HoldAddOp : IdentStr; HoldType : TokCode; function ParseTerm: TokCode; var HoldMultOp : IdentStr; HoldType : TokCode; function ParseSignedFactor: TokCode; var IdentPtr : SymPtr; HoldType : TokCode; { ParseFactor is the lowest-level routine in the parser. For a factor to be recognized as valid it must be either a boolean literal (TRUE of FALSE), a numeric literal, an identifier that designates a var- iable or a parenthesized expression. The case statement considers each of these possibilities in turn. } function ParseFactor: TokCode; var IdentPtr: SymPtr; { needed to consult the symbol table } begin case TK.Code of TrueSym, FalseSym : begin ParseFactor := BoolSym; { return type boolean } Gen(TK.Name); GetTK; { Gen TRUE or FLASE } end; Number : begin ParseFactor := IntSym; { return type integer } Gen(TK.Name); GetTK; { Gen numeric literal } end; Ident : begin IdentPtr := Find(TK.Name); { look up the name } if IdentPtr = nil then Error(UnDec) { not found? } else begin if IdentPtr^.Class <> Variable { can't be proc } then Error(XVar) else begin ParseFactor := IdentPtr^.VarType; { rtn Int or Bool } Gen(ConCat(TK.Name,' @')); GetTK; { code to fetch } end; end; end; LeftParen : begin { call ParseExpression recursively } GetTK; { and return the type } ParseFactor := ParseExpression; { that it returns } if TK.Code <> RightParen then Error(XParen); GetTK; { eat the ")" } end; else Error(XFactor); { if none of above, not a valid factor } end; end; { ParseSignedFactor is introduced into the chain of expression- parsing functions merely to handle a unary plus, minus or logical NOT preceding a factor. If none of these is found, the code drops through directly to ParseFactor. If one of them is found, the appropriate code is generated after ParseFactor returns, thereby converting the notation to postfix form. } begin {ParseSignedFactor} case TK.Code of Plus : begin GetTK; { eat the + sign } HoldType := ParseFactor; { parse & get type } if HoldType <> IntSym then Error(XInt) { +boolean illegal } else ParseSignedFactor := IntSym; { HoldType=Int } end; Minus : begin GetTK; { eat the - sign } HoldType := ParseFactor; { parse & get type } if HoldType <> IntSym then Error(XInt) { -boolean illegal } else begin ParseSignedFactor := IntSym; { HoldType = Int } Gen('NEGATE'); { code toggles sign} end; end; NotSym : begin GetTK; { eat NOT symbol } HoldType := ParseFactor; { parse & get type } if HoldType <> BoolSym then Error(XBool) { NOT number illegal} else begin ParseSignedFactor := BoolSym; { HoldType = boolean} Gen('NOT'); { code to invert } end; end; else ParseSignedFactor := ParseFactor; { no +, -, NOT found} end; end; { ParseTerm recognizes either "SignedFactor" or a subexpression of the form "SignedFactor MultOp Term". Thus it will always call ParseSignedFactor, and if the next token is a MultOp, it will also call itself recursively. } { For a lacuna in type-checking, see DADA.DOC Note 9. } begin {ParseTerm} HoldType := ParseSignedFactor; { parse & get type first operand } if (TK.Code in MultOpSet) then { TK = *, /, OR? } begin HoldMultOp := TK.Name; { save the Op for postfix } GetTK; { and eat it } if not (HoldType = ParseTerm) { parse & get type 2d operand } then Error(Match); { 1st & 2d operands same type? } Gen(HoldMultOp); { issue the saved operator } end; ParseTerm := HoldType; { return the operand type } end; { ParseSimpleExpr recognizes either "Term" or a subexpression of the form "Term AddOp SimpleExpr". It always calls ParseTerm and if the next token is an AddOp, it also calls itself. } begin {ParseSimpleExpr} HoldType := ParseTerm; { parse & get type 1st operand } if (TK.Code in AddOpSet) then { TK = +, -, AND? } begin HoldAddOp := TK.Name; { save the Op for postfix } GetTK; { and eat it } if not (HoldType = ParseSimpleExpr) { parse & get type 2d operand } then Error(Match); { 1st & 2d operands same type? } Gen(HoldAddOp); { issue the save operator } end; ParseSimpleExpr := HoldType; { return the operand type } end; { ParseExpression recognizes either "SimpleExpr" or a sub- expression of the form "SimpleExpr RelOp SimpleExpr." It always calls ParseSimpleExpr once, and if the next token is a RelOp, it also makes a second call to ParseSimpleExpr. Note that this scheme is slightly different from the recursive pattern in the lower- level functions. On that model one would expect "SimpleExpr RelOp Expression," so that to parse the second operand the function would call itself. Such a construction, however, would allow expressions of the form A > B < C = D, and so on. It would be easy enough to assign a meaning to these expressions, but the language definition does not supply one. } begin {ParseExpression} HoldType := ParseSimpleExpr; { parse & get type 1st operand } ParseExpression := HoldType; { type to be returned if no RelOp } if (TK.Code in RelOpSet) then { TK is >, <, =, etc. ? } begin HoldRelOp := TK.Name; { save operator for postfix } GetTK; { and eat it } if not (HoldType = ParseSimpleExpr) { parse & get type 2d operand } then Error(Match); { 1st & 2d operands same type ? } ParseExpression := BoolSym; { if Expr has Relop, type = bool } Gen(HoldRelOp); { issue the saved operator } end; end; { ParseStatement is the most elaborate routine in the parser. The grammar for Dada specifies five constructs to be recognized as valid statements: a compound statement delimited by "begin" and "end," an assignment statement, a procedure call, an "if" state- ment and a "while" statement. The parser actually includes two more possibilities: "Read" and "Write" statements, which can be viewed as predefined procedures. With one exception the grammar allows these possibilities to be distinguished on the basis of the first token presented to ParseStatement. The exception is the discrimination between assignment statements and procedure calls, which both begin with an identifier. The parser chooses its path by checking the identifier's class in the symbol table: a value can be assigned only to a variable, and only a procedure can be called. } { See also DADA.DOC Note 10 } begin {ParseStatement} case TK.Code of BeginSym : begin { must be compound } GetTK; { eat the "BEGIN" } while TK.Code <> EndSym do { loop while stmts } begin ParseStatement; { calls itself } if not (TK.Code in [Semi,EndSym]) { delimiter expected } then Error(XSemEnd); if TK.Code = Semi then GetTK; { go back for another} end; GetTK; { TK must be "END"; eat it } end; IfSym : begin { must be If statement} GetTK; { eat the "IF" } if not (BoolSym = ParseExpression) { parse expr & ck type} then Error(XBool); { only boolean allowed} Gen('IF'); { Forth IF after expr } if TK.Code <> ThenSym { must have then part } then Error(XThen); GetTK; { if present, eat it } ParseStatement; { calls itself } if TK.Code = ElseSym then { else is optional } begin { if present, Gen code} Gen('ELSE'); GetTK; { and eat the token } ParseStatement; { calls itself again } end; Gen('THEN'); { end of Forth cond. } end; WhileSym : begin { this is a while loop} Gen('BEGIN'); GetTK; { Gen marker; eat tok } if not (BoolSym = ParseExpression) { parse and check type} then Error(XBool); { must be boolean } if TK.Code <> DoSym then Error(XDo); { must have Do part } Gen('WHILE'); GetTK; { eat; Gen Forth test } ParseStatement; { recursive call } Gen('REPEAT'); { end of Forth block } end; Ident : begin { assignment or call } IdentPtr := Find(TK.Name); { look up in table } if IdentPtr = nil then Error(UnDec); { can't find it } if IdentPtr^.Class = Variable then { must be assignment } begin HoldType := IdentPtr^.VarType; { save Ident type... } HoldID := TK.Name; GetTK; { and name for postfix} if TK.Code <> AssignOp { must have := sign } then Error(XAssgn); GetTK; { if so, eat it } if not (HoldType = ParseExpression) { parse expr & ck type} then Error(Match); { report mismatch } Gen(Concat(HoldID,' !')); { code to store value } end else { must be proc call } begin { invoke the Forth } Gen(TK.Name); GetTK; { word and consume } end; { the token } end; ReadSym : begin { predefined READ proc } GetTK; { eat token } if TK.Code <> Ident { must name variable... } then Error(XIdent); { to hold the value read } IdentPtr := Find(TK.Name); { look up in table } if IdentPtr^.Class <> Variable { cannot be proc Ident } then Error(XVar); if IdentPtr^.VarType <> IntSym { only integers can... } then Error(XInt); { be read in Dada } Gen(Concat(TK.Name,' READ')); { issue the call in Forth} GetTK; { eat up the Ident } end; WriteSym : begin { predefined WRITE proc } GetTK; { eat token } if TK.Code <> Ident { must name variable... } then Error(XIdent); { to be written } IdentPtr := Find(TK.Name); { look it up } if IdentPtr^.Class <> Variable { cannot be Proc name } then Error(XVar); if IdentPtr^.VarType <> IntSym { only integers can... } then Error(XInt); { be written } Gen(Concat(TK.Name,' WRITE')); { issue the call } GetTK; { consume the Ident } end; else Error(XStmt); { if none of the above } end; end; { ParseBlock has two parts. It first checks for a procedure declar- ation; if it finds one, it parses the header and calls itself again. Ultimately, the BEGIN symbol that marks the statement part of a block must be reached. Each statement is then processed in turn (by Parse- Statement) until the matching END is reached. The possible nesting of blocks within blocks is accommodated automatically by the re- cursive organization of the routines. Recall that ParseBlock is passed an identifier as an argument, namely the Ident of the procedure or program that issued the call. This Ident is written into the code as the designator of a Forth word when "begin" is reached. } begin { ParseBlock } CurrentScope := CurrentScope + 1; { bump up nesting count } while TK.Code = ProcSym do { proc declarations } begin GetTK; { eat "procedure" token } if TK.Code <> Ident then Error(XIdent); { proc must have name } HoldID := TK.Name; { save to pass to next level } Declare(TK.Name,Proc,Null); { put in table as proc name } GetTK; { eat the Ident } if TK.Code <> Semi then Error(XSemi); { must have a semi } GetTK; { throw the semi away } ParseBlock(HoldID); { call again, pass proc name } if TK.Code <> Semi then Error(XSemi); { proc block must have semi } GetTK; { eat it up } end; if TK.Code <> BeginSym then Error(XBegin); { block begins "BEGIN" } Gen(Concat(': ',Caller)); { start colon definition } GetTK; { eat the "BEGIN" } while TK.Code <> EndSym do { loop for all statements } begin ParseStatement; { call for each stmt } if not (TK.Code in [Semi,EndSym]) { separator or terminator... } then Error(XSemEnd); { need after each one } if TK.Code = Semi then GetTK; { if semi, eat & go back } end; { TK must have been "END" } GetTK; { eat the END } Gen(';'); Gen('|'); { end Forth def, force CR } Blot; { clean up symbol table } end; { ParseProgram sets the entire compiler in motion. It first handles the program header, saving the program name (which will be the last Forth word generated). The program is declared in the symbol table as a procedure like any other, except that its scope field has a value of zero, which no other procedure can have. ParseProgram then calls ParseVariables and ParseBlock, which process the body of the program. Finally there is a check for the final dot. } begin { ParseProgram } if TK.Code <> PgmSym then Error(XPgm); { must begin "PROGRAM" } GetTK; { dispose of that token } if TK.Code <> Ident then Error(XIdent); { program must have a name } HoldID := TK.Name; { save, pass to ParseBlock } Declare(TK.Name,Proc,Null); { install in table } GenHeader(TK.Name); { output the Forth prelude } GetTK; { eat the Ident } if TK.Code <> Semi then Error(XSemi); { header must end with semi } GetTK; { toss out the semi } ParseVariables; { do the global declarations } ParseBlock(HoldID); { give Block the program name } if TK.Code <> Dot then Error(XDot); { not done until "." read } Gen(';S'); { tell Forth to stop } end; {*****************************************************************************} {*****************************************************************************} {***************** *****************} {***************** MAIN BLOCK *****************} {***************** *****************} {*****************************************************************************} {*****************************************************************************} { The main driver routine has little to do: initialize some global variables, open the files and crank up the parser. } procedure Initialize; begin InitErrorList; { fill up one static array... } InitKeywords; { and then another } InitSets; { define sets of tokens } InitOutBuf; { set up a clean slate } FirstSym := nil; { make pointer point nowhere } CurrentScope := 0; { at start scope is global } LineCount := 1; { start on first source line } SayHello; { paint the screen } end; begin { main block } Initialize; OpenFiles; Read(InFile,CH); CH := Upcase(CH); { get first char for scanner } GetTK; { and first token for parser } ParseProgram; CloseFiles; WriteLn('Compilation complete.'); end.