(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*       VAX/VMS Implementation          *
*                                       *
*                                       *
*     M2CId1:                           *
*                                       * 
*     Identifier handling in Pass 1     *
*                                       *
*     Version 3.1 of  1-FEB-1983        *
*                                       *
*                                       *
*                                       *
*     Based on PDP11 Implementation:    *
*     Version M22 of 09.03.81           *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zuerich                       *
*     CH-8092 Zuerich                   *
*                                       *
****************************************)

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

IMPLEMENTATION MODULE MVCId1;       (* LG *)
                                    (* VAX: M. Mall *)
  (* $T- *)

  IMPORT MVCompiler, MVCIO1, Storage;
  FROM MVCompiler IMPORT maxaddr, wordsize,
                         Idptr, Stptr, Idclass, Structform,
                         Varkind, Kindvar, Parkind,
                         Stpures, Stfuncs, Spellix, Symbol,
                         root, boolptr, charptr, intptr, cardptr,
                         intcarptr, realptr, wordptr, bitsetptr,
                         dfloatptr, gfloatptr, hfloatptr, byteptr,
                         shortwordptr, quadwordptr, octawordptr,
                         strptrs, substptr,
                         addrptr, procptr, processptr, mainmodp, sysmodp;
  FROM MVCIO1 IMPORT HashIdent, EnterResWord, String14, spix;
  FROM Storage IMPORT ALLOCATE, DEALLOCATE;

  CONST
    onebyte = 1; (* space for allocation *)
    oneword = 4 * onebyte;
    doubleword = 2 * oneword;
    procmarkspace = 1 * oneword; (* space used for procedure mark *)

  VAR
    curlistp : Idptr;

  PROCEDURE EnterName(VAR p: Idptr; VAR str: String14);
    (* initialisation and name entry *)

    VAR
      p1, p2: Idptr;

  BEGIN
    HashIdent(str);
    WITH p^ DO (* initialise *)
      name := spix; (* generated by HashIdent *)
      link := NIL;
      xref := NIL;
      idtyp := NIL;
      globmodp := mainmodp;
    END;
    p1 := curlistp;
    WHILE (p1<>NIL)AND(spix>p1^.name) DO
      p2 := p1;
      p1 := p1^.link;
    END;
    p^.link := p1;
    IF p1=curlistp THEN
      curlistp := p
    ELSE p2^.link := p
    END
  END EnterName;

  PROCEDURE EnterMod(sysmod: BOOLEAN);

    VAR
      p : Idptr;
      str : String14;

  BEGIN
    NEW(p,mods,FALSE,mods,FALSE);
    mainmodp := p;
    IF sysmod THEN
      str := "SYSTEM";
    ELSE 
      root := p;
      str := "S.M."; (* standard module *)
    END;
    HashIdent(str);
    WITH p^ DO
      name := spix;
      klass := mods;
      globmodp := mainmodp;
      link := NIL;
      xref := NIL;
      idtyp := NIL;
      expp := NIL;
      impp := NIL;
      locp := NIL;
      msp := NIL;
      isstandard := FALSE;
      externalaccess := FALSE;
      used := FALSE;
      qualexp := sysmod; (* if TRUE then module SYSTEM *)
      globalmodule := FALSE;
    END;
    curlistp := NIL;
  END EnterMod;

  PROCEDURE EnterProc(str: String14; pn: Stpures; tp: Stptr);

    VAR
      p: Idptr;

  BEGIN
    NEW(p, pures, TRUE);
    EnterName(p,str);
    WITH p^ DO
      klass := pures;
      idtyp := tp; (* must be <> NIL for substituted procedures *)
      isstandard := TRUE;
      pname := pn;
    END;
  END EnterProc;

  PROCEDURE EnterFunc(str: String14; fn: Stfuncs);

    VAR
      p: Idptr;

  BEGIN
    NEW(p, funcs, TRUE);
    EnterName(p,str);
    WITH p^ DO
      klass := funcs;
      isstandard := TRUE;
      fname := fn;
    END;
  END EnterFunc;

  PROCEDURE BaseType(sf: Structform): Stptr;

    VAR
      sp : Stptr;

  BEGIN
    NEW(sp,bools);
    WITH sp^ DO
      CASE sf OF
        bools,chars: size := onebyte; |
        ints,cards,words: size := oneword; |
        reals: size := oneword;
      END;
      stidp := NIL;
      inlist := TRUE;
      form := sf;
    END;
    RETURN sp
  END BaseType;

  PROCEDURE SubrStruct(mi,ma: CARDINAL): Stptr;

    VAR
      sp : Stptr;

  BEGIN
    NEW(sp,subranges);
    WITH sp^ DO
      size := oneword;
      form := subranges;
      stidp := NIL;
      inlist := TRUE;
      scalp := cardptr;
      min := mi;
      max := ma;
    END;
    RETURN sp
  END SubrStruct;

  PROCEDURE PointerStruct(tp : Stptr): Stptr;

    VAR
      sp : Stptr;

  BEGIN
    NEW(sp,pointers);
    WITH sp^ DO
      size := oneword;
      form := pointers;
      stidp := NIL;
      inlist := TRUE;
      elemp := tp;
    END;
    RETURN sp
  END PointerStruct;

  PROCEDURE SetStruct(): Stptr;

    VAR
      sp : Stptr;

  BEGIN
    NEW(sp,sets);
    WITH sp^ DO
      size := oneword;
      form := sets;
      stidp := NIL;
      inlist := TRUE;
      basep := SubrStruct(0,wordsize-1);
    END;
    RETURN sp
  END SetStruct;

  PROCEDURE ProcedureStruct(fp: Idptr; pl: CARDINAL): Stptr;

    VAR
      sp : Stptr;

  BEGIN
    NEW(sp,proctypes,pures);
    WITH sp^ DO
      size := oneword;
      form := proctypes;
      rkind := pures;
      stidp := NIL;
      inlist := TRUE;
      fstparam := fp;
      parlgth := pl;
    END;
    RETURN sp
  END ProcedureStruct;

  PROCEDURE EnterVar(str: String14; tp: Stptr; ad: CARDINAL);

    VAR
      p : Idptr;

  BEGIN
    NEW(p,vars,noparam);
    EnterName(p,str);
    WITH p^ DO
      xref := NIL;
      idtyp := tp;
      klass := vars;
      vlevel := 0;
      vaddr := ad;
      state := absolute;
      vkind := noparam;
    END;
  END EnterVar;

  PROCEDURE EnterParam(tp: Stptr; ad: CARDINAL; vk: Varkind; VAR np: Idptr);

    VAR
      p : Idptr;

  BEGIN
    NEW(p,vars,varparam);
    WITH p^ DO
      name := 0;
      xref := NIL;
      idtyp := tp;
      globmodp := mainmodp;
      klass := vars;
      vlevel := 1;
      vaddr := ad;
      state := local;
      vkind := vk;
      pkind := default;
      nxtparam := np;
    END;
    np := p
  END EnterParam;

  PROCEDURE EnterType(str: String14; tp: Stptr);

    VAR
      p : Idptr;

  BEGIN
    NEW(p,types);
    EnterName(p,str);
    WITH p^ DO
      klass := types;
      idtyp := tp;
      dstaddr := 0;
    END;
    tp^.stidp := p; (* link structure with name *)
  END EnterType;

  PROCEDURE EnterConst(str: String14; tp: Stptr; valu: CARDINAL);

    VAR
      p : Idptr;

  BEGIN
    NEW(p,consts);
    EnterName(p,str);
    WITH p^ DO
      idtyp := tp;
      klass := consts;
      cvalue.value := valu;
    END;
  END EnterConst;

  PROCEDURE InitResWords;

  BEGIN
    EnterResWord('AND',andsy);            (* reserved words *)
    EnterResWord('DIV',divsy);
    EnterResWord('MOD',modsy);
    EnterResWord('NOT',notsy);
    EnterResWord('OR',orsy);
    EnterResWord('IN',insy);
    EnterResWord('CONST',constsy);
    EnterResWord('TYPE',typesy);
    EnterResWord('VAR',varsy);
    EnterResWord('ARRAY',arraysy);
    EnterResWord('RECORD',recordsy);
    EnterResWord('SET',setsy);
    EnterResWord('POINTER',pointersy);
    EnterResWord('TO',tosy);
    EnterResWord('IMPORT',importsy);
    EnterResWord('EXPORT',exportsy);
    EnterResWord('FROM',fromsy);
    EnterResWord('QUALIFIED',qualifiedsy);
    EnterResWord('DEFINITION',definitionsy);
    EnterResWord('IMPLEMENTATION',implementationsy);
    EnterResWord('PROCEDURE',proceduresy);
    EnterResWord('MODULE',modulesy);
    EnterResWord('BEGIN',beginsy);
    EnterResWord('CASE',casesy);
    EnterResWord('OF',ofsy);
    EnterResWord('IF',ifsy);
    EnterResWord('THEN',thensy);
    EnterResWord('ELSIF',elsifsy);
    EnterResWord('ELSE',elsesy);
    EnterResWord('LOOP',loopsy);
    EnterResWord('EXIT',exitsy);
    EnterResWord('REPEAT',repeatsy);
    EnterResWord('UNTIL',untilsy);
    EnterResWord('WHILE',whilesy);
    EnterResWord('WITH',withsy);
    EnterResWord('DO',dosy);
    EnterResWord('FOR',forsy);
    EnterResWord('BY',bysy);
    EnterResWord('RETURN',returnsy);
    EnterResWord('END',endsy);
    EnterResWord('%FOREIGN',foreignsy);
    EnterResWord('%REF',refsy);
    EnterResWord('%IMMED',immedsy);
    EnterResWord('%DESCR',descrsy);
    EnterResWord('%STDESCR',stdescrsy);
  END InitResWords;

  PROCEDURE InitStandards;

    VAR
      niltypeptr : Stptr;
      parp : Idptr;
      prp : Stptr;
      saveidp : Idptr;
      ix : CARDINAL;

  BEGIN
    (* standard module *)
    EnterMod(FALSE);
    boolptr := BaseType(bools);
    charptr := BaseType(chars);
    intptr := BaseType(ints);
    cardptr := BaseType(cards);
    intcarptr := BaseType(cards);
    realptr := BaseType(reals);
    bitsetptr := SetStruct();
    niltypeptr := PointerStruct(NIL);
    procptr := ProcedureStruct(NIL,0); (* PROCEDURE *)
    EnterType('BOOLEAN',boolptr);
    EnterType('CHAR',charptr);
    EnterType('INTEGER',intptr);
    EnterType('CARDINAL',cardptr);
    EnterType('REAL',realptr);
    EnterType('BITSET',bitsetptr);
    EnterType('INT-CARD',intcarptr);
    EnterType('NIL-TYPE',niltypeptr);
    EnterType('PROC',procptr);
    EnterConst('FALSE',boolptr,0);
    EnterConst('TRUE',boolptr,1);
    EnterConst('NIL',niltypeptr,0);
    EnterProc('DEC', decp,NIL);      (* standard procedures *)
    EnterProc('EXCL', exlp,NIL);
    EnterProc('HALT', halp,NIL);
    EnterProc('INC', incp,NIL);
    EnterProc('INCL', inlp,NIL);
    EnterProc('NEW', newp,NIL);
    EnterProc('DISPOSE', disp,NIL);
    EnterFunc('ABS', absf);           (* standard functions *)
    EnterFunc('ASH', ashf);
    EnterFunc('CAP', capf);
    EnterFunc('CHR', chrf);
    EnterFunc('FLOAT', fltf);
    EnterFunc('HIGH', higf);
    EnterFunc('LEN', lenf);
    EnterFunc('ODD', oddf);
    EnterFunc('ORD', ordf);
    EnterFunc('TRUNC', trcf);
    EnterFunc('VAL', valf);
    mainmodp^.expp := curlistp;
    (* initialisation of string structure table *)
    FOR ix := 0 TO 20 DO
      strptrs[ix] := NIL
    END;
    (* module SYSTEM *)
    EnterMod(TRUE);
    wordptr := BaseType(words);
    processptr := PointerStruct(wordptr);
    addrptr := SubrStruct(0B,maxaddr);
    dfloatptr := BaseType(reals);
    dfloatptr^.size := 2 * oneword;
    gfloatptr := BaseType(reals);
    gfloatptr^.size := 2 * oneword;
    hfloatptr := BaseType(reals);
    hfloatptr^.size := 4 * oneword;
    byteptr := BaseType(words);
    byteptr^.size := onebyte;
    shortwordptr := BaseType(words);
    shortwordptr^.size := 2 * onebyte;
    quadwordptr := BaseType(words);
    quadwordptr^.size := 2 * oneword;
    octawordptr := BaseType(words);
    octawordptr^.size := 4 * oneword;
    EnterType('LONGWORD',wordptr);
    EnterType('WORD',wordptr);
    (* LONGWORD entered first to ensure wordptr...^.name='WORD' *)
    EnterType('PROCESS',processptr);
    EnterType('ADDRESS',addrptr);
    saveidp := realptr^.stidp; (* save reference to identifier 'REAL'  *)
    EnterType('F_FLOATING',realptr);
    realptr^.stidp := saveidp; (* because F_FLOATING is only a synonym *)
    EnterType('D_FLOATING',dfloatptr);
    EnterType('G_FLOATING',gfloatptr);
    EnterType('H_FLOATING',hfloatptr);
    EnterType('BYTE',byteptr);
    EnterType('SHORTWORD',shortwordptr);
    (*         LONGWORD : see above  *)
    EnterType('QUADWORD',quadwordptr);
    EnterType('OCTAWORD',octawordptr);
    EnterProc('NEWPROCESS',nprp,NIL);    (* SYSTEM procedures *)
    EnterProc('TRANSFER',trsp,NIL);
    EnterFunc('ADR', adrf);              (* SYSTEM functions *)
    EnterFunc('REGISTER',regf);
    EnterFunc('SIZE', sizf);
    EnterFunc('TSIZE', tszf);
    mainmodp^.expp := curlistp;
    sysmodp := mainmodp;
    (* initialisation of substitution procedures *)
    curlistp := NIL;
    parp := NIL;
    EnterParam(cardptr,procmarkspace + oneword,valparam,parp);
    EnterParam(addrptr,procmarkspace,varparam,parp);
    prp := ProcedureStruct(parp,2*oneword);
    (* PROCEDURE(VAR ADDRESS,CARDINAL) *)
    EnterProc("ALLOCATE",newp,prp); (* substitution for NEW *)
    EnterProc("DEALLOCATE",disp,prp); (* substitution for DISPOSE *)
    substptr := curlistp;
  END InitStandards;

  PROCEDURE InitIdTables;

  BEGIN
    InitResWords;
    InitStandards;
  END InitIdTables;

END MVCId1.