(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*     Implementation for Lilith         *
*                                       *
*                                       *
*     MCP1Ident:                        *
*                                       * 
*     Identifier handling in Pass 1     *
*                                       * 
*     Version C18 of 09.03.81           *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zuerich                       *
*     CH-8092 Zuerich                   *
*                                       *
****************************************)

IMPLEMENTATION MODULE MCP1Ident;   (* LG *)

  FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  FROM MCImpl IMPORT 
    Realsize, BytesperWord, BitsperWord,
    MaxInt, MinInt, MaxCard, MostSigBit, LeastSigBit;
  FROM MCBase IMPORT
    noprio,
    Idptr, Stptr, Idclass, Structform,
    Varkind, Kindvar,
    Stpures, Stfuncs, Spellix, Symbol,
    root, boolptr, charptr, intptr, cardptr,
    intcarptr, realptr, wordptr, bitsetptr,
    strptrs, substptr,
    addrptr, procptr, processptr, mainmodp, sysmodp;
  FROM MCP1IO IMPORT HashIdent, EnterResWord, String14, spix;
  FROM P1IOId IMPORT InitIdTab;

  CONST oneword = 1; (* space for allocation *)
        doubleword = 2 * oneword;
        procmarkspace = 4 * 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;
      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";
      HashIdent(str)
    ELSE
      root := p;
      str := "S.M."; (* standard module *)
      HashIdent(str);
    END;
    WITH p^ DO
      name := spix; klass := mods;
      globmodp := mainmodp;
      link := NIL; idtyp := NIL;
      expp := NIL; impp := NIL; locp := NIL;
      msp := NIL; isstandard := FALSE;
      priolev := noprio;
      externalaccess := 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,ints,cards,words: size := oneword;
      | reals: size := Realsize;
      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, BitsperWord-1);
    END;
    RETURN sp
  END SetStruct;

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

  PROCEDURE EnterVar(str: String14; tp: Stptr; ad: CARDINAL);
    VAR p : Idptr;
  BEGIN
    NEW(p,vars);
    EnterName(p,str);
    WITH p^ DO
      idtyp := tp;
      klass := vars;
      indaccess := FALSE;
      vlevel := 0;
      vaddr := ad;
      state := absolute;
      vkind := noparam;
      vlink := NIL;
    END; 
  END EnterVar;
    
  PROCEDURE EnterParam(tp: Stptr; ad: CARDINAL; vk: Varkind; VAR np: Idptr); 
    VAR p : Idptr;
  BEGIN
    NEW(p,vars);
    WITH p^ DO
      name := 0; idtyp := tp;
      globmodp := mainmodp;
      klass := vars;
      indaccess := vk = varparam;
      vlevel := 1;
      vaddr := ad;
      state := local;
      vkind := vk;
      vlink := 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;
    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('CODE',codesy);
    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);
  END InitResWords;

  PROCEDURE InitStandards;
    VAR niltypeptr : Stptr;
        parp : Idptr;
        prp : Stptr;
        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); (* 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, MaxCard);
    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('CAP', capf);
    EnterFunc('CHR', chrf);
    EnterFunc('FLOAT', fltf);
    EnterFunc('HIGH', higf);
    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,MaxCard);
    EnterType('WORD',wordptr);
    EnterType('PROCESS',processptr);
    EnterType('ADDRESS',addrptr);
    EnterProc('NEWPROCESS',nprp,NIL);    (* SYSTEM procedures *)
    EnterProc('TRANSFER',trsp,NIL);
    EnterFunc('ADR', adrf);              (* SYSTEM functions *)
    EnterFunc('SIZE', sizf);
    EnterFunc('TSIZE', tszf);
    EnterFunc('REGISTER', regf);
    EnterFunc('UNIXCALL', uxcf);
    EnterFunc('CCALL', ccaf);
    EnterProc('CALLEXTPROC', ccap, NIL);
    EnterFunc('CALLEXTFUNC', ccaf);

(*  Set up the SYSTEM constants for the target machine.
    The following code is independent of target machine
    wordlength and bit ordering, but does assume two's 
    complement arithmetic.
*)

    EnterConst("BYTESPERWORD", intcarptr, BytesperWord);
    EnterConst("BITSPERWORD", intcarptr, BitsperWord);
    EnterConst("MAXINT", intcarptr, CARDINAL(MaxInt));
    EnterConst("MININT", intcarptr, CARDINAL(MinInt));
    EnterConst("MAXCARD", cardptr, MaxCard);
    EnterConst("MOSTSIGBIT", intcarptr, MostSigBit);
    EnterConst("LEASTSIGBIT", intcarptr, LeastSigBit);

    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); (* 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
    InitIdTab;
    InitResWords;
    InitStandards;
  END InitIdTables;

END MCP1Ident.