compiler/src/voc07R/ORB.Mod

MODULE ORB;   (*NW 7.10.2013   in Oberon-07*)
  IMPORT Files, ORS, S := SYSTEM;
  TYPE BYTE = S.BYTE;
  (*Definition of data types Object and Type, which together form the data structure
    called "symbol table". Contains procedures for creation of Objects, and for search:
    NewObj, this, thisimport, thisfield (and OpenScope, CloseScope).
    Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures
    Import and Export. This module contains the list of standard identifiers, with which
    the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *)

  CONST versionkey* = 1; maxTypTab = 64;
    (* class values*) Head* = 0;
      Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
      SProc* = 6; SFunc* = 7; Mod* = 8;

    (* form values*)
      Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;
      Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10;
      String* = 11; Array* = 12; Record* = 13;
      
  TYPE Object* = POINTER TO ObjDesc;
    Module* = POINTER TO ModDesc;
    Type* = POINTER TO TypeDesc;

    ObjDesc*= RECORD
      class*, lev*, exno*: INTEGER;
      expo*, rdo*: BOOLEAN;   (*exported / read-only*)
      next*, dsc*: Object;
      type*: Type;
      name*: ORS.Ident;
      val*: LONGINT
    END ;

    ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ;

    TypeDesc* = RECORD
      form*, ref*, mno*: INTEGER;  (*ref is only used for import/export*)
      nofpar*: INTEGER;  (*for procedures, extension level for records*)
      len*: LONGINT;  (*for arrays, len < 0 => open array; for records: adr of descriptor*)
      dsc*, typobj*: Object;
      base*: Type;  (*for arrays, records, pointers*)
      size*: LONGINT;  (*in bytes; always multiple of 4, except for Byte, Bool and Char*)
    END ;

  (* Object classes and the meaning of "val":
    class    val
    ----------
    Var      address
    Par      address
    Const    value
    Fld      offset
    Typ      type descriptor (TD) address
    SProc    inline code number
    SFunc    inline code number
    Mod      key

  Type forms and the meaning of "dsc" and "base":
    form     dsc      base
    ------------------------
    Pointer  -        type of dereferenced object
    Proc     params   result type
    Array    -        type of elements
    Record   fields   extension *)

  VAR topScope*, universe, system*: Object;
    byteType*, boolType*, charType*: Type;
    intType*, realType*, setType*, nilType*, noType*, strType*: Type;
    nofmod, Ref: INTEGER;
    typtab: ARRAY maxTypTab OF Type;

  PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER);  (*insert new Object with name id*)
    VAR new, x: Object;
  BEGIN x := topScope;
    WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ;
    IF x.next = NIL THEN
      NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;
      x.next := new; obj := new
    ELSE obj := x.next; ORS.Mark("mult def")
    END 
  END NewObj;

  PROCEDURE thisObj*(): Object;
    VAR s, x: Object;
  BEGIN s := topScope;
    REPEAT x := s.next;
      WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ;
      s := s.dsc
    UNTIL (x # NIL) OR (s = NIL);
    RETURN x
  END thisObj;

  PROCEDURE thisimport*(mod: Object): Object;
    VAR obj: Object;
  BEGIN
    IF mod.rdo THEN
      IF mod.name[0] # 0X THEN
        obj := mod.dsc;
        WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END
      ELSE obj := NIL
      END
    ELSE obj := NIL
    END ;
    RETURN obj
  END thisimport;

  PROCEDURE thisfield*(rec: Type): Object;
    VAR fld: Object;
  BEGIN fld := rec.dsc;
    WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ;
    RETURN fld
  END thisfield;

  PROCEDURE OpenScope*;
    VAR s: Object;
  BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s
  END OpenScope;

  PROCEDURE CloseScope*;
  BEGIN topScope := topScope.dsc
  END CloseScope;

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

  PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR);
    VAR i, j: INTEGER;
  BEGIN i := 0; j := 0;  (*assume name suffix less than 4 characters*)
    WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
    REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
    FName[i] := 0X
  END MakeFileName;
  
  PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object;
    VAR mod: Module; obj, obj1: Object;
  BEGIN obj1 := topScope; obj := obj1.next;  (*search for module*)
    WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ;
    IF obj = NIL THEN  (*insert new module*)
      NEW(mod); mod.class := Mod; mod.rdo := FALSE;
      mod.name := name; mod.orgname := orgname; mod.val := key;
      mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL;
      obj1.next := mod; obj := mod
    ELSE (*module already present*)
      IF non THEN ORS.Mark("invalid import order") END
    END ;
    RETURN obj
  END ThisModule;
  
  PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
    VAR b: BYTE;
  BEGIN 
     (*Files.ReadByte(R, b);*)
     Files.ReadBytes(R, b, 1);
    (*IF b < 80H THEN x := b ELSE x := b - 100H END*)
    IF S.VAL(SHORTINT, b) < 128 THEN x := S.VAL(SHORTINT, b) ELSE x := S.VAL(SHORTINT, b) - 100H END
  END Read;
  
  PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type);
    VAR key: LONGINT;
      ref, class, mno, form, np, readonly: INTEGER;
      new, fld, par, obj, mod, impmod: Object;
      t: Type;
      name, modname: ORS.Ident;
  BEGIN Read(R, ref);
    IF ref < 0 THEN T := typtab[-ref]  (*already read*)
    ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev;
      Read(R, form); t.form := form;
      IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4
      ELSIF form = Array THEN
        InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size)
      ELSIF form = Record THEN
        InType(R, thismod, t.base);
        IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ;
        Files.ReadNum(R, t.len); (*TD adr/exno*)
        (*Files.ReadNum(R, t.nofpar);*)  (*ext level*)
        Files.ReadInt(R, t.nofpar);  (*ext level*)
        Files.ReadNum(R, t.size);
        Read(R, class);
        WHILE class # 0 DO  (*fields*)
          NEW(fld); fld.class := class; Files.ReadString(R, fld.name);
          IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ;
          Files.ReadNum(R, fld.val); fld.next := obj; obj := fld; Read(R, class)
        END ;
        t.dsc := obj
      ELSIF form = Proc THEN
        InType(R, thismod, t.base);
        obj := NIL; np := 0; Read(R, class);
        WHILE class # 0 DO  (*parameters*)
          NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1; 
          InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class)
        END ;
        t.dsc := obj; t.nofpar := np; t.size := 4
      END ;
      Files.ReadString(R, modname);
      IF modname[0] #  0X THEN  (*re-import*)
        (*Files.ReadInt(R, key); Files.ReadString(R, name);*)
        Files.ReadNum(R, key); Files.ReadString(R, name);
        mod := ThisModule(modname, modname, FALSE, key);
        obj := mod.dsc;  (*search type*)
        WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ;
        IF obj # NIL THEN T := obj.type   (*type object found in object list of mod*)
        ELSE (*insert new type object in object list of mod*)
          NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t;
          t.mno := mod.lev; T := t
        END ;
        typtab[ref] := T
      END
    END
  END InType;
  
  PROCEDURE Import*(VAR modid, modid1: ORS.Ident);
    VAR key: LONGINT; class, k: INTEGER;
      obj: Object;  t: Type;
      thismod: Object;
      modname, fname: ORS.Ident;
      F: Files.File; R: Files.Rider;
  BEGIN
    IF modid1 = "SYSTEM" THEN
      thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod);
      thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE
    ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname);
      IF F # NIL THEN
        Files.Set(R, F, 0); 
	(*Files.ReadInt(R, key); Files.ReadInt(R, key);*)
	Files.ReadNum(R, key); Files.ReadNum(R, key);
	Files.ReadString(R, modname);
        thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE;
        Read(R, class); (*version key*)
        IF class # versionkey THEN ORS.Mark("wrong version") END ;
        Read(R, class);
        WHILE class # 0 DO
          NEW(obj); obj.class := class; Files.ReadString(R, obj.name);
          InType(R, thismod, obj.type); obj.lev := -thismod.lev;
          IF class = Typ THEN
            t := obj.type; t.typobj := obj; Read(R, k);  (*fixup bases of previously declared pointer types*)
            WHILE k # 0 DO typtab[k].base := t; Read(R, k) END
          ELSE
            IF class = Const THEN
              IF obj.type.form = Real THEN 
	         (*Files.ReadInt(R, obj.val) *)
	         Files.ReadNum(R, obj.val) 
	      ELSE 
	         Files.ReadNum(R, obj.val)
	      END
            ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
            END
          END ;
          obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class)
        END ;
      ELSE ORS.Mark("import not available")
      END
    END
  END Import;
  
  (*-------------------------------- Export ---------------------------------*)

  PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
  BEGIN 
  (*Files.WriteByte(R, x)*)  (* -128 <= x < 128 *)
  Files.WriteByte(R, SHORT(x))  (* -128 <= x < 128 *)
  END Write;

  PROCEDURE OutType(VAR R: Files.Rider; t: Type);
    VAR obj, mod, fld: Object;

    PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER);
      VAR cl: INTEGER;
    BEGIN
      IF n > 0 THEN
        OutPar(R, par.next, n-1); cl := par.class;
        Write(R, cl);
        IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ;
        OutType(R, par.type)
      END
    END OutPar;

    PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT);
      VAR fld: Object; i, n: LONGINT;
    BEGIN
      IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset)
      ELSIF typ.form = Record THEN fld := typ.dsc;
        WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END
      ELSIF typ.form = Array THEN i := 0; n := typ.len;
        WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END
      END
    END FindHiddenPointers;

  BEGIN
    IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref)
    ELSE obj := t.typobj;
      IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ;
      Write(R, t.form);
      IF t.form = Pointer THEN
        IF t.base.ref > 0 THEN Write(R, -t.base.ref)
        ELSIF (t.base.typobj = NIL) OR ~t.base.typobj.expo THEN (*base not exported*) Write(R, -1)
        ELSE OutType(R, t.base)
        END
      ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size)
      ELSIF t.form = Record THEN
        IF t.base # NIL THEN OutType(R, t.base) ELSE OutType(R, noType) END ;
        IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ;
        Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size);
        fld := t.dsc;
        WHILE fld # NIL DO  (*fields*)
          IF fld.expo THEN
            Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val)
          ELSE FindHiddenPointers(R, fld.type, fld.val)
          END ;
          fld := fld.next
        END ;
         Write(R, 0)
      ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0)
      END ;
      IF (t.mno > 0) & (obj # NIL) THEN  (*re-export, output name*)
        mod := topScope.next;
        WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ;
        IF mod # NIL THEN Files.WriteString(R, mod.name); 
	(*Files.WriteInt(R, mod.val); *)
	Files.WriteNum(R, mod.val); 
	Files.WriteString(R, obj.name)
        ELSE ORS.Mark("re-export not found"); Write(R, 0)
        END
      ELSE Write(R, 0)
      END
    END
  END OutType;

  PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT);
    VAR x, sum, oldkey: LONGINT;
      obj, obj0: Object;
      filename: ORS.Ident;
      F, F1: Files.File; R, R1: Files.Rider;
  BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb");
    F := Files.New(filename); Files.Set(R, F, 0);
    Files.WriteInt(R, 0); (*placeholder*)
    Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*)
    Files.WriteString(R, modid); Write(R, versionkey);
    obj := topScope.next;
    WHILE obj # NIL DO
      IF obj.expo THEN
        Write(R, obj.class); Files.WriteString(R, obj.name);
        OutType(R, obj.type);
        IF obj.class = Typ THEN
          IF obj.type.form = Record THEN
            obj0 := topScope.next;  (*check whether this is base of previously declared pointer types*)
            WHILE obj0 # obj DO
              IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ;
              obj0 := obj0.next
            END
          END ;
          Write(R, 0)
        ELSIF obj.class = Const THEN
          IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno)
          ELSIF obj.type.form = Real THEN 
	     (*Files.WriteInt(R, obj.val)*)
	     Files.WriteNum(R, obj.val)
          ELSE Files.WriteNum(R, obj.val)
          END
        ELSIF obj.class = Var THEN
          Files.WriteNum(R, obj.exno);
          IF obj.type.form = String THEN
            Files.WriteNum(R, obj.val DIV 10000H); obj.val := obj.val MOD 10000H
          END
        END
      END ;
      obj := obj.next
    END ;
    REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0;
    FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ;
    Files.Set(R, F, 0); sum := 0;  (* compute key (checksum) *)
    WHILE ~R.eof DO 
       (*Files.ReadInt(R, x); *)
       Files.ReadNum (R, x); 
       sum := sum + x 
    END ;
    F1 := Files.Old(filename); (*sum is new key*)
    IF F1 # NIL THEN 
       Files.Set(R1, F1, 4); 
       (*Files.ReadInt(R1, oldkey) *)
       Files.ReadNum(R1, oldkey) 
    ELSE 
       oldkey := sum+1 
    END ;
    IF sum # oldkey THEN
      IF newSF THEN
        key := sum; Files.Set(R, F, 4); 
	(*Files.WriteInt(R, sum); *)
	Files.WriteNum(R, sum); 
	Files.Register(F)  (*insert checksum*)
      ELSE ORS.Mark("new symbol file inhibited")
      END
    ELSE newSF := FALSE; key := sum
    END
  END Export;

  PROCEDURE Init*;
  BEGIN topScope := universe; nofmod := 1
  END Init;
  
  PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type;
    VAR tp: Type;
  BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL;
    typtab[ref] := tp; RETURN tp
  END type;

  PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT);
    VAR obj: Object;
  BEGIN 
     NEW(obj); 
     (*obj.name := name; *)
     COPY(name, obj.name); 
     obj.class := cl; obj.type := type; obj.val := n; obj.dsc := NIL;
    IF cl = Typ THEN type.typobj := obj END ;
    obj.next := system; system := obj
  END enter;
  
BEGIN
  byteType := type(Byte, Int, 1);
  boolType := type(Bool, Bool, 1);
  charType := type(Char, Char,1);
  intType := type(Int, Int, 4);
  realType := type(Real, Real, 4);
  setType := type(Set, Set,4);
  nilType := type(NilTyp, NilTyp, 4);
  noType := type(NoTyp, NoTyp, 4);
  strType := type(String, String, 8);
    
  (*initialize universe with data types and in-line procedures;
    LONGINT is synonym to INTEGER, LONGREAL to REAL.
    LED, ADC, SBC; LDPSR, LDREG, REG, COND, MSK are not in language definition*)
  system := NIL;  (*n = procno*10 + nofpar*)
  enter("UML", SFunc, intType, 132);  (*functions*)
  enter("SBC", SFunc, intType, 122);
  enter("ADC", SFunc, intType, 112);
  enter("ROR", SFunc, intType, 92);
  enter("ASR", SFunc, intType, 82);
  enter("LSL", SFunc, intType, 72);
  enter("LEN", SFunc, intType, 61);
  enter("CHR", SFunc, charType, 51);
  enter("ORD", SFunc, intType, 41);
  enter("FLT", SFunc, realType, 31);
  enter("FLOOR", SFunc, intType, 21);
  enter("ODD", SFunc, boolType, 11);
  enter("ABS", SFunc, intType, 1);
  enter("LED", SProc, noType, 81);  (*procedures*)
  enter("UNPK", SProc, noType, 72);
  enter("PACK", SProc, noType, 62);
  enter("NEW", SProc, noType, 51);
  enter("ASSERT", SProc, noType, 41);
  enter("EXCL", SProc, noType, 32);
  enter("INCL", SProc, noType, 22);
  enter("DEC", SProc, noType, 11);
  enter("INC", SProc, noType, 1);
  enter("SET", Typ, setType, 0);   (*types*)
  enter("BOOLEAN", Typ, boolType, 0);
  enter("BYTE", Typ, byteType, 0);
  enter("CHAR", Typ, charType, 0);
  enter("LONGREAL", Typ, realType, 0);
  enter("REAL", Typ, realType, 0);
  enter("LONGINT", Typ, intType, 0);
  enter("INTEGER", Typ, intType, 0);
  topScope := NIL; OpenScope; topScope.next := system; universe := topScope;
  
  system := NIL;  (* initialize "unsafe" pseudo-module SYSTEM*)
  enter("H", SFunc, intType, 201);     (*functions*)
  enter("COND", SFunc, boolType, 191);
  enter("SIZE", SFunc, intType, 181);
  enter("ADR", SFunc, intType, 171);
  enter("VAL", SFunc, intType, 162);
  enter("REG", SFunc, intType, 151);
  enter("BIT", SFunc, boolType, 142);
  enter("LDREG", SProc, noType, 142);  (*procedures*)
  enter("LDPSR", SProc, noType, 131);
  enter("COPY", SProc, noType, 123);
  enter("PUT", SProc, noType, 112);
  enter("GET", SProc, noType, 102);
END ORB.