(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*     Implementation for Lilith         *
*                                       *
*                                       *
*     M2SymFile:                        *
*                                       * 
*     Generation of symbolfiles         *
*     of separately compiled modules    *
*                                       * 
*     Version C18 of 29.09.81           *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zuerich                       *
*     CH-8092 Zuerich                   *
*                                       *
*     Modified by MJJ to make the       *
*     symfile a character file          *
****************************************)

IMPLEMENTATION MODULE M2SymFile;   (* LG *)

  (* $T- *)

  IMPORT
    NewStreams, Storage, Conversions, 
    MCBase, MCPublic, MCSymFileDefs, P1IOId;

PROCEDURE SymFile;

  MODULE SymbolFileHandling;

    FROM NewStreams IMPORT
      STREAM, Connect, Reset, WriteChar, EndWrite, Disconnect;
    FROM Conversions IMPORT ConvertOctal;
    FROM MCBase IMPORT Spellix;
    FROM MCPublic IMPORT symFile, compstat, Compilerstatus;
    FROM MCSymFileDefs IMPORT SymFileSymbols;
    FROM P1IOId IMPORT maxspix, IdSetPos, IdGetChar;

    EXPORT
      SymPutS, SymPutNumber, SymPutCard, SymPutStr, SymPutIdent,
      InitSym, TermSym;
  
    TYPE Byte = [0..377B];

    VAR symf : STREAM;

    PROCEDURE WriteSym(b: Byte);
    BEGIN
        WriteChar(symf, CHAR(b));
    END WriteSym;

    PROCEDURE SymPutS(s: SymFileSymbols);
    BEGIN
      WriteSym(ORD(s));
    END SymPutS;
    
    PROCEDURE SymPutNumber(w: CARDINAL);
    (*  Wordlength independent representation of words *)
    VAR k: CARDINAL;
    BEGIN
      k := w DIV 128;
      IF k=0 THEN
          WriteChar(symf, CHAR(w));
      ELSE
          WriteChar(symf, CHAR((w MOD 128) + 128));
  	  SymPutNumber(k);
      END;
    END SymPutNumber;

    PROCEDURE SymPutCard(c: CARDINAL);
    BEGIN
      SymPutS(normalconstSS);
      SymPutNumber(c);
    END SymPutCard;

    PROCEDURE SymPutStr(addr,length: CARDINAL);
      TYPE Bufptr = POINTER TO ARRAY [1 .. 100] OF CHAR;
      VAR string : Bufptr;
          ix : CARDINAL;
    BEGIN
      SymPutS(stringconstSS);
      string := Bufptr(addr);
      FOR ix := 1 TO length + 1 DO WriteSym(ORD(string^[ix])) END;
      (* terminating 0C is written from string^[length + 1] *)
    END SymPutStr;

    PROCEDURE SymPutIdent(sx: Spellix);
      VAR ch : CHAR;
          str : ARRAY [0 .. 5] OF CHAR;
          ix : CARDINAL;
    BEGIN
      SymPutS(identSS);
      IF INTEGER(sx) < 0 THEN (* dummy type name *)
        ConvertOctal(sx,6,str);
        FOR ix := 0 TO 5 DO WriteSym(ORD(str[ix])) END;
      ELSIF sx <= maxspix THEN (* identifier *)
        IdSetPos(sx);
        IdGetChar(ch);
        WHILE ch <> ' ' DO WriteSym(ORD(ch)); IdGetChar(ch) END;
      END; 
      WriteSym(0);
    END SymPutIdent;
  
    PROCEDURE InitSym; 
    BEGIN
      INCL(compstat,syms); (* status: symbolfile is generated *)
      Connect(symf,symFile,FALSE);
      Reset(symf);
    END InitSym;

    PROCEDURE TermSym;
    BEGIN
      SymPutS(endfileSS);
      EndWrite(symf);
      Disconnect(symf,FALSE);
    END TermSym;

  END SymbolFileHandling;

  MODULE SymbolDump;

    FROM Storage IMPORT ALLOCATE, DEALLOCATE;
    FROM MCBase IMPORT
      Idptr, Stptr, Idclass, Structform,
      Spellix, Constval,
      mainmodp, root, sysmodp,
      Varkind, Kindvar, Recpart;
    FROM MCSymFileDefs IMPORT symFileKey, SymFileSymbols;
    FROM SymbolFileHandling IMPORT
      SymPutS, SymPutNumber, SymPutCard, SymPutStr, SymPutIdent,
      InitSym, TermSym;

    TYPE Nlptr = POINTER TO Namelist;
         Namelist = RECORD
                      namep : Idptr;
                      nxtnp : Nlptr;
                    END;
         Mlptr = POINTER TO Modlist;
         Modlist = RECORD
                     mnamp : Idptr;
                     nxtmp : Mlptr;
                     fstnp : Nlptr;
                     lstnp : Nlptr;
                   END;
    VAR mlroot : Mlptr;  (* root of module list *)
        dumix : INTEGER; (* index for dummy identifier i.e. negative numbers *)

    PROCEDURE EnterDumpList(namp: Idptr);
      VAR flist : Nlptr; (* the list of potential forward references *)
          mp: Mlptr;
          np, frnp : Nlptr;

      PROCEDURE GenDummyType(sp: Stptr);
        VAR ip : Idptr;
      BEGIN (* generate dummy type name for a not explicit declared type *)
        DEC(dumix); (* new dummy identifier *)
        NEW(ip,types);
        WITH ip^ DO  
          name := CARDINAL(dumix);
          link := NIL;
          globmodp := mainmodp;
          idtyp := sp;
          klass := types;
        END; (* WITH *)
        sp^.stidp := ip;
      END GenDummyType;

      PROCEDURE EnterName(namp: Idptr);
        VAR mp : Mlptr;
            np : Nlptr;
      BEGIN
        IF namp <> NIL THEN (* enter referrenced name in module list *)
          NEW(np);
          np^.namep := namp;
          np^.nxtnp := NIL;
          mp := mlroot;
          WHILE mp^.mnamp <> namp^.globmodp DO mp := mp^.nxtmp END;
          WITH mp^ DO
            IF fstnp = NIL THEN fstnp := np;
            ELSE lstnp^.nxtnp := np;
            END;
            lstnp := np
          END; (* WITH *)
        END;
      END EnterName;
      
      PROCEDURE ForwardReference(namp: Idptr);
        (* record a forward (pointer) reference to a structure to be
           checked after the explicit name list has been completed. *)
        VAR
          frnp : Nlptr;
        BEGIN
          NEW(frnp);
          WITH frnp^ DO
            namep := namp;
            nxtnp := flist
          END (* WITH *);
          flist := frnp
        END ForwardReference;

      PROCEDURE StructCheck(strp: Stptr);
        (* check if the names belonging to the structure are already *)
        (* entered into the separate compilation dump list *)
        VAR ip : Idptr;
            sp : Stptr;
      BEGIN
        IF NOT strp^.inlist THEN
          WITH strp^ DO
            inlist := TRUE;
            CASE form OF
              enums,hides:
                EnterName(stidp);
             |subranges:
                StructCheck(scalp);
                EnterName(stidp);
             |pointers:
                EnterName(stidp);
                IF elemp^.stidp = NIL THEN 
                  GenDummyType(elemp);
                  StructCheck(elemp)
                ELSE
                  ForwardReference(elemp^.stidp)
                END (* IF *);
             |sets:
                StructCheck(basep);
                EnterName(stidp);
             |arrays:
                StructCheck(elp);
                IF NOT dyn THEN
                  StructCheck(ixp);
                  EnterName(stidp);
                END;
             |records:
                CASE rpart OF
                  fixedpart:
                    ip := fieldp;
                    WHILE ip <> NIL DO
                      WITH ip^ DO
                        IF idtyp^.stidp = NIL THEN GenDummyType(idtyp) END;
                        StructCheck(idtyp);
                        ip := link;
                      END; (* WITH *)
                    END;
                    IF tagp <> NIL THEN StructCheck(tagp) END;
                    EnterName(stidp);
                 |tagfield:
                    StructCheck(tagtyp);
                    sp := fstvarp;
                    WHILE sp <> NIL DO
                      IF sp^.subtagp <> NIL THEN
                        StructCheck(sp^.subtagp);
                      END;
                      sp := sp^.nxtvarp;
                    END;
                END; (* CASE *)
             |proctypes:
                ip := fstparam;
                WHILE ip <> NIL DO
                  StructCheck(ip^.idtyp);
                  ip := ip^.vlink;
                END;
                IF rkind = funcs THEN StructCheck(funcp) END;
                EnterName(stidp);
            END; (* CASE *)
          END; (* WITH *)
        END;
      END StructCheck;

      PROCEDURE IdentCheck(namp: Idptr);
      BEGIN
        WITH namp^ DO
          CASE klass OF
            types:
              StructCheck(idtyp);
              (* check IF a second name of this type exists *)
              IF namp <> idtyp^.stidp THEN EnterName(namp) END;
           |consts:
              StructCheck(idtyp);
              EnterName(namp);
           |vars:
              IF idtyp^.stidp = NIL THEN GenDummyType(idtyp) END;
              StructCheck(idtyp);
              EnterName(namp);
           |pures,funcs:
              StructCheck(idtyp)
           |indrct: IdentCheck(nxtidp);
            ELSE (* unknown,mods,fields *)
          END; (* CASE *)
        END; (* WITH *)
      END IdentCheck;

    BEGIN (* EnterDumpList *)
      IF namp <> NIL THEN
        flist := NIL;
        REPEAT (* deal with the names supplied explicitly *)
          IdentCheck(namp);
          namp := namp^.link;
        UNTIL namp = NIL;
        WHILE flist <> NIL DO (* deal with outstanding forward refs *)
          frnp := flist; (* remove ref from chain before considering it *)
          flist := frnp^.nxtnp;
          mp := mlroot; (* search module dump list for corresponding module *)
          WHILE (mp <> NIL) AND (mp^.mnamp <> frnp^.namep^.globmodp) DO 
            mp := mp^.nxtmp
          END (* WHILE *);
          IF mp <> NIL THEN (* if the module containing the name is to be 
                               dumped, make sure that the name is in the
                               module's list of names to be dumped *)
            np := mp^.fstnp;
            LOOP 
              IF np = NIL THEN
                IdentCheck(frnp^.namep); (* reference was still outstanding *)
                EXIT
              END (* IF *);
              IF frnp^.namep = np^.namep THEN
                EXIT (* reference to structure whose name is already known *)
              END (* IF *);
              np := np^.nxtnp
            END (* LOOP *)
          END (* IF *);
          DISPOSE(frnp)
        END (* while *)
      END (* if *);
    END EnterDumpList;

    PROCEDURE DumpModule(mp: Mlptr);
      (* dump symbolic module on symbol file *)
      VAR hmp : Mlptr;
          np1,np2 : Nlptr;
          explp : Idptr;
          expname : Spellix;
          curmod : Idptr;
 
      PROCEDURE DumpDeclaration(ip: Idptr);
        (* dump one declaration on symbol file *)
       
        PROCEDURE DumpQualIdent(ip: Idptr);
        BEGIN
          WITH ip^ DO
            IF (globmodp <> curmod) AND (globmodp <> root) THEN
              SymPutIdent(globmodp^.name);
              SymPutS(periodSS);
            END;
            SymPutIdent(name);
          END;
        END DumpQualIdent;
 
        PROCEDURE DumpConst(sp: Stptr; val: Constval);
          CONST rwordnum = 2; (* number of words for a real number *)
          VAR ix : CARDINAL;
              rconv : RECORD
                        CASE BOOLEAN OF
                          FALSE : ra: ARRAY [1..rwordnum] OF CARDINAL;
                         |TRUE : rc: REAL;
                        END;
                      END;
        BEGIN 
          WITH sp^ DO
            IF form = arrays THEN (* string constant *)
              SymPutStr(val.svalue^.valentry,ixp^.max + 1); (* addr,length *)
            ELSIF form = reals THEN
              SymPutS(realconstSS);
              rconv.rc := val.rvalue^;
              FOR ix := 1 TO rwordnum DO
                SymPutNumber(rconv.ra[ix]);
              END;
            ELSE
              SymPutCard(val.value);
              DumpQualIdent(stidp); (* type identifier of constant *)
            END;
          END;
        END DumpConst;
 
        PROCEDURE DumpType(sp: Stptr; struct: BOOLEAN);
          (* dump type structure or type identifier *)
          VAR ip : Idptr;
              cval : Constval;
 
          PROCEDURE DumpVariants(sp: Stptr);
            (* dump structure of record variants *)
            VAR sp1 : Stptr;
                csize : CARDINAL; (* current size of variant *)
                csubtag : Stptr; (* current pointer to subvariant *)
          BEGIN
            IF sp <> NIL THEN
              SymPutS(caseSS);
              SymPutS(colonSS);
              WITH sp^ DO
                DumpType(tagtyp,FALSE);
                sp1 := fstvarp;
                WHILE sp1 <> NIL DO (* dump variants *)
                  SymPutS(ofSS);
                  csize := sp1^.size;
                  csubtag := sp1^.subtagp;
                  WHILE (sp1 <> NIL) AND (sp1^.size = csize)                      
                                     AND (sp1^.subtagp = csubtag) DO 
                    SymPutCard(sp1^.varval);
                    sp1 := sp1^.nxtvarp;
                  END;
                  SymPutS(colonSS);
                  DumpVariants(csubtag);
                  SymPutCard(csize);
                END;
                IF elsevarp <> NIL THEN (* else variant *)
                  SymPutS(elseSS);
                  DumpVariants(elsevarp^.subtagp);
                  SymPutCard(elsevarp^.size);
                END;
              END;
              SymPutS(endSS);
            END;
          END DumpVariants;
 
        BEGIN (* DumpType *)
          WITH sp^ DO
            IF NOT struct AND (stidp <> NIL) THEN
              DumpQualIdent(stidp);
            ELSE (* dump type structure *)
              CASE form OF
                enums:
                  SymPutS(lparentSS);
                  ip := fcstp;
                  WHILE ip <> NIL DO
                    SymPutIdent(ip^.name);
                    SymPutCard(ip^.cvalue.value);
                    ip := ip^.link;
                  END;
                  SymPutS(rparentSS);
               |subranges: 
                  SymPutS(lbracketSS);
                  cval.value := min;
                  DumpConst(scalp,cval);
                  SymPutS(rangeSS);
                  cval.value := max;
                  DumpConst(scalp,cval);
                  SymPutS(rbracketSS);
               |pointers:
                  SymPutS(pointertypSS);
                  DumpType(elemp,FALSE);
               |hides:
                  SymPutS(hiddentypSS);
               |sets:
                  SymPutS(settypSS);
                  DumpType(basep,FALSE);
               |arrays:
                  SymPutS(arraytypSS);
                  IF NOT dyn THEN DumpType(ixp,FALSE); SymPutS(ofSS) END;
                  DumpType(elp,FALSE);
               |records:
                  SymPutS(recordtypSS);
                  ip := fieldp;
                  WHILE ip <> NIL DO (* dump fields *)
                    SymPutIdent(ip^.name);
                    SymPutCard(ip^.fldaddr); (* offset in record *)
                    SymPutS(colonSS);
                    DumpType(ip^.idtyp,FALSE);
                    ip := ip^.link;
                  END;
                  DumpVariants(tagp);
                  SymPutS(endSS);
                  SymPutCard(size); (* record size *)
               |proctypes:
                  SymPutS(procSS); 
                  SymPutS(lparentSS);
                  ip := fstparam;
                  WHILE ip <> NIL DO
                    IF ip^.vkind = varparam THEN SymPutS(varSS) END;
                    DumpType(ip^.idtyp,FALSE);
                    ip := ip^.vlink;
                  END;
                  SymPutS(rparentSS);
                  IF rkind = funcs THEN
                    SymPutS(colonSS);
                    DumpType(funcp,FALSE);
                  END;
              END (* case *)
            END;
          END; (* WITH *)
        END DumpType;
 
      BEGIN (* DumpDeclaration *)
        WITH ip^ DO
          CASE klass OF
            consts:
              SymPutS(constSS);
              SymPutIdent(name);
              DumpConst(idtyp,cvalue);
           |types:
              SymPutS(typSS);
              SymPutIdent(name);
              DumpType(idtyp,idtyp^.stidp=ip); (*check on equivalent type names*)
           |vars:
              SymPutS(varSS);
              SymPutIdent(name);
              IF state = absolute THEN
                SymPutS(lbracketSS);
                SymPutCard(vaddr);
                SymPutS(rbracketSS);
              ELSE SymPutCard(vaddr);
              END;
              SymPutS(colonSS);
              DumpType(idtyp,FALSE);
           |pures,funcs: 
              SymPutS(procSS);
              SymPutIdent(name);
              SymPutCard(procnum);
              DumpType(idtyp,TRUE);
          END; (* case *)
        END; (* WITH *)
      END DumpDeclaration;

    BEGIN       
      WITH mp^ DO
        curmod := mnamp;
        SymPutS(unitSS);
        WITH mnamp^ DO
          SymPutCard(modulekey[0]);
          SymPutCard(modulekey[1]);
          SymPutCard(modulekey[2]);
          SymPutIdent(name);
        END;
        IF fstnp <> NIL THEN
          (* import in definition module to be develloped *)
          SymPutS(importSS); (* import list *)
          SymPutIdent(sysmodp^.name); (* module SYSTEM allways imported *)
          hmp := mlroot;
          WHILE hmp <> mp DO (* import all preceding modules *)
            SymPutIdent(hmp^.mnamp^.name);
            hmp := hmp^.nxtmp;
          END;
          SymPutS(exportSS); (* export list *)
          (* dump exported names on the name list *)
          explp := mnamp^.expp;
          WHILE explp <> NIL DO
            expname := explp^.name;
            np1 := fstnp;
            WHILE np1 <> NIL DO
              IF np1^.namep^.name = expname THEN
                SymPutIdent(expname); np1 := NIL;
              ELSE np1 := np1^.nxtnp
              END;
            END;
            explp := explp^.link;
          END;
          np1 := fstnp;
          WHILE np1 <> NIL DO (* dump name list *)
            np2 := np1;
            np1 := np2^.nxtnp;
            DumpDeclaration(np2^.namep);
            DISPOSE(np2);
          END;
        END; (* IF *)
        SymPutS(endunitSS);
      END; (* WITH *)
    END DumpModule;
 
    PROCEDURE StartDump;
      (* dump of the symbol file *)
      VAR mp, hmp, dmp : Mlptr;
          ip : Idptr;

      PROCEDURE EnterModList(ip: Idptr);
        (* enter module into list in order of module number *)
        VAR mp, hmp, nmp : Mlptr;
            num : CARDINAL;
      BEGIN
        num := ip^.modnum;
        NEW(nmp);
        WITH nmp^ DO
          mnamp := ip;
          nxtmp := NIL;
          fstnp := NIL;
          lstnp := NIL;
        END;
        mp := mlroot;
        WHILE (mp <> NIL) AND (mp^.mnamp^.modnum < num) DO
          hmp := mp;
          mp := mp^.nxtmp;
        END;
        nmp^.nxtmp := mp;
        IF mp = mlroot THEN mlroot := nmp;
        ELSE hmp^.nxtmp := nmp;
        END;
      END EnterModList;

    BEGIN
      (* entry of modules into module list *)
      (* assume that main-module has the highest module number *)
      ip := root^.locp; (* list of separate modules *)
      WHILE ip <> NIL DO
        IF ip <> sysmodp THEN EnterModList(ip) END;
        ip := ip^.link;
      END;
      (* generate lists of names to be dumped *)
      EnterDumpList(mainmodp^.expp);
      EnterDumpList(mainmodp^.locp);
      (* dump on symbol file *)
      InitSym;
      (* dump header *)
      SymPutCard(symFileKey);
      WITH mainmodp^ DO
        SymPutCard(modulekey[0]);
        SymPutCard(modulekey[1]);
        SymPutCard(modulekey[2]);
        SymPutIdent(name);
      END;
      (* dump modules *)
      mp := mlroot;
      WHILE mp <> NIL DO
        DumpModule(mp);
        mp := mp^.nxtmp;
      END;
      TermSym;
      (* dispose module list *)
      mp := mlroot;
      WHILE mp <> NIL DO
        dmp := mp; mp := mp^.nxtmp; DISPOSE(dmp);
      END;
    END StartDump;
 
  BEGIN (* SymbolDump *)
    dumix := 0; (* initialisation of dummy identifier *)
    mlroot := NIL;
    StartDump;
  END SymbolDump;

BEGIN
(* It all happens through MODULE initialisation *)
END SymFile;


END M2SymFile.