(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*                                       *
*     M2CReference:                     *
*                                       * 
*     Generation of reference file      *
*                                       * 
*     Version of 03-Aug-83              *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zuerich                       *
*     CH-8092 Zuerich                   *
*                                       *
****************************************)

IMPLEMENTATION MODULE MCP2Reference; (* LG *)
(*
    03-Aug-83:  suppress output of imported types
*)

  (* $T- *)
  FROM SYSTEM IMPORT WORD;
  FROM NewStreams IMPORT
    STREAM, Connect, Reset, WriteWord, WriteChar, EndWrite, Disconnect;
  FROM M2RefTypes IMPORT RefSymbol;
  FROM MCP2IO  IMPORT line;
  FROM P1IOId IMPORT IdSetPos, IdGetChar, maxspix;
  FROM MCBase IMPORT
    Idptr, Stptr, Idclass, Structform, Varkind, Kindvar, Spellix,
    bitsetptr, addrptr, processptr, mainmodp;
  FROM MCPublic IMPORT refFile;

  CONST
    refversion = 33;    
    maxfix = 16;
  TYPE
    Byte = [0 .. 377B];
    ForwardIndex = [0 .. maxfix];

  VAR
    ref     : STREAM;
    writeref: BOOLEAN; (* writing on ref file allowed *)
    wordbuff : CARDINAL;
    fref : ARRAY [0 .. maxfix-1] OF Stptr;

  PROCEDURE WriteRef(b: Byte);
  BEGIN
      WriteChar(ref, CHAR(b));
  END WriteRef;
  
  PROCEDURE WriteRefWord(w: WORD);
  (*  Wordlength independent representation of words *)
  VAR k: CARDINAL;
  BEGIN
    k := CARDINAL(w) DIV 128;
    IF k=0 THEN
        WriteChar(ref, CHAR(w));
    ELSE
        WriteChar(ref, CHAR((CARDINAL(w) MOD 128) + 128));
	WriteRefWord(k);
    END;
  END WriteRefWord;

  PROCEDURE RefSym ( sym : RefSymbol );
    (* write a RefSymbol on the ref file *)
  BEGIN
    WriteRef(ORD(sym)) 
  END RefSym;

  PROCEDURE RefIdent(spix:Spellix);
    VAR ch: CHAR;
  BEGIN
    IF spix>maxspix THEN WriteRef(ORD("*"));
    ELSE
      IdSetPos(spix);
      IdGetChar(ch);
      WHILE ch <> ' ' DO 
        WriteRef(ORD(ch));
        IdGetChar(ch);
      END;
    END(*else*);
    WriteRef(0);
  END RefIdent;
  
  PROCEDURE RefNum ( num : CARDINAL );
    (* write a number on the ref file *)
  BEGIN
    WriteRefWord(num);
  END RefNum;

  PROCEDURE TypeRef(VAR sp: Stptr);
  (* write a type reference on the ref file *)
    VAR
        sym: RefSymbol;
    BEGIN
        IF sp=NIL THEN sym := undefRS;
        ELSE
            WITH sp^ DO
                CASE form OF
                  ints: sym := integerRS;
                | cards: sym := cardinalRS;
                | chars: sym := charRS;
                | bools: sym := booleanRS;
                | reals: sym := realRS;
                | proctypes: sym := proctypRS;
                | words: sym := wordRS;
                ELSE
                  IF sp = bitsetptr THEN sym := bitsetRS;
                  ELSIF sp = addrptr THEN sym := addressRS;
                  ELSIF sp = processptr THEN sym := processRS;
                  ELSE sym := typerefRS;
                  END;
                END; (* case *)
            END; (* with *)
        END; (* if *)
        RefSym(sym);
        IF sym = typerefRS THEN RefNum(CARDINAL(sp)) END;
    END TypeRef;

  PROCEDURE Type(VAR sp: Stptr);
  (* write a type description on the ref file,
     but suppress details if it is imported from another module
  *)
    VAR
        ip: Idptr;
        writetype, isexternal: BOOLEAN;
        sym: RefSymbol;
        
    PROCEDURE ForwardRef;
        VAR
           fix: ForwardIndex;
        BEGIN
            fix := 0;
            WHILE (fix < maxfix) AND (fref[fix] <> NIL) DO
                INC(fix);
            END (* while *);
            IF fix < maxfix THEN
                fref[fix] := sp;
                writetype := FALSE;
            END (* if *);
        END ForwardRef;
     
    PROCEDURE XType(sp: Stptr);
        BEGIN
            IF NOT isexternal THEN
                Type(sp);
            END (* if *);
        END XType;

    BEGIN
        IF (sp=NIL) OR sp^.inlist THEN
            RETURN
        END (* if *);
        writetype := TRUE;
        WITH sp^ DO
            isexternal := (stidp # NIL) AND (stidp^.globmodp # mainmodp);
            inlist := TRUE;
            CASE form OF
              subranges: sym := subrRS; XType(scalp);
            | enums: sym := enumRS;
            | sets: sym := setRS; XType(basep);
            | pointers:
                sym := pointerRS;
                IF elemp=NIL THEN
                    ForwardRef
                ELSE
                    XType(elemp)
                END (* if *);
            | arrays:
                IF dyn THEN
                    sym := arrdynRS
                ELSE
                    sym := arrayRS; XType(ixp);
                END (* if *);
                XType(elp);
            | records:
                sym := recordRS;
                IF NOT isexternal THEN
                    ip := fieldp;
                    WHILE ip <> NIL DO
                        Type(ip^.idtyp);
                        ip := ip^.link
                    END (* while *);
                END (* if *);
            | hides:
                sym := hiddenRS;
                IF NOT isexternal THEN
                    ForwardRef
                END (* if *);
            | opens: sym := openRS; XType(openstruc);
            ELSE writetype := FALSE;
            END (* case *);

            IF NOT writetype THEN RETURN END;
            RefSym(typeRS);
            RefNum(CARDINAL(sp));
            IF isexternal THEN 
                RefIdent(stidp^.globmodp^.name); (* note module name *)
            ELSE WriteRef(0);
            END (* if *);
            IF stidp=NIL THEN WriteRef(0) ELSE RefIdent(stidp^.name) END;
            RefSym(sym);
            RefNum(size);
            IF NOT isexternal THEN (* output full details *)
                CASE sym OF
                  subrRS:
                    RefNum(min);
                    RefNum(max);
                    TypeRef(scalp);
                | enumRS:
                    ip := fcstp;
                    WHILE ip <> NIL DO
                        WITH ip^ DO
                            RefSym(constRS);
                            RefNum(cvalue.value);
                            RefIdent(name);
                            ip := link;
                        END (* with *);
                    END (* while *);
                    RefSym(endRS);

                | setRS : TypeRef(basep);
                | pointerRS : TypeRef(elemp);
                | arrayRS : TypeRef(ixp); TypeRef(elp);
                | arrdynRS : TypeRef(elp);
                | recordRS :
                   ip := fieldp;
                   WHILE ip <> NIL DO
                     WITH ip^ DO
                      RefSym(fieldRS);
                      RefNum(fldaddr);
                      RefIdent(name);
                      TypeRef(idtyp);
                      ip := link;
                     END; (* WITH *)
                   END; (* WHILE *)
                   RefSym(endRS);
                | hiddenRS : (* nothing more *)
                | openRS : TypeRef(openstruc);
              END; (* CASE *)
            END (* if *);
       END (* with *);
    END Type;

  PROCEDURE Reference(ip : Idptr);
    (* write a reference to the identifier *)
    VAR tp : Stptr; 
        sym : RefSymbol;
  BEGIN
    IF writeref AND (ip<>NIL) THEN
      WITH ip^ DO
        CASE klass OF
          mods, pures, funcs :
            IF klass = mods THEN RefSym (moduleRS);
            ELSE RefSym (procRS);
            END;
            RefNum(line);
            RefNum(procnum);
            RefIdent (name);
        | types :
            Type(idtyp);
        | vars :
            Type(idtyp);
            RefSym (varRS);
            RefNum(line);
            IF state = absolute THEN RefSym(absRS);
            ELSIF vkind = varparam THEN RefSym(indRS);
            ELSE RefSym(relRS);
            END;
            RefNum(vaddr);
            RefIdent (name);
            TypeRef(idtyp);
         ELSE
         END (* CASE *)
       END (* WITH *)
     END;
  END Reference;

  PROCEDURE EndReference(ip:Idptr);
    VAR fix : ForwardIndex;
        sp : Stptr;
  BEGIN (* EndReference *)
    IF writeref AND (ip<>NIL) THEN
      (* write forward references *)
      fix := 0;
      WHILE fix < maxfix DO
        IF fref[fix] <> NIL THEN
          sp := fref[fix];
          IF (sp^.form = pointers) AND (sp^.elemp <> NIL) OR
             (sp^.form = opens) THEN (* write information *)
            fref[fix] := NIL;
            sp^.inlist := FALSE;
            Type(sp);
          END;
        END;
        INC(fix);
      END; (* WHILE *)
      RefSym(endRS);
    END;
  END EndReference;

  PROCEDURE InitRef;
    (* initialisation of ref file *)
    VAR fix : ForwardIndex;
  BEGIN (* InitRef *)
    writeref := TRUE;
    Connect(ref,refFile,TRUE);
    Reset(ref);
    RefSym(reffileRS);
    RefNum(refversion);
    fix := 0;
    WHILE fix < maxfix DO fref[fix] := NIL; INC(fix) END;
  END InitRef;

  PROCEDURE TermRef;
  BEGIN (* TermRef *)
    EndWrite(ref);
    Disconnect(ref,FALSE);
    writeref := FALSE;
  END TermRef;

BEGIN (* MCP2Reference *)
  writeref := FALSE
END MCP2Reference.