(********************* PL0 compiler Turbo Pascal code ********************) Program PL0 (Fa, FA1, FA2
);
(* Pl0 compile with code generation *) label 99
;
(* Turbo Pascal Do Not Support Goto Between Different Blocks So, The 'Goto' Command in Getch Are Replaced by Procedure EXITP !! In Another Way, 'Label 99' Do Not Work !! Lin Wei 2001 *) Const Norw = 13;
(* of reserved words *) TXMAX = 100;
(* longth of identifier table *) nmax = 14;
(* Max number of digits in numbers *) al = 10;
(* longth of identifiers *) AMAX = 2047;
(* maximum address *) levmax = 3;
(* max depth of block Nesting *) cxmax = 200;
(* size of code array *) Type symbol = (NUL, IDENT, NUMBER, PLUS, Minus, Times, Slash, Oddsym
, EQL, NEQ, LSS, LEQ, GTR, GEQ, LPAREN, RPAREN, COMMA
, SEMICOLON, Period, Becomes, Beginsym, Endsym, IFSYM
, THENSYM, WHILESYM, WRITESYM, READSYM, DOSYM, CALLSYM
Constsym, Varsym, Procsym
); ALFA = Packed array [1..Al] of char
Objects = (Constant, Variable, Procedur
);
(* Wirth "and" Object "There, Which Won't work! *) Symset = set of symbol
FCT = (LIT, OPR, LOD, STO, CAL, INT, JMP, JPC
INSTRUCTION =
Packed Record F: FCT;
(* function code *) l: 0..levmax;
(* Level *) A: 0..amax;
(* Displacement addr *) end
;
(* LIT 0, A LOAD CONSTANT A OPR 0, A Execute Opr a LOD 1, A Load Variable 1, A Sto 1, A Store Variable 1, A Cal 1, A Call Procedure At Level 1 INT 0, A Increment T - Register by a jmp 0, a jump to a jpc 0, a jump conditional to a *) var fa: text; fa1, fa2: Text
Listswitch: boolean;
(* True set list object code *) CH: char;
(* last char) *) SYM: Symbol;
(* Last Symbol Read *) ID: ALFA;
(* Last Identifier Read *) Num: Integer;
(* Last Number Read *) cc: integer;
(* Character Count *) LL: Integer;
(* Line Length *) KK: INTEGER
; Cx: integer;
(* code allocation index *) line: array [1..81] of char
; A: ALFA
; Code: array [0..cxmax] of instruction
Word: array [1..norw] of Alfa
Wsym: array [1..norw] of symbol
Ssym: array ['' .. '^'] of symbol
;
(* Wirth Uses "array [char]" Here *) MNEMonic: array [fct] of packed array [1..5] of char
Declbegsys, Statbegsys, Facbegsys: Symset
Table: Array [0..txmax]
Of Record Name: Alfa
Case Kind: Objects
Of constant: (VAL: Integer
Variable, Procedur: (Level, ADR, SIZE: INTEGER
)
(* "size" lacking in Original. I think it belongs here *) end
FIN, Fout: Text
FNAME: STRING
Err: INTEGER
; ENDF: BOOLEAN
Procedure Error (N: Integer
);
Begin Writeln ('****', '': CC-1, '!', N: 2
); Writeln (FA1, '****', '': CC-1, '!', N: 2
Err: = Err 1
;
(* error *) Procedure EXITP
;
Begin endf: = TRUE
Close (FIN)
Writeln
EXIT
; END
Procedure getsym
; Var i, j, k: integer
Procedure getch
;
Begin if cc = ll
Then Begin if Eof (FIN)
Then Begin Write ('Program Incomplete'
CLOSE (FIN
Writeln
EXITP
;
(* goto 99; *) end
; Ll: = 0
; Cc: = 0
Write (CX: 4, ''
Write (FA1, CX: 4, ''
WHILE NOT EOLN (FIN)
Do Begin Ll: = LL 1
Read (Fin, CH
Write (CH)
Write (FA1, CH)
LINE [LL]: = CH
; END
Writeln
; LL: = LL 1
;
(* read (FIN, LINE [LL]); Repleted by Two Lines Below *) Line [LL]: = ''
Readln (FIN)
Writeln (FA1
); END
; Cc: = CC 1
CH: = line [cc
];
(* getch *) Begin
(* getsym *) while ch = '' do getch
; If chin ['a' .. 'z']
Then Begin K: = 0
;
Repeat IF K Then Begin K: = K 1 ; A [k]: = CH ; END Getch Until NOT (CH IN ['A' .. 'Z', '0' .. '9' ]); If k> = KK THEN KK: = K Else Repeat A [KK]: = '' ; KK: = KK-1 Until Kk = K ; Id: = a I: = 1 ; J: = Norw ; REPEAT K: = (i j) DIV 2 ; If id <= word [k] THEN J: = K-1 ; If id> = word [k] THEN i: = K 1 Until i> J ; If i-1> j Then Sym: = wsym [k] else sym: = IDENT ; ELSE IF CH IN ['0' .. '9'] THEN Begin (* Number *) K: = 0 Num: = 0 ; SYM: = Number ; REPEAT NUM: = 10 * Num (ORD (CH) -ORD ('0' )); K: = k 1; getch Until NOT (CH IN ['0' .. '9' ]); If k> nmax the Error (30 ); END ELSE IF CH = ':' Then Begin getch ; If ch = '=' Then Begin Sym: = Becomes Getch END ELSE SYM: = NUL END ELSE IF CH = '<' Then Begin getch ; If ch = '=' Then Begin Sym: = Leq Getch ; END ELSE SYM: = LSS ; ELSE IF CH = '>' Then Begin getch ; If ch = '=' Then Begin Sym: = GEQ Getch ; END ELSE SYM: = GTR ; END ELSE BEGIN SYM: = SSYM [CH ]; Getch ; END ; (* getsym *) Procedure Gen (x: fct; y, z: integer ); Begin IF CX> CXMAX Then Begin Write ('Program Too Long " ); (* goto 99; *) end WITH code [CX] Do Begin f: = x ; L: = Y A: = z ; END ; Cx: = CX 1 ; (* gen *) Procedure Test (S1, S2: Symset; N: Integer ); Begin if not (SYM in S1) Then Begin Error (N ); S1: = S1 S2 WHILE NOT (SYM IN S1) Do GetSym ; END ; (* Test *) Procedure Block (Lev, Tx: Integer; fsys: symset VAR DX: Integer; (* Data Allocation Index *) TX0: Integer; (* Inital Table Index *) CX0: Integer; (* Inital Code Index *) Procedure Enter (K: Objects Begin (* ENTER Object Into Table *) TX: = TX 1 WITH TABLE [TX] Do Begin Name: = ID Kind: = k Case K Of constant: Begin if Num> AMAX THEN BEGIN Error (31); Num: = 0; End Val: = Num ; END Variable: Begin Level: = Lev ADR: = DX ; Dx: = DX 1 ; END Procedur: Level: = Lev ; END ; END ; (* ENTER *) Function Position (ID: ALFA): Integer VAR i: Integer Begin (* Find Identifier In Table *) Table [0] .name: = ID ; I: = TX WHILE TABLE [I] .Name <> ID DO i: = i-1 Position: = i ; (* position *) Procedure constdeclaration ; Begin if Sym = Ident Then Begin Getsym ; If Sym in [EQL, Becomes] Then Begin if Sym = Becomes Then Error (1 GetSym ; If Sym = Number Then Begin Enter (Constant GetSym ; END ELSE ERROR (2 ); ELSE ERROR (3 ); ELSE ERROR (4 END; (* constdeclaration *) Procedure Vardeclaration ; Begin if Sym = Ident Then Begin Enter (Variable GetSym END ELSE ERROR (4 END; (* Vardeclaration *) Procedure ListCode VAR i: Integer ; Begin if Listswitch Then Begin for i: = CX0 TO CX-1 Do with code [i] Do Begin Writeln (I, MNemonic [f]: 5, L: 3, A: 5 Writeln (Fa, I: 4, MNEMONIC [F]: 5, L: 3, A: 5 ); END ; END ; (* listcode *) Procedure Statement (fsys: symset ); VAR I, CX1, CX2: INTEGER Procedure Expression (fsys: symset VAR Addop: Symbol Procedure Term (fsys: Symset VAR Mulop: Symbol Procedure Factor (fsys: symset VAR i: integer ; Begin Test (Facbegsys, Fsys, 24 WHILE SYM IN FACBEGSYS Do Begin if Sym = Ident Then Begin I: = Position (ID ); If i = 0 Then Error (11 Else with Table [I] Do Case Kind Of constant: Gen (LIT, 0, VAL Variable: Gen (LOD, Lev-Level, ADR ); Procedur: Error (21 ); END Getsym ; ELSE IF SYM = NUMBER Then Begin If Num> Amax Then Begin Error (31 Num: = 0 ; END Gen (LIT, 0, NUM GetSym ; END ELSE IF SYM = LPAREN Then Begin Getsym Expression ([RPAREN] FSYS ); If sym = rparen the getsym else error (22 ); END Test (fsys, facbegsys, 23 ); END ; (* Factor *) Begin (* Term *) Factor ([Times, Slash] FSYS WHILE SYM IN [TIMES, SLASH] Do Begin Mulop: = SYM Getsym ; Factor (fsys [Times, Slash ]); If mulop = Times Then (opr, 0,4) Else Gen (opr, 0, 5 ) End ; (* Term *) Begin (* Expression *) IF SYM IN [Plus, Minus] Then Begin Addop: = SYM Getsym ; Term (Fsys [Plus, Minus]); if addop = minus kil (opr, 0, 1 ); ELSE TERM (Fsys [Plus, Minus ]); While Sym in [Plus, Minus] Do Begin Addop: = SYM Getsym ; Term (Fsys [Plus, Minus ]); If addop = Plus kil (opr, 0, 2) Else Gen (opr, 0, 3 ); END ; (* Expression *) Procedure Condition (fsys: symset VAR RELOP: SYMBOL ; Begin if Sym = Oddsym Then Begin Getsym Expression (fsys) GEN (OPR, 0, 6 ); END ELSE BEGIN Expression ([EQL, NEQ, LSS, LEQ, GTR, GEQ] FSYS ); If not (SYM IN [EQL, NEQ, LSS, LEQ, GTR, GEQ]) THEN ERROR (20 ) Else Begin Relop: = SYM Getsym Expression (fsys) Case Relop Of EQL: Gen (opr, 0, 8 NEQ: GEN (OPR, 0, 9 ); LSS: GEN (OPR, 0, 10 ); Geq: gen (opr, 0,11 ); GTR: GEN (OPR, 0, 12 Leq: Gen (opr, 0,13 ); END ; END ; END ; (* condition *) Begin (* Statement *) if SYM = Ident Then Begin I: = Position (ID ); If i = 0 Then Error (11 Else if Table [I] .kind <> variable Then Begin Error (12 ); I: = 0 ; END Getsym ; If Sym = Becomes Then Getsym Else Error (13 Expression (fsys) ); If i <> 0 dam with table [i] do gen (STO, Lev-Level, ADR ); END ELSE IF SYM = ReadSym Then Begin Getsym ; If Sym <> lparen the Error (34) Else Repeat Getsym ; If Sym = Ident Then i: = position (id ELSE I: = 0 ; If i = 0 Then Error (35 Else with Table [I] Do Begin Gen (opr, 0,16 ); GEN (Sto, Lev-Level, ADR ); END Getsym Until Sym <> COMMA ; If Sym <> rparen Then Begin Error (33 WHILE NOT (SYM IN FSYS) Do GetSym ; END ELSE GETSYM END ELSE IF SYM = WriteSYM Then Begin Getsym ; If SYM = LPAREN Then Begin Repeat Getsym Expression ([RPAREN, COMMA] FSYS Gen (opr, 0,14 Until Sym <> COMMA ; If sym <> rparen kilror (33) Else Getsym ; END Gen (opr, 0,15 END ELSE IF SYM = Callsym Then Begin Getsym ; If Sym <> Ident Then Error (14 ) Else Begin i: = position (id) ); If i = 0 Then Error (11) else with table [i] Do if Kind = Procedur Then Gen (Cal, Lev-Level, ADR Else Error (15 GetSym ; END END ELSE IF SYM = IFSYM Then Begin Getsym Condition ([THENSYM, DOSYM] FSYS ); If sym = THENSYM THEN GETSYM ELSE ERROR (16 ); Cx1: = cx Gen (JPC, 0, 0 Statement (fsys) ); Code [cx1] .a: = cx END ELSE IF SYM = Beginsym Then Begin Getsym ; STATEMENT ([SEMICOLON, Endsym] fsys ); While sym in [semicolon] statbegsysdo begin if Sym = semicolon dam, Statement ([SEMICOLON, Endsym] FSYS ); END ; If Sym = endsym the getsym else error (17 ); ELSE IF SYM = WhileSym Then Begin CX1: = CX Getsym Condition ([DOSYM] FSYS ); CX2: = CX Gen (JPC, 0, 0 ); If Sym = dosym the getsym else error (18 Statement (fsys) ); GEN (JMP, 0, CX1 ); Code [cx2] .a: = cx ; END Test (fsys, [], 19 END; (* Statement *) Begin (* block *) dx: = 3 ; TX0: = TX ; Table [TX] .adr: = CX Gen (JMP, 0, 0 ); If Lev> Levmax Then Error (32 ); REPEAT IF SYM = Constsym Then Begin Getsym ; Repeat constdeclaration WHILE SYM = Comma Do Begin Getsym ConstdeClaration ; END ; If Sym = SEMICOLON THEN GETSYM ELSE ERROR (5 Until Sym <> IDENT ; END ; If Sym = VARSYM Then Begin Getsym Repeat Vardeclaration WHILE SYM = Comma Do Begin Getsym Vardeclaration ; END ; If Sym = SEMICOLON THEN GETSYM ELSE ERROR (5 Until Sym <> IDENT ; END WHILE SYM = Procsym Do Begin Getsym ; If Sym = IDENT Then Begin Enter (Procedur) GetSym END ELSE ERROR (4 ); If Sym = SEMICOLON THEN GETSYM ELSE ERROR (5 ); Block (Lev 1, TX, [SEMICOLON] FSYS ); If SYM = SEMICOLON Then Begin Getsym ; Test (Statbegsys [Ident, Procsym], FSYS, 6); ELSE Error (5 ); END ; Test (statbegsys [ident), DECLBEGSYS, 7 ); Until not (SYM in Declbegsys ); Code [table [tx0] .adr] .a: = cx WITH TABLE [TX0] Do Begin ADR: = CX Size: = DX ; END ; Cx0: = CX Gen (int, 0, dx Statement ([SEMICOLON, Endsym] FSYS GEN (OPR, 0, 0 ); Test (fsys, [], 8 ListCode ; (* block *) Procedure Interpret Const stacksize = 500 ; VAR P, B, T: Integer; (* Program Base TopStack Registers *) i: Instruction ; S: array [1..stacksize] of integer; (* Datastore *) Function Base (L: Integer): Integer VAR BL: INTEGER ; Begin BL: = B; (* Find Base 1 Level Down *) While L> 0 Do Begin BL: = S [BL ]; L: = L-1 ; END Base: = BL ; (* Base *) Begin Writeln ('Start PL0' ); T: = 0; B: = 1; P: = 0 ; S [1]: = 0; s [2]: = 0; s [3]: = 0 ; Repeat I: = Code [P ]; P: = p 1 WITH I do CASE F Of Lit: Begin T: = T 1; S [T]: = a; end ; Opr: Case A of (* Operator *) 0: Begin (* return *) T: = B-1 ; P: = s [t 3 ]; B: = S [T 2 ]; END ; 1: s [t]: = - s ]; 2: Begin T: = T-1; s [t]: = s [t] s [t 1]; END ; 3: Begin T: = T-1; s [t]: = s [t] -s [t 1]; end ; 4: Begin T: = T-1; s [t]: = s [t] * s [t 1]; end ; 5: Begin T: = T-1; S [T]: = S [T] DIV S [T 1]; END ; 6: s [t]: = ORD (ODD (S [T ]); 8: Begin T: = T-1; s [t]: = ORD (S [T] = S [T 1]); END; 9: Begin T: = T-1; s ]: = ORD (S [T] <> S [T 1]); END ; 10: Begin T: = T-1; s [T]: = ORD (S [T] 11: Begin T: = T-1; s [T]: = ORD (S [T]> = S [T 1]); END 12: Begin T: = T-1; s [T]: = ORD (S [T]> S [T 1]); END 13: Begin T: = T-1; s [T]: = ORD (S [T] <= S [T 1]); END ; 14: Begin Write (s [t]); Write (FA2, S [T]); T: = T-1; END 15: Begin Writeln; Writeln (FA2); END ; 16: Begin T: = T 1; Write ('?'); Write (FA2, '?'); Readln (S [T ]); Writeln (FA2, S [T]); END ; END ; LOD: Begin T: = T 1; s [T]: = S [Base (L) a]; END ; STO: Begin S [Base (L) A]: = S [T]; (* WriteLn (s [t]) *) T: = T-1; END Cal: Begin (* generat new block mark *) s [t 1]: = base (l); s [t 2]: = B ; S [t 3]: = p; b: = t 1; p: = a; end ; Int: T: = T a ; JMP: P: = a JPC: Begin IF S [T] = 0 THEN P: = a; T: = T-1; END ; (* with, case *) Until P = 0 ; Close (FA2 END; (* interpret *) Begin (* main *) for ch: = '' to '!' do ssym [ch]: = NUL ; (* Changed Bacause of Different Character Set Note The Typos Below In The Original WHERE The Alfas Were Not Given The Correct Space *) Word [1]: = 'Begin'; Word [2]: = 'CALL' ; Word [3]: = 'const'; Word [4]: = 'do' Word [5]: = 'end'; Word [6]: = 'IF' Word [7]: = 'odd'; Word [8]: = 'procedure'; Word [9]: = 'read'; Word [10]: = 'TEN' Word [11]: = 'Var'; Word [12]: = 'While' Word [13]: = 'WRITE' ; Wsym [1]: = beginsym; wsym [2]: = Callsym Wsym [3]: = Constsym; Wsym [4]: = DOSYM Wsym [5]: = endsym; wsym [6]: = ifsym Wsym [7]: = ODDSYM; Wsym [8]: = procsym Wsym [9]: = ReadSym; Wsym [10]: = Tensym Wsym [11]: = VARSYM; wsym [12]: = WhileSym Wsym [13]: = WriteSYM ; SSYM [' ']: = Plus; SSYM ['-']: = minus SSYM ['*']: = Times; SSYM ['/']: = Slash SSYM [']: = lparen; ssym [') ']: = rparen SSYM ['=']: = EQL; SSYM [',']: = Comma SSYM ['.']: = Period; ssym ['#']: = neq SSYM [';']: = SEMICOLON MNEMONIC [LIT]: = 'LIT'; MNEMONIC [OPR]: = 'OPR' MNEMONIC [LOD]: = 'LOD'; MNEMONIC [STO]: = 'STO' MNEMONIC [CAL]: = 'CAL'; MNEMONIC [INT]: = 'int' MNEMONIC [JMP]: = 'JMP'; MNEMONIC [JPC]: = 'JPC' DECLBEGSYS: = [Constsym, Varsym, Procsym Statbegsys: = [Beginsym, Callsym, IFSYM, WhileSym ]; Facbegsys: = [Ident, Number, Lparen ]; (* Page (output) *) endf: = false Assign (FA1, 'PL0.TXT' ReWrite (FA1 Write ('INPUT file?' Write (FA1, 'Input File?' Readln (FNAME Writeln (FA1, FNAME ); (* OpenF (FIN, FNAME, 'R'); ==> *) Assign (FIN, FNAME); Reset (Fin ); Write ('List Object Code?'); Readln (FNAME Write (FA1, 'LIST OBJECT CODE?' ); ListSwitch: = (fname [1] = 'y' Err: = 0 ; Cc: = 0; cx: = 0; LL: = 0 CH: = ''; KK: = Al Getsym Assign (Fa, 'PL0-1.txt' Assign (FA2, 'PL0-2.txt' ReWrite (fa) ReWrite (FA2 ); Block (0, 0, [Period] Declbegsys statbegsys CLOSE (fa) CLOSE (FA1) ); If Sym <> period life error (9 ); If err = 0 THEN Interpret Else Write ('Error In PL / 0 Program " 99: (* This Line is not work in turbo pascal so replace by Procedure EXITP: See The Memo At The Top *) Close (FIN Writeln ; END .
