home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / modula2 / alexcoco / cocosynf < prev    next >
Encoding:
Modula Implementation  |  1987-07-16  |  14.7 KB  |  440 lines
  1. (* cocosyn  General table driven syntax analyzer           Re
  2.    =======  ====================================           Moe 21.12.83
  3. 01 (21.12.83) First version (rewritten from PL/M)
  4. 02 (28.02.84) New interface for input and errors
  5. 03 (02.04.84) Error in EOL-processing corrected
  6. 04 (08.05.84) New EOL-processing
  7. 05 (23.07.84) For G-Code
  8. 06 (30.08.84) Error recovery simplified
  9. 07 (05.04.85) New G-Code instruction EPSA (ANYA modified)
  10. ----------------------------------------------------------------------*)
  11. IMPLEMENTATION MODULE -->modulename;
  12.  
  13. FROM FileIO        IMPORT con, WriteCard, WriteLn, WriteString;
  14. FROM FileSystem    IMPORT Open, ReadWord;
  15. FROM Files         IMPORT Close, File, Mode, status, FileStatus;
  16.                                                          (*2.12.,I,Dob*)
  17. FROM SYSTEM        IMPORT WORD;                          (*2.12.,I,Dob*)
  18. FROM Storage       IMPORT ALLOCATE, DEALLOCATE;          (*2.12.,D,Dob*)
  19.  
  20. FROM -->semantic analyzer IMPORT Semant;
  21. FROM -->input module      IMPORT -->input procedure;
  22. FROM -->error module      IMPORT -->error procedure, Errorptr;
  23.  
  24. -->declarations
  25.  
  26. CONST        (*opcodes for G-code-instructions*)         (*2.12.,I,Dob*)
  27.   t    = 0; ta   = 1; nt   = 2; nta  = 3;
  28.   nts  = 4; ntas = 5; any  = 6; anya = 7;
  29.   eps  = 8; epsa = 9; jmp  =10; ret  =11;
  30.  
  31. TYPE
  32.   Attributenumbers = ARRAY[0..maxp] OF CARDINAL;
  33.   Instrtype        = [0..255];                           (*2.12.,C,Dob*)
  34.   Namepointers     = ARRAY[0..maxnamep] OF CARDINAL;
  35.   Namelist         = ARRAY[1..maxname] OF CHAR;
  36.   Pragma           = RECORD    (*semantics for a pragma*)
  37.     sem2,sem3: CARDINAL;
  38.     END;
  39.   Pragmalist       = ARRAY[maxt..maxp] OF Pragma;
  40.   Symbolset        = ARRAY[0..maxt DIV 16] OF BITSET;
  41.                                (*set of terminals*)
  42.   Symbolnode       = RECORD    (*symbol information (only for nt)*)
  43.     startpc: CARDINAL;         (*start node of rule for nt*)
  44.     del:     BOOLEAN;          (*TRUE, if nt is deletable*)
  45.     first:   Symbolset;        (*terminals causing to analyze this nt*)
  46.     END;
  47.   Symbollist       = ARRAY[maxp+1..maxs] OF Symbolnode;
  48.  
  49. VAR
  50.   anyset:    ARRAY[1..maxany] OF Symbolset;
  51.   code:      ARRAY[1..maxcode] OF CHAR; (*G-code area*)
  52.   correct:   BOOLEAN;          (*error indicator*)
  53.   epsset:    ARRAY[1..maxeps] OF Symbolset;
  54.   name:      Namelist;         (*symbol names*)
  55.   namep:     Namepointers;     (*pointers to symbol names*)
  56.   nra:       Attributenumbers; (*nr.of attributes for t,pr-symbols*)
  57.   ntsymbols: Symbollist;       (*nonterminals information*)
  58.   pc:        CARDINAL;         (*program counter*)
  59.   ps:        Pragmalist;       (*semantics for pragmas*)
  60.   (*typ,at,col and line are declared in the definition module*)
  61.  
  62.  
  63. (* Match     Check if sy is member of the specified set
  64. ---------------------------------------------------------------------*)
  65. PROCEDURE Match(sy:CARDINAL; set:Symbolset): BOOLEAN;
  66. BEGIN RETURN (sy MOD 16) IN set[sy DIV 16]; END Match;
  67.  
  68.  
  69. (* Next      Get next byte from code area
  70. ---------------------------------------------------------------------*)
  71. PROCEDURE Next(): CARDINAL;
  72. BEGIN INC(pc); RETURN ORD(code[pc-1]); END Next;
  73.  
  74.  
  75. (* Next2     Get next word from code area
  76. ---------------------------------------------------------------------*)
  77. PROCEDURE Next2(): CARDINAL;
  78. BEGIN
  79.   INC(pc,2); RETURN 256*ORD(code[pc-2]) + ORD(code[pc-1]);
  80.   END Next2;
  81.  
  82.  
  83. (* NextSym    Get next symbol
  84. -----------------------------------------------------------------------*)
  85. PROCEDURE NextSym;
  86. VAR token,i: CARDINAL;
  87. BEGIN
  88.   REPEAT
  89.     -->input procedure(token);
  90.     typ:=token DIV 256; col:=token MOD 256;
  91.     IF printinput THEN
  92.       WriteString(con,"$(in:"); WriteCard(con,typ,3);
  93.       WriteString(con,") ");
  94.       IF printnodes THEN
  95.         WriteCard(con,lacts,3); WriteString(con,"| ");
  96.         END;
  97.       END;
  98.     FOR i:=1 TO nra[typ] DO -->input procedure(at[i]); END;
  99.     IF typ=eolsy THEN INC(line); END;
  100.     IF typ>maxt THEN
  101.       IF correct AND (ps[typ].sem2<>0) THEN Semant(ps[typ].sem2); END;
  102.       IF correct AND (ps[typ].sem3<>0) THEN Semant(ps[typ].sem3); END;
  103.       END;
  104.     UNTIL (typ<=maxt) OR (typ=eofsy);
  105.   END NextSym;
  106.  
  107. (*MODULE ERRORS;    Procedures for recovery after syntax errors
  108. =====================================================================*)
  109.  
  110. CONST errdistmin = 2;   (*min.distance between two errors*)
  111. VAR
  112.   errdist:  CARDINAL;                      (*current error distance*)
  113.   newlacts: ARRAY [0..maxt] OF CARDINAL;   (*new stack length*)
  114.   newpc:    ARRAY [0..maxt] OF CARDINAL;   (*pc after recovery*)
  115.  
  116.  
  117. (* AdjustPc    Adjust pc to next symbol instruction
  118. ---------------------------------------------------------------------*)
  119. PROCEDURE AdjustPc(VAR pc:CARDINAL);
  120. BEGIN
  121.   IF pc=0 THEN RETURN; END;
  122.   LOOP
  123.     CASE ORD(code[pc]) OF                                (*2.12.,C,Dob*)
  124.       t,ta,nt,nta,nts,ntas,any,anya,eps,epsa: EXIT;
  125.     | jmp: pc:=256*ORD(code[pc+1])+ORD(code[pc+2]);
  126.     | ret: pc:=0; EXIT;
  127.       ELSE INC(pc); (*sem*)
  128.       END;
  129.     END;
  130.   END AdjustPc;
  131.  
  132.  
  133. (* Error       Report syntax error
  134. ---------------------------------------------------------------------*)
  135. PROCEDURE Error(VAR pc,altroot:CARDINAL);
  136. VAR
  137.   e,e1,h: Errorptr;
  138.   i,j: CARDINAL;
  139.   opcode: Instrtype;                                     (*2.12.,C,Dob*)
  140.   sy,nextpc,altpc,pc1: CARDINAL;
  141.  
  142.     PROCEDURE GiveName(q:Errorptr; sy:CARDINAL);
  143.     VAR p,j: CARDINAL;
  144.     BEGIN
  145.       p:=namep[sy]; j:=0;
  146.       WHILE (j<25) AND (name[p+j]<>0C) DO
  147.         INC(j); q^.txt[j]:=name[p+j-1];
  148.         END;
  149.       q^.l:=j;
  150.       END GiveName;
  151.  
  152. BEGIN (*Error*)
  153.   correct:=FALSE;
  154.   IF errdist >= errdistmin
  155.     THEN
  156.       IF errmsg
  157.         THEN
  158.           NEW(h); GiveName(h,typ);             (*pass near-symbol*)
  159.           h^.next:=NIL; e1:=h;
  160.           pc1:=altroot;  AdjustPc(pc1);
  161.           WHILE pc1>0 DO
  162.             GetSymInstr(pc1,opcode,sy,nextpc,altpc);
  163.             IF opcode<any THEN   (*t,nt,nts,ta,nta,ntas*)
  164.               NEW(e); GiveName(e,sy);          (*pass expected symbol*)
  165.               e1^.next:=e; e1:=e; e^.next:=NIL;
  166.               END;
  167.             pc1:=altpc;
  168.             END; (*WHILE*)
  169.         ELSE h:=NIL
  170.         END; (*IF errmsg*)
  171.       -->error procedure(h,line,col);
  172.       Triple(altroot); SaveStack;
  173.       IF printnodes THEN
  174.         WriteString(con,"$   typ    newpc  newlacts$");
  175.         FOR i:=0 TO maxt DO
  176.           IF newpc[i]<>0 THEN
  177.             WriteCard(con,i,5); WriteCard(con,newpc[i],10);
  178.             WriteCard(con,newlacts[i],10); WriteLn(con);
  179.             END; (*IF*)
  180.           END; (*FOR*)
  181.         END; (*IF*)
  182.     ELSE RestoreStack;
  183.     END;
  184.   WHILE newpc[typ]=0 DO
  185.     IF printnodes THEN
  186.       WriteString(con,"$(skip:"); WriteCard(con,typ,0);
  187.       WriteString(con,") ");
  188.       END;
  189.     NextSym;
  190.     END;
  191.   pc:=newpc[typ]; altroot:=pc; lacts:=newlacts[typ]; errdist:=0;
  192.   END Error;
  193.  
  194.  
  195. (* Fill        Fill triple list with alt-chain starting at pc
  196. ----------------------------------------------------------------------*)
  197. PROCEDURE Fill(pc,lacts:CARDINAL);
  198. VAR
  199.   i,sy,nextpc,altpc: CARDINAL;
  200.   s: Symbolset;
  201.   opcode: Instrtype;                                     (*2.12.,C,Dob*)
  202. BEGIN
  203.   AdjustPc(pc);
  204.   WHILE pc<>0 DO
  205.     GetSymInstr(pc,opcode,sy,nextpc,altpc);
  206.     CASE opcode OF
  207.       t,ta:
  208.         newpc[sy]:=pc; newlacts[sy]:=lacts;
  209.     | nt,nta,nts,ntas:
  210.         s:=ntsymbols[sy].first;
  211.         FOR i:=0 TO maxt DO
  212.           IF Match(i,s) THEN newpc[i]:=pc; newlacts[i]:=lacts; END;
  213.           END;
  214.         IF ntsymbols[sy].del THEN Fill(nextpc,lacts); END;
  215.     | eps,epsa:
  216.         Fill(nextpc,lacts);
  217.       ELSE (*any,anya: nothing*)
  218.       END; (*CASE*)
  219.     pc:=altpc;
  220.     END; (*WHILE*)
  221.   END Fill;
  222.  
  223.  
  224. (* FillSucc      Fill triple list with succ. of alt-chain at pc
  225. ---------------------------------------------------------------------*)
  226. PROCEDURE FillSucc(pc,lacts:CARDINAL);
  227. VAR
  228.   opcode: Instrtype;                                     (*2.12.,C,Dob*)
  229.   sy,nextpc,altpc: CARDINAL;
  230. BEGIN
  231.   AdjustPc(pc);
  232.   WHILE pc>0 DO      (*fill with successors of alternative-starts*)
  233.     GetSymInstr(pc,opcode,sy,nextpc,altpc);
  234.     IF nextpc>0 THEN Fill(nextpc,lacts); END;
  235.     pc:=altpc;
  236.     END; (*WHILE*)
  237.   END FillSucc;
  238.  
  239.  
  240. (* GetSymInstr  Get G-code instruction at address pc
  241. ---------------------------------------------------------------------*)
  242. PROCEDURE GetSymInstr(pc:CARDINAL; VAR opcode:Instrtype; (*2.12.,C,Dob*)
  243.                       VAR sy,nextpc,altpc: CARDINAL);
  244. BEGIN (*assert: pc points to a symbol instruction (not ANY,RET,JMP,SEM)*)
  245.   opcode:=ORD(code[pc]);                                 (*2.12.,C,Dob*)
  246.   IF opcode IN {t,ta,nt,nta,nts,ntas,anya,eps,epsa}
  247.     THEN sy:=ORD(code[pc+1]);
  248.     ELSE sy:=0;
  249.     END;
  250.   CASE opcode OF
  251.     t,nt,eps:
  252.           nextpc:=pc+2;  altpc:=0;
  253.   | ta,nta,anya,epsa:
  254.           nextpc:=pc+4;  altpc:=256*ORD(code[pc+2])+ORD(code[pc+3]);
  255.   | nts:  nextpc:=pc+3;  altpc:=0;
  256.   | ntas: nextpc:=pc+5;  altpc:=256*ORD(code[pc+2])+ORD(code[pc+3]);
  257.   | any:  nextpc:=pc+1;  altpc:=0;
  258.     END; (*CASE*)
  259.   AdjustPc(nextpc); AdjustPc(altpc);
  260.   (*assert: nextpc,altpc point to symbol instructions or are zero*)
  261.   END GetSymInstr;
  262.  
  263.  
  264. (* Triple        Fill triple list
  265. ---------------------------------------------------------------------*)
  266. PROCEDURE Triple(altroot:CARDINAL);
  267. VAR i: CARDINAL;
  268. BEGIN
  269.   FOR i:=0 TO maxt DO              (*clear triple list*)
  270.     newpc[i]:=0; newlacts[i]:=0;
  271.     END;
  272.   FOR i:=1 TO lacts DO             (*fill with succ.of stacked nt's*)
  273.     (*s[1] contains successor at level 0*)
  274.     FillSucc(StackElem(i),i-1);
  275.     Fill(StackElem(i),i-1);
  276.     END;
  277.   FillSucc(altroot,lacts);         (*fill with succ.of alt-chain*)
  278.   Fill(altroot,lacts);             (*fill with current alt-chain*)
  279.   END Triple;
  280.  
  281.  
  282.  
  283. (*MODULE SYNTAXSTACK;   stack for currently parsed nonterminals
  284. =====================================================================*)
  285. CONST  lmaxs = 50;                         (*max.stack length*)
  286. TYPE   Stack = ARRAY[1..lmaxs] OF CARDINAL;
  287. VAR    s,olds: Stack;
  288.        lacts:  CARDINAL;                   (*stack pointer*)
  289.  
  290. PROCEDURE Pop(VAR loc: CARDINAL);
  291. BEGIN
  292.   IF lacts>0
  293.     THEN loc:=s[lacts]; DEC(lacts);
  294.     ELSE WriteString(con,"--- Parser stack underflow.$"); HALT;
  295.     END;
  296.   IF printnodes THEN WriteString(con,"  pop"); END;
  297.   END Pop;
  298.  
  299. PROCEDURE Push(loc: CARDINAL);
  300. BEGIN
  301.   IF lacts<lmaxs
  302.     THEN INC(lacts); s[lacts]:=loc;
  303.     ELSE WriteString(con,"--- Parser stack overflow.$"); HALT;
  304.     END;
  305.   IF printnodes THEN WriteString(con," push"); END;
  306.   END Push;
  307.  
  308. PROCEDURE RestoreStack;
  309. BEGIN s:=olds; END RestoreStack;
  310.  
  311. PROCEDURE SaveStack;
  312. BEGIN olds:=s; END SaveStack;
  313.  
  314. PROCEDURE StackElem(i:CARDINAL): CARDINAL;
  315. BEGIN RETURN s[i]; END StackElem;
  316.  
  317.  
  318.  
  319. (* Parse         Proper syntax analyzer
  320. ---------------------------------------------------------------------*)
  321. PROCEDURE Parse(VAR corr:BOOLEAN);
  322. VAR
  323.   altroot:   CARDINAL;     (*root of current alternative chain*)
  324.   checksum:  CARDINAL;     (*table check sum*)
  325.   dummy,i,j: CARDINAL;
  326.   mustread:  BOOLEAN;      (*TRUE if next symbol must be read*)
  327.   opcode:    Instrtype;    (*instruction code*)            (*2.12.,C,Dob*)
  328.   header:    ARRAY[1..8] OF CARDINAL;
  329.   running:   BOOLEAN;      (*interpreter state*)
  330.   sy:        CARDINAL;
  331.   s,fn:      ARRAY[0..79] OF CHAR;
  332.   tab:       File;         (*table file*)
  333.  
  334. PROCEDURE ReadByteBlock(VAR f:File; VAR bl:ARRAY OF WORD);(*2.12.,I,Dob*)
  335. VAR i: CARDINAL;
  336. BEGIN
  337.   FOR i:=0 TO HIGH(bl) DO; ReadWord(f,bl[i]); END;
  338.   END ReadByteBlock;
  339.  
  340. BEGIN
  341.   s:=tabfile;
  342.   i:=0; WHILE progdir[i]<>0C DO fn[i]:=progdir[i]; INC(i) END;
  343.   j:=0; WHILE s[j]<>0C DO fn[i]:=s[j]; INC(i); INC(j) END;
  344.   fn[i]:=0C;
  345.   tab := Open(fn, Rmode);
  346.   IF status#Done THEN
  347.     WriteString(con,"--- Parser tables not found.$"); HALT;
  348.     END;
  349.   ReadByteBlock(tab,header);  (*not used*)
  350.   ReadByteBlock(tab,code);
  351.   ReadByteBlock(tab,ntsymbols);
  352.   ReadByteBlock(tab,epsset);
  353.   ReadByteBlock(tab,anyset);
  354.   ReadByteBlock(tab,nra);
  355.   ReadByteBlock(tab,ps);
  356.   IF errmsg THEN
  357.     ReadByteBlock(tab,namep);
  358.     ReadByteBlock(tab,name);
  359.     END;
  360.   ReadByteBlock(tab,checksum);
  361.   IF check<>checksum THEN
  362.     WriteString(con,"--- Old parser version. Recompile it.$"); HALT;
  363.     END;
  364.   Close(tab);
  365.  
  366.   pc:=startpc; altroot:=pc;
  367.   line:=1; col:=1;
  368.   correct:=TRUE; mustread:=TRUE; running:=TRUE;
  369.  
  370.   WHILE running DO
  371.     opcode:=Next();                                      (*2.12.,C,Dob*)
  372.     IF mustread AND (opcode<=epsa) THEN                  (*2.12.,C,Dob*)
  373.       NextSym; mustread:=FALSE; INC(errdist); altroot:=pc-1;
  374.       END;
  375.     IF printnodes THEN WriteCard(con,pc-1,5); END;
  376.     CASE opcode OF
  377.       t:
  378.         IF typ=Next()
  379.           THEN IF typ=eofsy                    (*t recognized*)
  380.             THEN running:=FALSE;
  381.             ELSE mustread:=TRUE;
  382.             END;
  383.           ELSE Error(pc,altroot);
  384.           END;
  385.     | ta:
  386.         IF typ=Next()
  387.           THEN dummy:=Next2(); mustread:=TRUE; (*t recognized*)
  388.           ELSE pc:=Next2();                    (*try alternative*)
  389.           END;
  390.     | nt,nts:
  391.         sy:=Next();
  392.         IF Match(typ,ntsymbols[sy].first) OR ntsymbols[sy].del
  393.           THEN                                 (*right nt, parse it*)
  394.             IF opcode=nts THEN Semant(Next()); END;
  395.             Push(pc); pc:=ntsymbols[sy].startpc;
  396.             altroot:=pc;
  397.           ELSE Error(pc,altroot);
  398.           END;
  399.     | nta,ntas:
  400.         sy:=Next();
  401.         IF Match(typ,ntsymbols[sy].first)
  402.           THEN                                 (*right nt, parse it*)
  403.             dummy:=Next2();
  404.             IF opcode=ntas THEN Semant(Next()); END;
  405.             Push(pc); pc:=ntsymbols[sy].startpc;
  406.             altroot:=pc;
  407.           ELSE pc:=Next2();                    (*try alternative*)
  408.           END;
  409.     | any:  mustread:=TRUE;                    (*any recognized*)
  410.     | anya:
  411.         IF Match(typ,anyset[Next()])
  412.           THEN dummy:=Next2(); mustread:=TRUE; (*any recognized*)
  413.           ELSE pc:=Next2();
  414.           END;
  415.     | eps:
  416.         IF NOT Match(typ,epsset[Next()]) THEN
  417.           Error(pc,altroot);
  418.           END;
  419.     | epsa:
  420.         IF Match(typ,epsset[Next()])
  421.           THEN dummy:=Next2();                 (*eps recognized*)
  422.           ELSE pc:=Next2();
  423.           END;
  424.     | jmp:  pc:=Next2();                       (*goto successor*)
  425.     | ret:  Pop(pc); altroot:=pc;              (*end of nt*)
  426.       ELSE (*sem*)
  427.         IF correct THEN Semant(opcode); END;             (*2.12.,C,Dob*)
  428.       END; (*CASE*)
  429.     END; (*WHILE running*)
  430.   corr:=correct;
  431.   END Parse;
  432.  
  433. BEGIN
  434.   printinput:=FALSE;
  435.   printnodes:=FALSE;
  436.   errdist:=100;
  437.   lacts:=0;
  438.   END -->modulename.
  439.  
  440.