(* 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)
08 (07.11.86) ByteBlockIO added, ATARI file names          La   
09 (04.12.86) Alignment in Symbolnode corrected            La       
----------------------------------------------------------------------*)
IMPLEMENTATION MODULE Oberonsyn;

FROM FileIO        IMPORT con, WriteCard, WriteLn, WriteString;
FROM FileSystem    IMPORT Close, File, Lookup, Response;
FROM SYSTEM        IMPORT WORD, BITSET;                  (*2.12.,I,Dob*)
FROM Storage       IMPORT ALLOCATE, DEALLOCATE;          (*2.12.,D,Dob*)
FROM ByteBlockIO   IMPORT ReadByteBlock;

FROM Oberonsem IMPORT Semant;
FROM OberonLex      IMPORT GetSy;
FROM Errors      IMPORT SyntaxError, Errorptr;

CONST
  check    =42254;
  eofsy    =   0;
  eolsy    =  67;
  errmsg   = TRUE;
  maxname  =1151;
  maxnamep = 121;
  maxcode  =1043;
  maxany   =   1;
  maxeps   =  29;
  maxt     =  66;
  maxp     =  67;
  maxs     = 121;
  startpc  =1039;
  tabfile  = 'Oberontab';



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*)
    dummy,                     (*for correct alignment*)     (*4.12.86 La*)
    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*)
  correct1:   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*)
  lacts:     CARDINAL;         (*stack pointer*)
  (*typ,at,col and line are declared in the definition module*)

PROCEDURE RestoreStack;FORWARD;
PROCEDURE SaveStack;FORWARD;
PROCEDURE StackElem(i:CARDINAL): CARDINAL;FORWARD;

(* 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
    GetSy(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 GetSy(at[i]); END;
    IF typ=eolsy THEN INC(line); END;
    IF typ>maxt THEN
      IF correct1 AND (ps[typ].sem2<>0) THEN Semant(ps[typ].sem2); END;
      IF correct1 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
=====================================================================*)
FROM SYNTAXSTACK IMPORT StackElem;
IMPORT                                                   (*2.12.,C,Dob*)
  t, ta, nt, nta, nts, ntas, any, anya, eps, epsa, jmp, ret, Instrtype,
  code, col, con, correct1, errmsg, Errorptr, line, Match, maxt,
  name, namep, NextSym, ntsymbols, printnodes, RestoreStack, SaveStack,
  Symbolset, SyntaxError, typ, WriteCard, WriteLn, WriteString,
  ALLOCATE, DEALLOCATE, lacts;
EXPORT errdist, Error;
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*)


PROCEDURE GetSymInstr(pc:CARDINAL; VAR opcode:Instrtype; (*2.12.,C,Dob*)
                      VAR sy,nextpc,altpc: CARDINAL);FORWARD;
PROCEDURE Triple(altroot:CARDINAL);FORWARD;

(* 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*)
  correct1:=FALSE;
  IF errdist >= errdistmin
    THEN
      IF errmsg
        THEN
          ALLOCATE(h, SIZE(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*)
              ALLOCATE(e, SIZE(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*)
      SyntaxError(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;

BEGIN  (*ERRORS*)
  errdist:=100;
  END ERRORS;



MODULE SYNTAXSTACK;  (* stack for currently parsed nonterminals
=====================================================================*)
IMPORT con, printnodes, WriteString, lacts;
EXPORT Push, Pop, SSRestoreStack, SSSaveStack, SSStackElem;
CONST  lmaxs = 50;                         (*max.stack length*)
TYPE   Stack = ARRAY[1..lmaxs] OF CARDINAL;
VAR    s,olds: Stack;

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 SSRestoreStack;
BEGIN s:=olds; END SSRestoreStack;

PROCEDURE SSSaveStack;
BEGIN olds:=s; END SSSaveStack;

PROCEDURE SSStackElem(i:CARDINAL): CARDINAL;
BEGIN RETURN s[i]; END SSStackElem;

BEGIN
  lacts:=0;
  END SYNTAXSTACK;

PROCEDURE StackElem(i:CARDINAL): CARDINAL;
BEGIN
  RETURN SSStackElem(i);
END StackElem;  

PROCEDURE RestoreStack;
BEGIN SSRestoreStack; END RestoreStack;

PROCEDURE SaveStack;
BEGIN SSSaveStack; END SaveStack;


(* Parse         Proper syntax analyzer
---------------------------------------------------------------------*)
PROCEDURE Parse(VAR correct:BOOLEAN);
VAR
  altroot: CARDINAL;     (*root of current alternative chain*)
  checksum:CARDINAL;     (*table check sum*)
  dummy:   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;
  tab:     File;         (*table file*)

BEGIN
  Lookup(tab,tabfile,1024,FALSE);
  IF tab.res<>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
    WriteCard(con, check, 5);
    WriteCard(con, checksum, 5);
    WriteString(con,"--- Old parser version. Recompile it.$"); 
    HALT;
    END;
  Close(tab);

  pc:=startpc; altroot:=pc;
  line:=1; col:=1;
  correct1:=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 correct1 THEN Semant(opcode); END;             (*2.12.,C,Dob*)
      END; (*CASE*)
    END; (*WHILE running*)
  correct:=correct1;
  END Parse;

BEGIN
  printinput:=FALSE;
  printnodes:=FALSE;
  END Oberonsyn.