(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*       VAX/VMS Implementation          *
*                                       *
*                                       *
*     MVCXRef:                          *
*                                       * 
*     Cross Reference Table             *
*     Management                        *
*                                       * 
*     Version 3.1 of  1-FEB-1983        *
*                                       *
*                                       *
*                                       *
*     Based on PDP11 Implementation:    *
*     Version M22 of 26.02.81           *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zuerich                       *
*     CH-8092 Zuerich                   *
*                                       *
****************************************)

(****************************************
* Updates:                              *
****************************************)

IMPLEMENTATION MODULE MVCXRef; (* VAX: H. Eckhardt *)

IMPORT MVCompiler;
IMPORT MVCPublic;
IMPORT Storage;
IMPORT SYSTEM;


MODULE ListStorage;

FROM MVCompiler IMPORT Idptr, XRefptr, sysmodp;
FROM MVCPublic  IMPORT Compilerstatus, compstat;
FROM Storage    IMPORT ALLOCATE, DEALLOCATE;
EXPORT EnableXRef, DisableXRef, EnterXRef;


  VAR
    enabled :   BOOLEAN;


  PROCEDURE EnableXRef;

    BEGIN
      enabled := TRUE
    END EnableXRef;


  PROCEDURE DisableXRef;

    BEGIN
      enabled := FALSE
    END DisableXRef;


  PROCEDURE EnterXRef   ( idptr :  Idptr;
                          line :   CARDINAL;
                          marked : BOOLEAN );
        (* Enters line no. into the (ordered) list;
         * entries may be 'marked'.
         *)

    VAR
      ref,
      lastref : XRefptr;

    BEGIN
      IF enabled AND (crossrefs IN compstat) THEN
        (* check for valid data: *)
        IF idptr = NIL THEN
          RETURN
        ELSIF idptr^.name < sysmodp^.name THEN
          RETURN (* no standard names *)
        END;
        ref := idptr^.xref;
        LOOP
          IF ref = NIL THEN
            EXIT
          ELSIF line <= ref^.lineno THEN
            IF line = ref^.lineno THEN
              ref^.mark := ref^.mark OR marked;
              RETURN;
            ELSE
              EXIT
            END (* if line = ..^.lineno *);
          ELSE
            lastref := ref;
            ref := lastref^.nextref;
          END (* if ref = NIL *);
        END (* loop *);
        IF ref = idptr^.xref THEN
          NEW ( ref );
          ref^.nextref := idptr^.xref;
          idptr^.xref := ref;
        ELSE
          NEW ( ref );
          ref^.nextref := lastref^.nextref;
          lastref^.nextref := ref;
        END;
        WITH ref^ DO
          lineno := line;
          mark := marked;
        END;
      END (* if enabled and crossrefs in compstat *);
    END EnterXRef;

END ListStorage;

(* - - - - - - - - - - - - - - - - - - *)

MODULE TableRetrieval;

FROM   MVCompiler IMPORT Spellix, spelltab, Idclass, Idset, Idptr,
                         Structform, Stptr, Listptr,
                         XRefptr, sysmodp, mainmodp;
FROM   Storage    IMPORT ALLOCATE, DEALLOCATE;
IMPORT Nameptr, XTabEntry, EnterXRef;
EXPORT GetEntry, OpenTable, EoTab;


TYPE
  listptr =     POINTER TO listrecs;
  listrecs =    RECORD
                  identp : Idptr;
                  scopep : Nameptr;
                  isexp :  BOOLEAN;
                  next :   listptr;
                END;

VAR
  currlist : listptr;


  PROCEDURE isExternal ( idp : Idptr ) : BOOLEAN;

    BEGIN
      IF idp^.klass = mods THEN
        RETURN idp^.globalmodule OR (idp = sysmodp)
      ELSE
        RETURN (idp^.globmodp <> mainmodp)
      END
    END isExternal;


  PROCEDURE hasTypeName ( structidp : Idptr ) : BOOLEAN;

    BEGIN
      IF structidp = NIL THEN
        RETURN FALSE
      END;
      IF (INTEGER(structidp^.name) <= 0) THEN
        RETURN FALSE (* = dummy name *)
      END;
      IF (spelltab[structidp^.name] >= '0') AND
         (spelltab[structidp^.name] <= '7') THEN
        RETURN FALSE
      END;
      RETURN TRUE
    END hasTypeName;


PROCEDURE GetEntry      ( VAR entry : XTabEntry );
        (* Returns next entry of current scope
         * Error : if EoTab = TRUE before calling then entry is undefined.
         *)

  VAR
    disposable :        listptr;


  PROCEDURE evalStruct ( structp : Stptr );

    VAR
      elptr : Stptr ;

    BEGIN (* evalStruct *)
      WITH (* current *) entry DO
        struct.named := hasTypeName ( structp^.stidp ) AND
                        NOT (structp^.stidp = currlist^.identp);
        IF (structp^.form = subranges) AND NOT struct.named THEN
          structp := structp^.scalp;
        END;
        WITH structp^ DO
          WITH (* entry. *) struct DO
            IF named THEN
              typename := structp^.stidp^.name
            ELSE
              typeform := form
            END (* if named *);
          END (* with struct *);
          WITH (* entry. *) elstruct DO
            CASE (* structp^. *) form OF
              sets :
                elptr := basep |
              pointers :
                elptr := elemp |
              arrays :
                elptr := elp;
                WHILE elptr^.form = arrays DO
                  (* reduce to elements: *)
                  elptr := elptr^.elp;
                END;
            ELSE
              RETURN (* no element types *)
            END (* case form *);
            named := hasTypeName ( elptr^.stidp );
            IF named THEN
              typename := elptr^.stidp^.name
            ELSE
              typeform := elptr^.form
            END;
          END (* with elstruct *);
        END (* with structp *);
      END (* with current entry *);
    END evalStruct;


  BEGIN (* GetEntry *)
    IF NOT EoTab() THEN
      disposable := currlist;
      currlist := currlist^.next;
      DISPOSE ( disposable );
      WITH entry DO
        WITH currlist^ DO
          ident := identp^.name;
          class := identp^.klass;
          exported := isexp;
          external := isExternal ( identp );
          refList := identp^.xref;
          IF refList^.lineno = 0 THEN
            (* remove: *) refList := refList^.nextref
          END;
          scopes := scopep;
          WITH identp^ DO
            CASE class OF
              consts, types :
                evalStruct ( idtyp ) |
              vars :
                kind := vkind;
                evalStruct ( idtyp ) |
              fields :
                evalStruct ( idtyp ) |
              funcs :
                IF NOT isstandard THEN
                  evalStruct ( idtyp^.funcp )
                ELSE
                  struct.named := FALSE;
                  struct.typeform := proctypes
                END |
              mods :
                IF external THEN
                  DISPOSE ( scopes );
                  scopes := NIL;
                END;
            ELSE
            END (* class *);
          END (* with identp^ *);
        END (* with actidp *);
      END (* with entry *);
    END (* if not EoTab *);
  END GetEntry;



PROCEDURE OpenTable;

  VAR
    auxp : listptr;

  PROCEDURE Insert ( idp, idscope : Idptr; exported : BOOLEAN );
    (* inserts into ordered list,
     * according to idp^.name.
     *)

    VAR
      newp :     listptr;
      p, lp :    listptr;
      auxnamp :  Nameptr;

    PROCEDURE less ( i, k : Spellix ): BOOLEAN;
      (* tests for spelltab[i..] < spelltab[k..] *)

      VAR
        Ci, Ck :        CHAR;

      BEGIN
        LOOP
          Ci := spelltab [ i ];
          IF (Ci >= 'a') AND (Ci <= 'z') THEN Ci := CAP ( Ci ) END;
          Ck := spelltab [ k ];
          IF (Ck >= 'a') AND (Ck <= 'z') THEN Ck := CAP ( Ck ) END;
          IF (Ci = ' ') OR (Ck = ' ') THEN
            RETURN Ci < Ck
          ELSIF Ci <> Ck THEN
            RETURN Ci < Ck 
          END;
          INC ( i ); INC ( k );
        END;
      END less;

    PROCEDURE JoinStructs ( stp : Stptr; locp : Idptr );
        (* Include components of structured types
         * into the table.
         *)
      VAR
        elptr : Stptr;

      BEGIN
        WITH stp^ DO
          CASE form OF
            enums :
              IncludeList ( fcstp, idscope, FALSE ) |
            records :
              IncludeList ( fieldp, locp, FALSE ) |
            sets :
              IF NOT hasTypeName ( basep^.stidp ) THEN
                JoinStructs ( basep, locp )
              END |
            pointers, arrays :
              IF form = pointers THEN
                elptr := elemp
              ELSE
                elptr := elp;
                WHILE elptr^.form = arrays DO
                  (* reduce to elements: *)
                  elptr := elptr^.elp;
                END;
              END;
              IF hasTypeName ( elptr^.stidp ) THEN
                WITH elptr^ DO
                  IF stidp^.globmodp <> mainmodp THEN
                    (* external name, ensure insertion: *)
                    EnterXRef ( stidp, 0, FALSE );
                    (* line no 0 removed by GetEntry *)
                    Insert ( stidp, stidp^.globmodp, FALSE );
                  END (* if stidp^.globmodp *);
                END (* with elptr^ *);
              ELSE (* unnamed structure: *)
                JoinStructs ( elptr, locp )
              END (* if hasTypeName ... else *);
          ELSE (* other Structforms: *)
          END (* case form *);
        END (* with stp^ *)
      END JoinStructs;


    BEGIN (* Insert *)
      (* check for validity of parameter: *)
      IF idp = NIL THEN
        RETURN
      ELSIF (idp^.idtyp = NIL) AND (idp^.klass IN Idset{types, vars, fields}) THEN
        RETURN (* missing type *)
      ELSIF idp^.name < sysmodp^.name THEN
        RETURN (* standard names not entered *)
      END;
      IF idp^.klass = indrct THEN
        idp := idp^.nxtidp
      END;
      IF idp^.xref <> NIL THEN
        p := currlist;
        lp := p;
        LOOP
          IF p = NIL THEN
            EXIT
          ELSIF idp = p^.identp THEN
            IF idscope = NIL THEN
              RETURN (* already entered *)
            END;
            (* perhaps another scope: *)
            auxnamp := p^.scopep;
            WHILE auxnamp <> NIL DO
              IF auxnamp^.name = idscope^.name THEN
                (* already entered *)
                RETURN
              END; auxnamp := auxnamp^.next;
            END (* while *);
            (* enter: *)
            NEW ( auxnamp );
            auxnamp^.next := p^.scopep;
            auxnamp^.name := idscope^.name;
            p^.scopep := auxnamp;
          ELSIF less ( idp^.name,  p^.identp^.name ) THEN
            EXIT (* for insertion *)
          ELSE
            lp := p;
            p := p^.next
          END (* if p^.next *);
        END (* loop *);
        (* insert: *)
        NEW ( newp );
        WITH newp^ DO
          identp := idp;
          IF idscope <> NIL THEN
            NEW ( scopep );
            scopep^.name := idscope^.name;
            scopep^.next := NIL;
          ELSE
            scopep := NIL
          END;
          isexp := exported;
          next := p;
        END;
        IF lp = p THEN
          currlist := newp;
        ELSE
          lp^.next := newp;
        END;
        (* include components of structured types, *)
        (* but don't analyse SYSTEM structures:    *)
        IF idscope = sysmodp THEN
          RETURN
        END;
        WITH idp^ DO
          CASE klass OF
            types :
              IF idtyp^.stidp = idp THEN
                JoinStructs ( idtyp, idtyp^.stidp )
              ELSE (* type structure is named, *)
                RETURN (* from Insert *)
              END |
            vars, fields :
              IF NOT hasTypeName ( idtyp^.stidp ) THEN
                JoinStructs ( idtyp, idp )
              ELSIF idtyp^.stidp^.xref = NIL THEN
                (* indirect import or declaration from def. module: *)
                EnterXRef ( idtyp^.stidp, 0, FALSE );
                Insert ( idtyp^.stidp, idtyp^.stidp^.globmodp, FALSE );
              ELSE (* type is named *)
                RETURN (* from Insert *)
              END |
            pures, funcs :
              (* enlist locals: *)
              IF NOT isExternal ( idp ) THEN
                IncludeList ( locp, idp, FALSE )
              END |
            mods :
              (* enlist exports and locals: *)
              IF NOT isExternal ( idp ) THEN
                IncludeList ( expp, idp, TRUE );
                IncludeList ( locp, idp, FALSE );
              END;
          ELSE
          END (* case klass *);
        END (* with idp *);
      END (* if idp^.xref <> NIL *);
    END Insert;


  PROCEDURE IncludeExternals ( lip : Idptr );
        (* to insert main module's imports into table *)

    PROCEDURE join ( lip, fromp : Idptr );

      BEGIN
        WHILE lip <> NIL DO
          IF lip <> mainmodp THEN
            Insert ( lip, fromp, FALSE );
            WITH lip^ DO
              IF (klass = mods) THEN
                join ( expp, lip );
              END;
            END;
          END (* if lip <> mainmodp *);
          lip := lip^.link;
        END;
      END join;

    BEGIN (* IncludeExternals  *)
      join ( lip, lip^.globmodp );
    END IncludeExternals ;


  PROCEDURE IncludeList ( lip :      Idptr;
                          idscope :    Idptr;
                          exported : BOOLEAN );

    BEGIN
      WHILE lip <> NIL DO
        IF lip^.klass <> indrct THEN
          Insert ( lip, idscope, exported );
          (* indirect referred id's inserted later *)
        END;
        lip := lip^.link;
      END;
    END IncludeList;


  BEGIN (* OpenTable *)
    currlist := NIL;
    (* enlist imports: *)
    IncludeExternals ( sysmodp );
    (* enlist global exports: *)
    IncludeList ( mainmodp^.expp, NIL, TRUE );
    (* enlist locals: *)
    IncludeList ( mainmodp^.locp, NIL, FALSE );
    (* empty list head since GetEntry fetches *.next *)
    NEW ( auxp );
    auxp^.next := currlist;
    currlist := auxp;
  END OpenTable;


PROCEDURE EoTab (): BOOLEAN;
        (* TRUE when last entry of current table has been read
         * or no initial OpenTable has been done.
         *)

  BEGIN
    IF currlist = NIL THEN
      RETURN TRUE
    ELSE
      RETURN currlist^.next = NIL;
    END;
  END EoTab;


  BEGIN (* TableRetrieval initialization *)
    currlist := NIL;
  END TableRetrieval;



END MVCXRef.