home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
modula2
/
alexcoco
/
cocosynf
< prev
next >
Wrap
Text File
|
1987-07-16
|
15KB
|
440 lines
(* cocosyn General table driven syntax analyzer Re
======= ==================================== Moe 21.12.83
01 (21.12.83) First version (rewritten from PL/M)
02 (28.02.84) New interface for input and errors
03 (02.04.84) Error in EOL-processing corrected
04 (08.05.84) New EOL-processing
05 (23.07.84) For G-Code
06 (30.08.84) Error recovery simplified
07 (05.04.85) New G-Code instruction EPSA (ANYA modified)
----------------------------------------------------------------------*)
IMPLEMENTATION MODULE -->modulename;
FROM FileIO IMPORT con, WriteCard, WriteLn, WriteString;
FROM FileSystem IMPORT Open, ReadWord;
FROM Files IMPORT Close, File, Mode, status, FileStatus;
(*2.12.,I,Dob*)
FROM SYSTEM IMPORT WORD; (*2.12.,I,Dob*)
FROM Storage IMPORT ALLOCATE, DEALLOCATE; (*2.12.,D,Dob*)
FROM -->semantic analyzer IMPORT Semant;
FROM -->input module IMPORT -->input procedure;
FROM -->error module IMPORT -->error procedure, Errorptr;
-->declarations
CONST (*opcodes for G-code-instructions*) (*2.12.,I,Dob*)
t = 0; ta = 1; nt = 2; nta = 3;
nts = 4; ntas = 5; any = 6; anya = 7;
eps = 8; epsa = 9; jmp =10; ret =11;
TYPE
Attributenumbers = ARRAY[0..maxp] OF CARDINAL;
Instrtype = [0..255]; (*2.12.,C,Dob*)
Namepointers = ARRAY[0..maxnamep] OF CARDINAL;
Namelist = ARRAY[1..maxname] OF CHAR;
Pragma = RECORD (*semantics for a pragma*)
sem2,sem3: CARDINAL;
END;
Pragmalist = ARRAY[maxt..maxp] OF Pragma;
Symbolset = ARRAY[0..maxt DIV 16] OF BITSET;
(*set of terminals*)
Symbolnode = RECORD (*symbol information (only for nt)*)
startpc: CARDINAL; (*start node of rule for nt*)
del: BOOLEAN; (*TRUE, if nt is deletable*)
first: Symbolset; (*terminals causing to analyze this nt*)
END;
Symbollist = ARRAY[maxp+1..maxs] OF Symbolnode;
VAR
anyset: ARRAY[1..maxany] OF Symbolset;
code: ARRAY[1..maxcode] OF CHAR; (*G-code area*)
correct: BOOLEAN; (*error indicator*)
epsset: ARRAY[1..maxeps] OF Symbolset;
name: Namelist; (*symbol names*)
namep: Namepointers; (*pointers to symbol names*)
nra: Attributenumbers; (*nr.of attributes for t,pr-symbols*)
ntsymbols: Symbollist; (*nonterminals information*)
pc: CARDINAL; (*program counter*)
ps: Pragmalist; (*semantics for pragmas*)
(*typ,at,col and line are declared in the definition module*)
(* Match Check if sy is member of the specified set
---------------------------------------------------------------------*)
PROCEDURE Match(sy:CARDINAL; set:Symbolset): BOOLEAN;
BEGIN RETURN (sy MOD 16) IN set[sy DIV 16]; END Match;
(* Next Get next byte from code area
---------------------------------------------------------------------*)
PROCEDURE Next(): CARDINAL;
BEGIN INC(pc); RETURN ORD(code[pc-1]); END Next;
(* Next2 Get next word from code area
---------------------------------------------------------------------*)
PROCEDURE Next2(): CARDINAL;
BEGIN
INC(pc,2); RETURN 256*ORD(code[pc-2]) + ORD(code[pc-1]);
END Next2;
(* NextSym Get next symbol
-----------------------------------------------------------------------*)
PROCEDURE NextSym;
VAR token,i: CARDINAL;
BEGIN
REPEAT
-->input procedure(token);
typ:=token DIV 256; col:=token MOD 256;
IF printinput THEN
WriteString(con,"$(in:"); WriteCard(con,typ,3);
WriteString(con,") ");
IF printnodes THEN
WriteCard(con,lacts,3); WriteString(con,"| ");
END;
END;
FOR i:=1 TO nra[typ] DO -->input procedure(at[i]); END;
IF typ=eolsy THEN INC(line); END;
IF typ>maxt THEN
IF correct AND (ps[typ].sem2<>0) THEN Semant(ps[typ].sem2); END;
IF correct AND (ps[typ].sem3<>0) THEN Semant(ps[typ].sem3); END;
END;
UNTIL (typ<=maxt) OR (typ=eofsy);
END NextSym;
(*MODULE ERRORS; Procedures for recovery after syntax errors
=====================================================================*)
CONST errdistmin = 2; (*min.distance between two errors*)
VAR
errdist: CARDINAL; (*current error distance*)
newlacts: ARRAY [0..maxt] OF CARDINAL; (*new stack length*)
newpc: ARRAY [0..maxt] OF CARDINAL; (*pc after recovery*)
(* AdjustPc Adjust pc to next symbol instruction
---------------------------------------------------------------------*)
PROCEDURE AdjustPc(VAR pc:CARDINAL);
BEGIN
IF pc=0 THEN RETURN; END;
LOOP
CASE ORD(code[pc]) OF (*2.12.,C,Dob*)
t,ta,nt,nta,nts,ntas,any,anya,eps,epsa: EXIT;
| jmp: pc:=256*ORD(code[pc+1])+ORD(code[pc+2]);
| ret: pc:=0; EXIT;
ELSE INC(pc); (*sem*)
END;
END;
END AdjustPc;
(* Error Report syntax error
---------------------------------------------------------------------*)
PROCEDURE Error(VAR pc,altroot:CARDINAL);
VAR
e,e1,h: Errorptr;
i,j: CARDINAL;
opcode: Instrtype; (*2.12.,C,Dob*)
sy,nextpc,altpc,pc1: CARDINAL;
PROCEDURE GiveName(q:Errorptr; sy:CARDINAL);
VAR p,j: CARDINAL;
BEGIN
p:=namep[sy]; j:=0;
WHILE (j<25) AND (name[p+j]<>0C) DO
INC(j); q^.txt[j]:=name[p+j-1];
END;
q^.l:=j;
END GiveName;
BEGIN (*Error*)
correct:=FALSE;
IF errdist >= errdistmin
THEN
IF errmsg
THEN
NEW(h); GiveName(h,typ); (*pass near-symbol*)
h^.next:=NIL; e1:=h;
pc1:=altroot; AdjustPc(pc1);
WHILE pc1>0 DO
GetSymInstr(pc1,opcode,sy,nextpc,altpc);
IF opcode<any THEN (*t,nt,nts,ta,nta,ntas*)
NEW(e); GiveName(e,sy); (*pass expected symbol*)
e1^.next:=e; e1:=e; e^.next:=NIL;
END;
pc1:=altpc;
END; (*WHILE*)
ELSE h:=NIL
END; (*IF errmsg*)
-->error procedure(h,line,col);
Triple(altroot); SaveStack;
IF printnodes THEN
WriteString(con,"$ typ newpc newlacts$");
FOR i:=0 TO maxt DO
IF newpc[i]<>0 THEN
WriteCard(con,i,5); WriteCard(con,newpc[i],10);
WriteCard(con,newlacts[i],10); WriteLn(con);
END; (*IF*)
END; (*FOR*)
END; (*IF*)
ELSE RestoreStack;
END;
WHILE newpc[typ]=0 DO
IF printnodes THEN
WriteString(con,"$(skip:"); WriteCard(con,typ,0);
WriteString(con,") ");
END;
NextSym;
END;
pc:=newpc[typ]; altroot:=pc; lacts:=newlacts[typ]; errdist:=0;
END Error;
(* Fill Fill triple list with alt-chain starting at pc
----------------------------------------------------------------------*)
PROCEDURE Fill(pc,lacts:CARDINAL);
VAR
i,sy,nextpc,altpc: CARDINAL;
s: Symbolset;
opcode: Instrtype; (*2.12.,C,Dob*)
BEGIN
AdjustPc(pc);
WHILE pc<>0 DO
GetSymInstr(pc,opcode,sy,nextpc,altpc);
CASE opcode OF
t,ta:
newpc[sy]:=pc; newlacts[sy]:=lacts;
| nt,nta,nts,ntas:
s:=ntsymbols[sy].first;
FOR i:=0 TO maxt DO
IF Match(i,s) THEN newpc[i]:=pc; newlacts[i]:=lacts; END;
END;
IF ntsymbols[sy].del THEN Fill(nextpc,lacts); END;
| eps,epsa:
Fill(nextpc,lacts);
ELSE (*any,anya: nothing*)
END; (*CASE*)
pc:=altpc;
END; (*WHILE*)
END Fill;
(* FillSucc Fill triple list with succ. of alt-chain at pc
---------------------------------------------------------------------*)
PROCEDURE FillSucc(pc,lacts:CARDINAL);
VAR
opcode: Instrtype; (*2.12.,C,Dob*)
sy,nextpc,altpc: CARDINAL;
BEGIN
AdjustPc(pc);
WHILE pc>0 DO (*fill with successors of alternative-starts*)
GetSymInstr(pc,opcode,sy,nextpc,altpc);
IF nextpc>0 THEN Fill(nextpc,lacts); END;
pc:=altpc;
END; (*WHILE*)
END FillSucc;
(* GetSymInstr Get G-code instruction at address pc
---------------------------------------------------------------------*)
PROCEDURE GetSymInstr(pc:CARDINAL; VAR opcode:Instrtype; (*2.12.,C,Dob*)
VAR sy,nextpc,altpc: CARDINAL);
BEGIN (*assert: pc points to a symbol instruction (not ANY,RET,JMP,SEM)*)
opcode:=ORD(code[pc]); (*2.12.,C,Dob*)
IF opcode IN {t,ta,nt,nta,nts,ntas,anya,eps,epsa}
THEN sy:=ORD(code[pc+1]);
ELSE sy:=0;
END;
CASE opcode OF
t,nt,eps:
nextpc:=pc+2; altpc:=0;
| ta,nta,anya,epsa:
nextpc:=pc+4; altpc:=256*ORD(code[pc+2])+ORD(code[pc+3]);
| nts: nextpc:=pc+3; altpc:=0;
| ntas: nextpc:=pc+5; altpc:=256*ORD(code[pc+2])+ORD(code[pc+3]);
| any: nextpc:=pc+1; altpc:=0;
END; (*CASE*)
AdjustPc(nextpc); AdjustPc(altpc);
(*assert: nextpc,altpc point to symbol instructions or are zero*)
END GetSymInstr;
(* Triple Fill triple list
---------------------------------------------------------------------*)
PROCEDURE Triple(altroot:CARDINAL);
VAR i: CARDINAL;
BEGIN
FOR i:=0 TO maxt DO (*clear triple list*)
newpc[i]:=0; newlacts[i]:=0;
END;
FOR i:=1 TO lacts DO (*fill with succ.of stacked nt's*)
(*s[1] contains successor at level 0*)
FillSucc(StackElem(i),i-1);
Fill(StackElem(i),i-1);
END;
FillSucc(altroot,lacts); (*fill with succ.of alt-chain*)
Fill(altroot,lacts); (*fill with current alt-chain*)
END Triple;
(*MODULE SYNTAXSTACK; stack for currently parsed nonterminals
=====================================================================*)
CONST lmaxs = 50; (*max.stack length*)
TYPE Stack = ARRAY[1..lmaxs] OF CARDINAL;
VAR s,olds: Stack;
lacts: CARDINAL; (*stack pointer*)
PROCEDURE Pop(VAR loc: CARDINAL);
BEGIN
IF lacts>0
THEN loc:=s[lacts]; DEC(lacts);
ELSE WriteString(con,"--- Parser stack underflow.$"); HALT;
END;
IF printnodes THEN WriteString(con," pop"); END;
END Pop;
PROCEDURE Push(loc: CARDINAL);
BEGIN
IF lacts<lmaxs
THEN INC(lacts); s[lacts]:=loc;
ELSE WriteString(con,"--- Parser stack overflow.$"); HALT;
END;
IF printnodes THEN WriteString(con," push"); END;
END Push;
PROCEDURE RestoreStack;
BEGIN s:=olds; END RestoreStack;
PROCEDURE SaveStack;
BEGIN olds:=s; END SaveStack;
PROCEDURE StackElem(i:CARDINAL): CARDINAL;
BEGIN RETURN s[i]; END StackElem;
(* Parse Proper syntax analyzer
---------------------------------------------------------------------*)
PROCEDURE Parse(VAR corr:BOOLEAN);
VAR
altroot: CARDINAL; (*root of current alternative chain*)
checksum: CARDINAL; (*table check sum*)
dummy,i,j: CARDINAL;
mustread: BOOLEAN; (*TRUE if next symbol must be read*)
opcode: Instrtype; (*instruction code*) (*2.12.,C,Dob*)
header: ARRAY[1..8] OF CARDINAL;
running: BOOLEAN; (*interpreter state*)
sy: CARDINAL;
s,fn: ARRAY[0..79] OF CHAR;
tab: File; (*table file*)
PROCEDURE ReadByteBlock(VAR f:File; VAR bl:ARRAY OF WORD);(*2.12.,I,Dob*)
VAR i: CARDINAL;
BEGIN
FOR i:=0 TO HIGH(bl) DO; ReadWord(f,bl[i]); END;
END ReadByteBlock;
BEGIN
s:=tabfile;
i:=0; WHILE progdir[i]<>0C DO fn[i]:=progdir[i]; INC(i) END;
j:=0; WHILE s[j]<>0C DO fn[i]:=s[j]; INC(i); INC(j) END;
fn[i]:=0C;
tab := Open(fn, Rmode);
IF status#Done THEN
WriteString(con,"--- Parser tables not found.$"); HALT;
END;
ReadByteBlock(tab,header); (*not used*)
ReadByteBlock(tab,code);
ReadByteBlock(tab,ntsymbols);
ReadByteBlock(tab,epsset);
ReadByteBlock(tab,anyset);
ReadByteBlock(tab,nra);
ReadByteBlock(tab,ps);
IF errmsg THEN
ReadByteBlock(tab,namep);
ReadByteBlock(tab,name);
END;
ReadByteBlock(tab,checksum);
IF check<>checksum THEN
WriteString(con,"--- Old parser version. Recompile it.$"); HALT;
END;
Close(tab);
pc:=startpc; altroot:=pc;
line:=1; col:=1;
correct:=TRUE; mustread:=TRUE; running:=TRUE;
WHILE running DO
opcode:=Next(); (*2.12.,C,Dob*)
IF mustread AND (opcode<=epsa) THEN (*2.12.,C,Dob*)
NextSym; mustread:=FALSE; INC(errdist); altroot:=pc-1;
END;
IF printnodes THEN WriteCard(con,pc-1,5); END;
CASE opcode OF
t:
IF typ=Next()
THEN IF typ=eofsy (*t recognized*)
THEN running:=FALSE;
ELSE mustread:=TRUE;
END;
ELSE Error(pc,altroot);
END;
| ta:
IF typ=Next()
THEN dummy:=Next2(); mustread:=TRUE; (*t recognized*)
ELSE pc:=Next2(); (*try alternative*)
END;
| nt,nts:
sy:=Next();
IF Match(typ,ntsymbols[sy].first) OR ntsymbols[sy].del
THEN (*right nt, parse it*)
IF opcode=nts THEN Semant(Next()); END;
Push(pc); pc:=ntsymbols[sy].startpc;
altroot:=pc;
ELSE Error(pc,altroot);
END;
| nta,ntas:
sy:=Next();
IF Match(typ,ntsymbols[sy].first)
THEN (*right nt, parse it*)
dummy:=Next2();
IF opcode=ntas THEN Semant(Next()); END;
Push(pc); pc:=ntsymbols[sy].startpc;
altroot:=pc;
ELSE pc:=Next2(); (*try alternative*)
END;
| any: mustread:=TRUE; (*any recognized*)
| anya:
IF Match(typ,anyset[Next()])
THEN dummy:=Next2(); mustread:=TRUE; (*any recognized*)
ELSE pc:=Next2();
END;
| eps:
IF NOT Match(typ,epsset[Next()]) THEN
Error(pc,altroot);
END;
| epsa:
IF Match(typ,epsset[Next()])
THEN dummy:=Next2(); (*eps recognized*)
ELSE pc:=Next2();
END;
| jmp: pc:=Next2(); (*goto successor*)
| ret: Pop(pc); altroot:=pc; (*end of nt*)
ELSE (*sem*)
IF correct THEN Semant(opcode); END; (*2.12.,C,Dob*)
END; (*CASE*)
END; (*WHILE running*)
corr:=correct;
END Parse;
BEGIN
printinput:=FALSE;
printnodes:=FALSE;
errdist:=100;
lacts:=0;
END -->modulename.