(*************************************************************************

     $RCSfile: ODT.mod $
  Description: Symbol table handler for OD.

               This module is adapted from Modules OCG and OCT, which are
               part of the Oberon-A compiler 'OC'.

   Created by: fjc (Frank Copeland)
    $Revision: 1.3 $
      $Author: fjc $
        $Date: 1994/08/08 16:35:10 $

  Copyright © 1994, Frank Copeland.
  This file is part of Oberon-A.
  See Oberon-A.doc for conditions of use and distribution.

  Log entries are at the end of the file.

*************************************************************************)

MODULE ODT;

(*
** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
** $V= OvflChk       $Z= ZeroVars
*)

IMPORT
  SYS := SYSTEM,
  d   := Dos,
  f   := Files,
  Reals,
  str := Strings;

(*
** Object and item modes. These are the same as those declared in module
** OCG and must be updated if that module is changed.
*)

CONST

  Undef   =  0;
  Var     =  1; (* local and global variables and value parameters *)
  VarX    =  2; (* indexed array variables *)
  VarR    =  3; (* value parameter passed in a register *)
  VarArg  =  4; (* C-style vararg pushed on stack, for libcalls only *)
  Ind     =  5; (* variable parameters *)
  IndX    =  6; (* indexed dynamic array parameters *)
  IndR    =  7; (* variable parameter passed in a register *)
  RegI    =  8; (* register indirect mode with displacement *)
  RegX    =  9; (* register indirect mode with displacement and index *)
  Lab     = 10; (* absolute mode, the address of a label *)
  LabI    = 11; (* immediate mode, the address of a label *)
  Abs     = 12; (* absolute mode *)
  Con     = 13; (* constants *)
  Push    = 14; (* register indirect mode with predecrement *)
  Pop     = 15; (* register indirect mode with postincrement *)
  Coc     = 16; (* condition code *)
  Reg     = 17; (* register direct mode *)
  Fld     = 18; (* record fields *)
  Typ     = 19; (* types *)
  LProc   = 20; (* local (non-exportable) procedures *)
  XProc   = 21; (* exportable procedures *)
  SProc   = 22; (* standard procedures *)
  LibCall = 23; (* Amiga library functions *)
  TProc   = 24; (* Type-bound procedure *)
  FProc   = 25; (* Foreign procedures (such as in amiga.lib) *)
  Mod     = 26; (* Modules *)
  Head    = 27; (* symbol scope header *)
  RList   = 28; (* Register list for MOVEM *)

  (* Sizes in bytes of basic data types. *)

  ByteSize = 1; WordSize = 2; LongSize = 4;
  BoolSize = 1; CharSize = 1;
  SIntSize = 1; IntSize = 2; LIntSize = 4;
  RealSize = 4; LRealSize = RealSize;
  BSetSize = 1; WSetSize = 2; SetSize = 4;
  PtrSize  = 4; ProcSize = 4;

(*
** The following declarations are adapted from Module OCT. They must be
** updated if that module is changed.
*)

CONST

  maxImps = 32;

  (* structure forms *)
  Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5;
  LInt = 6; Real = 7; LReal = 8; BSet = 9; WSet = 10; Set = 11;
  String = 12; NilTyp = 13; NoTyp = 14; PtrTyp = 15; CPtrTyp = 16;
  BPtrTyp = 17; Word = 18; Longword = 19; TagTyp = 20;
  Pointer = 21; CPointer = 22; BPointer = 23; ProcTyp = 24;
  Array = 25; DynArr = 26; Record = 27;

  (* String lengths *)

  NameLen = 255;
  PathLen = 256;

  (* Values for visible field of ObjDesc *)

  Exp = -1;
  NotExp = 0;
  RdOnly = 1;

TYPE

  Name = ARRAY NameLen + 1 OF CHAR;
  Symbol * = POINTER TO ARRAY OF CHAR;

  Object = POINTER TO ObjDesc;
  Struct = POINTER TO StrDesc;

  ObjDesc = RECORD
    left, right, link : Object;
    typ : Struct;
    a0, a1 : LONGINT;
    a2 : INTEGER;
    mode : SHORTINT;
    visible : SHORTINT;
    name : LONGINT;
    symbol : Symbol;
  END; (* ObjDesc *)

  ActionProc = PROCEDURE (obj : Object);

  StrDesc = RECORD
    form, n, mno : INTEGER;
    size, adr : LONGINT;
    BaseTyp : Struct;
    link, strobj : Object;
  END; (* StrDesc *)

VAR
  topScope : Object;

  undftyp, bytetyp, booltyp, chartyp, sinttyp, inttyp,
  linttyp, realtyp, lrltyp, settyp, stringtyp, niltyp, notyp,
  ptrtyp, cptrtyp, bptrtyp, bsettyp, wsettyp, wordtyp,
  lwordtyp, tagtyp
    : Struct;

  nofGmod : INTEGER; (* nof imports *)
  GlbMod : ARRAY maxImps OF Object;

CONST

  SFtag = 53594D07H; (* "SYM" + version # *)
  firstStr = 32; maxStr = 512;
  maxMod = 24; maxParLev = 6;
  NotYetExp = 0;

  (* terminal symbols for symbol file elements *)
  eUndef = 0; eCon = 1; eTypE = 2; eTyp = 3; eVar = 4; eXProc = 5;
  eLibCall = 6; ePointer = 7; eProcTyp = 8; eArray = 9; eDynArr = 10;
  eRecord = 11; eParList = 12; eValPar = 13; eVarPar = 14; eValRegPar = 15;
  eVarRegPar = 16; eFldList = 17; eFld = 18; eHPtr = 19; eHProc = 20;
  eFixup = 21; eMod = 22; eBPointer = 23; eCPointer = 24; eMod0 = 25;
  eTProcE = 26; eTProc = 27; eVarArg = 28; eFProc = 29;

  (* name buffer size *)

  BufSize = 16384;
  MaxBuffers = 16;
  HashTableSize = 251;

TYPE

  NameBufPtr = POINTER TO ARRAY BufSize OF CHAR;

VAR
  universe, syslink : Object;
  SR : f.Rider;
  nameBuf : ARRAY MaxBuffers OF NameBufPtr;
  nameX, nameOrg, nameSize : LONGINT;
  nameTab, backupTab : ARRAY HashTableSize OF LONGINT;
  ObjectList : Object;
  StructList : Struct;

  (* These are assumed to have all fields zeroed by the loader. *)
  emptyObj  : ObjDesc;
  emptyStr  : StrDesc;

  indentLevel : INTEGER;
  name : Name;
  verbose * : BOOLEAN;

(*--- CONSOLE IO ---------------------------------*)

(* -------------------------------------
**
** Writes a string to the standard output.
*)

PROCEDURE PutStr ( str : ARRAY OF CHAR );
(* $D- Don't copy open arrays *)
BEGIN (* PutStr *)
  SYS.SETREG (0, d.base.PutStr (str))
END PutStr;

(*--- MEMORY MANAGEMENT ---------------------------------*)

(*------------------------------------*)
PROCEDURE AllocObj () : Object;

  VAR newObj : Object;

BEGIN (* AllocObj *)
  IF ObjectList = NIL THEN
    NEW (newObj)
  ELSE
    newObj := ObjectList; ObjectList := ObjectList.link
  END;
  newObj^ := emptyObj;
  RETURN newObj
END AllocObj;

(*------------------------------------*)
PROCEDURE FreeObj (obj : Object);

BEGIN (* FreeObj *)
  IF obj # NIL THEN
    FreeObj (obj.left); FreeObj (obj.right);
    obj^ := emptyObj;
    obj.link := ObjectList; ObjectList := obj
  END
END FreeObj;

(*------------------------------------*)
PROCEDURE AllocStruct () : Struct;

  VAR newStr : Struct;

BEGIN (* AllocStruct *)
  IF StructList = NIL THEN
    NEW (newStr)
  ELSE
    newStr := StructList; StructList := StructList.BaseTyp;
    newStr.BaseTyp := NIL
  END;
  RETURN newStr
END AllocStruct;

(*------------------------------------*)
PROCEDURE FreeStruct (str : Struct);

BEGIN (* FreeStruct *)
  IF str # NIL THEN
    FreeObj (str.link); str^ := emptyStr;
    str.BaseTyp := StructList; StructList := str
  END
END FreeStruct;

(*--- NAME TABLE HANDLER ---------------------------------*)

(*------------------------------------*)
PROCEDURE CheckBuf (size : LONGINT);

  VAR newBuf : NameBufPtr; newX : LONGINT;

BEGIN (* CheckBuf *)
  newX := nameX + size + 4;
  IF newX >= nameSize THEN
    IF newX >= BufSize * MaxBuffers THEN
      PutStr (" !! Name buffer overflow\n"); nameX := 0
    ELSE
      IF ((newX-1) MOD BufSize) < (size+4) THEN nameX := nameSize END;
      NEW (newBuf);
      INC (nameSize, BufSize);
      nameBuf [(nameSize - 1) DIV BufSize] := newBuf
    END
  END
END CheckBuf;

(*------------------------------------*)
PROCEDURE InsertName (n : ARRAY OF CHAR) : LONGINT;

  VAR i, j, k, len, bufX : INTEGER; x, x1 : LONGINT; ch : CHAR;
      buf : NameBufPtr;

(* $D- disable copying of open arrays *)
BEGIN (* InsertName *)
  k := 0; len := 0; ch := n [0];
  WHILE ch # 0X DO
    (*$V- ignore overflows*)
    INC (k, ORD (ch));
    (*$V=*)
    INC (len); ch := n [len]
  END;
  k := (k + len) MOD HashTableSize;
  x := nameTab [k];
  LOOP
    IF x = 0 THEN
      CheckBuf (len);
      buf := nameBuf [nameX DIV BufSize];
      bufX := SHORT (nameX MOD BufSize);
      buf [bufX] := CHR (nameTab [k] DIV 10000H); INC (bufX);
      buf [bufX] := CHR (nameTab [k] DIV 100H);   INC (bufX);
      buf [bufX] := CHR (nameTab [k]);            INC (bufX);
      i := 0;
      WHILE i <= len DO buf [bufX] := n [i]; INC (bufX); INC (i) END;
      x := nameX + 3; nameTab [k] := x; nameX := nameX + len + 4;
      RETURN x
    ELSE
      buf := nameBuf [x DIV BufSize];
      bufX := SHORT (x MOD BufSize);
      x1 :=
        (LONG (ORD (buf [bufX - 3])) * 10000H)
        + (LONG (ORD (buf [bufX - 2])) * 100H)
        + LONG (ORD (buf [bufX - 1]));
      i := bufX; j := 0;
      LOOP
        IF buf [i] # n [j] THEN
          x := x1; EXIT
        ELSIF n [j] = 0X THEN
          RETURN x
        ELSE
          INC (i); INC (j)
        END
      END
    END; (* ELSE *)
  END; (* LOOP *)
END InsertName;

(*------------------------------------*)
PROCEDURE NameLength (name : LONGINT) : INTEGER;

  VAR buf : NameBufPtr; len, bufX : INTEGER;

BEGIN (* NameLength *)
  buf := nameBuf [name DIV BufSize];
  bufX := SHORT (name MOD BufSize);
  len := 0;
  WHILE buf [bufX] # 0X DO INC (len); INC (bufX) END;
  RETURN len
END NameLength;

(*------------------------------------*)
PROCEDURE GetName (adr : LONGINT);

  VAR buf : NameBufPtr; i, bufX : INTEGER; ch :  CHAR;

BEGIN (* GetName *)
  buf := nameBuf [adr DIV BufSize];
  bufX := SHORT (adr MOD BufSize);
  i := 0;
  REPEAT
    ch := buf [bufX]; name [i] := ch;
    INC (i); INC (bufX)
  UNTIL ch = 0X;
END GetName;

(*--- TABLE INSERTION ---------------------------------*)

(*------------------------------------*)
PROCEDURE InsertObj
  ( VAR name : ARRAY OF CHAR; root : Object; mode : SHORTINT;
    VAR res : Object ) : BOOLEAN;

  VAR
    obj, prev : Object; result : BOOLEAN;
    buf : NameBufPtr; n1, n2 : LONGINT; bufX, i : INTEGER; ch1, ch2 : CHAR;

BEGIN (* InsertObj *)
  prev := root; obj := root.link; n1 := InsertName (name);
  WHILE (obj # NIL) & (obj.name # n1) DO
    prev := obj; n2 := obj.name; i := 0;
    buf := nameBuf [n2 DIV BufSize]; bufX := SHORT (n2 MOD BufSize);
    REPEAT
      ch1 := name [i]; INC (i);
      ch2 := buf [bufX]; INC (bufX)
    UNTIL ch1 # ch2;
    IF ch1 < ch2 THEN obj := obj.left
    ELSE obj := obj.right
    END
  END;
  IF obj = NIL THEN
    obj := AllocObj (); obj.name := n1; obj.mode := mode;
    IF prev = root THEN
      root.link := obj
    ELSE
      IF ch1 < ch2 THEN prev.left := obj
      ELSE prev.right := obj
      END
    END;
    result := TRUE
  ELSE
    result := FALSE
  END;
  res := obj;
  RETURN result
END InsertObj;

(*------------------------------------*)
PROCEDURE Insert
  ( VAR name : ARRAY OF CHAR;
    VAR res : Object;
    mode : SHORTINT );

BEGIN (* Insert *)
  IF ~InsertObj (name, topScope, mode, res) THEN
    IF res.mode # Undef THEN PutStr (" !! name used twice\n") END;
    res.mode := mode
  END
END Insert;

(*------------------------------------*)
PROCEDURE OpenScope (level : INTEGER);

  VAR head : Object;

BEGIN (* OpenScope *)
  head := AllocObj ();
  head.mode := Head; head.a0 := level; head.left := topScope;
  topScope := head;
END OpenScope;

(*------------------------------------*)
PROCEDURE CloseScope ();

  VAR oldHead : Object;

BEGIN (* CloseScope *)
  oldHead := topScope; topScope := topScope.left;
  oldHead^ := emptyObj; oldHead.link := ObjectList; ObjectList := oldHead;
END CloseScope;

(*--- MODULE INITIALISATION ---------------------------------*)

(*------------------------------------*)
PROCEDURE Init * ();

BEGIN (* Init *)
  topScope := universe; nofGmod := 0
END Init;

(*------------------------------------*)
PROCEDURE Close * ();

  VAR i : INTEGER;

BEGIN (* Close *)
  f.Set (SR, NIL, 0);
  i := 0; WHILE i < maxImps DO GlbMod [i] := NIL; INC (i) END;
  (* Restore original hash table for reserved names... *)
  nameTab := backupTab; nameX := nameOrg;
  (* ... Assuming that only one name buffer is required *)
  nameSize := BufSize;
  i := 1; WHILE i < MaxBuffers DO nameBuf [i] := NIL; INC (i) END
END Close;

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

(*------------------------------------*)
PROCEDURE ReadInt(VAR i: LONGINT);
(*
  Reads integers written in a compacted form. Taken from J. Templ.
  SPARC-Oberon. User's Guide and Implementation. Computersysteme ETH
  Zürich, Technical Report No. 133, June 1990.
*)

  VAR n: LONGINT; s: INTEGER; x: CHAR;

BEGIN
  s := 0; n := 0; f.Read(SR, x);
  WHILE ORD(x) >= 128 DO
    INC(n, ASH(ORD(x) - 128, s)); INC(s, 7); f.Read(SR, x)
  END;
  i := n + ASH(ORD(x) MOD 64 - ORD(x) DIV 64 * 64, s)
END ReadInt;

(*------------------------------------*)
PROCEDURE ReadLInt (VAR k : LONGINT);

BEGIN (* ReadLInt *)
  f.ReadBytes (SR, k, 4);
END ReadLInt;

(*------------------------------------*)
PROCEDURE ReadId (VAR id : ARRAY OF CHAR);

  VAR i : INTEGER; ch : CHAR;

BEGIN (* ReadId *)
  i := 0;
  REPEAT
    f.Read (SR, ch); id [i] := ch; INC (i)
  UNTIL ch = 0X;
END ReadId;

(*------------------------------------*)
PROCEDURE Import *
  ( FileName : ARRAY OF CHAR;
    VAR name : ARRAY OF CHAR )
  : BOOLEAN;

  VAR
    i, m, s, nofLmod, strno, parlev, fldlev : INTEGER;
    k, l, modname : LONGINT;
    obj : Object;
    modobj : Object;
    class : SHORTINT;
    SymFile : f.File;
    LocMod : ARRAY maxMod OF Object;
    struct : ARRAY maxStr OF Struct;
    lastpar, lastfld : ARRAY maxParLev OF Object;
    result : BOOLEAN;

    link : Object;
    typ : Struct;
    a0, a1 : LONGINT;
    a2 : INTEGER;
    mode : SHORTINT;
    visible : SHORTINT;
    symbol : Symbol;
    objName : ARRAY NameLen+1 OF CHAR;

  (*------------------------------------*)
  PROCEDURE reversedList (p : Object) : Object;

    VAR q, r : Object;

  BEGIN (* reversedList *)
    q := NIL;
    WHILE p # NIL DO r := p.link; p.link := q; q := p; p := r END;
    RETURN q
  END reversedList;

  (*------------------------------------*)
  PROCEDURE reversedList2 (p : Object) : Object;

    VAR q, r : Object;

  BEGIN (* reversedList2 *)
    q := NIL;
    WHILE p # NIL DO r := p.left; p.left := q; q := p; p := r END;
    RETURN q
  END reversedList2;

(* $D- Don't copy arrays *)
BEGIN (* Import *)
  result := FALSE;
  nofLmod := 0; strno := firstStr; parlev := -1; fldlev := -1;
  SymFile := f.Old (FileName);
  IF SymFile # NIL THEN
    PutStr ("\x9B\x4B << "); PutStr (FileName); PutStr ("\r");
    f.Set (SR, SymFile, 0); ReadLInt (k);
    IF k = SFtag THEN
      struct [Undef] := undftyp; struct [Byte] := bytetyp;
      struct [Bool] := booltyp; struct [Char] := chartyp;
      struct [SInt] := sinttyp; struct [Int] := inttyp;
      struct [LInt] := linttyp; struct [Real] := realtyp;
      struct [LReal] := lrltyp; struct [Set] := settyp;
      struct [String] := stringtyp; struct [NilTyp] := niltyp;
      struct [NoTyp] := notyp; struct [BSet] := bsettyp;
      struct [WSet] := wsettyp; struct [PtrTyp] := ptrtyp;
      struct [CPtrTyp] := cptrtyp; struct [BPtrTyp] := bptrtyp;
      struct [Word] := wordtyp; struct [Longword] := lwordtyp;
      struct [TagTyp] := tagtyp;
      LOOP (* read next item from symbol file *)
        f.Read (SR, class); IF SR.eof THEN EXIT END;
        link := NIL; typ := NIL; a0 := 0; a1 := 0; a2 := 0;
        mode := Undef; visible := NotExp; symbol := NIL;
        objName := "";
        CASE class OF
          eUndef : PutStr (" !! Corrupt symbol file\n")
          |
          eCon .. eXProc, eFProc : (* object *)
            m := 0; ReadInt (l); s := SHORT (l); typ := struct [s];
            CASE class OF
              eCon :
                mode := Con;
                CASE typ.form OF
                  Byte, Char, BSet, Bool, SInt, Int, WSet,
                  Word, LInt, Real, LReal, Set, Longword :
                    ReadInt (a0);
                  |
                  (*LReal : ReadInt (a0); ReadInt (a1);
                  |*)
                  String :
                    ReadInt (a0); ReadInt (a1);
                    IF a1 <= 2 THEN
                      ReadInt (l); a2 := SHORT (l)
                    END
                  |
                  NilTyp : (* NIL *)
                  |
                  CPtrTyp, BPtrTyp, CPointer, BPointer, ProcTyp :
                    (* This is all VERY dodgy, but ... *)
                    ReadInt (a0)
                  |
                ELSE
                  PutStr (" !! Unrecognised form in symbol file\n")
                END; (* CASE obj.typ.form *)
              |
              eTypE, eTyp :
                mode := Typ; ReadInt (l); m := SHORT (l);
                IF class = eTypE THEN visible := Exp
                ELSE visible := NotExp
                END
              |
              eVar :
                mode := Var; ReadInt (a0); f.Read (SR, visible)
              |
              eXProc :
                mode := XProc; link := reversedList (lastpar [parlev]);
                DEC (parlev);
              |
            eFProc :
              mode := FProc;
              link := reversedList (lastpar [parlev]); DEC (parlev);
              ReadId (objName); NEW (symbol, str.Length (objName) + 1);
              COPY (objName, symbol^)
            |
            ELSE
              PutStr (" !! Unrecognised class in symbol file\n")
            END; (* CASE class *)
            ReadId (objName);
            IF InsertObj (objName, LocMod [m], mode, obj) THEN
              obj.link := link; obj.typ := typ; obj.a0 := a0;
              obj.a1 := a1; obj.a2 := a2; obj.visible := visible;
              obj.symbol := symbol;
              IF mode = Typ THEN
                IF typ.strobj = NIL THEN typ.strobj := obj END
              END;
            ELSIF mode = Typ THEN
              FreeStruct (typ); struct [s] := obj.typ
            END
          |
          ePointer .. eRecord, eBPointer, eCPointer :
            (* structure *)
            typ := AllocStruct (); typ.strobj := NIL;
            ReadInt (l); typ.BaseTyp := struct [l];
            ReadInt (l); typ.mno := SHORT (LocMod [l].a0);
            CASE class OF
              ePointer, eBPointer, eCPointer :
                typ.size := PtrSize; typ.n := 0;
                IF class = ePointer THEN
                  typ.form := Pointer; ReadInt (typ.adr);
                  IF typ.BaseTyp.form = DynArr THEN
                    typ.size := typ.BaseTyp.size;
                  END
                ELSIF class = eCPointer THEN typ.form := CPointer
                ELSE typ.form := BPointer
                END;
              |
              eProcTyp :
                typ.form := ProcTyp; typ.size := ProcSize;
                typ.link := reversedList (lastpar [parlev]);
                DEC (parlev);
              |
              eArray :
                typ.form := Array; ReadInt (typ.size);
                ReadInt (typ.adr); ReadInt (l); typ.n := SHORT (l);
              |
              eDynArr :
                typ.form := DynArr; ReadInt (typ.size);
                ReadInt (typ.adr);
              |
              eRecord :
                typ.form := Record;
                ReadInt (typ.size); typ.n := 0;
                typ.link := reversedList2 (lastfld [fldlev]);
                DEC (fldlev);
                IF typ.BaseTyp = notyp THEN
                  typ.BaseTyp := NIL; typ.n := 0;
                ELSE
                  typ.n := typ.BaseTyp.n + 1;
                END;
                ReadInt (typ.adr); (* of descriptor *)
              |
            ELSE
              PutStr (" !! Unrecognised class in symbol file\n")
            END; (* CASE class *)
            struct [strno] := typ; INC (strno);
          |
          eParList : (* parameter list start *)
            IF parlev < maxParLev - 1 THEN
              INC (parlev); lastpar [parlev] := NIL;
            ELSE
              PutStr (" !! Too many parameter lists\n")
            END
          |
          eValPar, eVarPar, eValRegPar, eVarRegPar, eVarArg :
          (* parameter *)
            obj := AllocObj ();
            IF class = eValPar THEN obj.mode := Var
            ELSIF class = eVarPar THEN obj.mode := Ind
            ELSIF class = eValRegPar THEN obj.mode := VarR
            ELSIF class = eVarRegPar THEN obj.mode := IndR
            ELSE obj.mode := VarArg
            END;
            ReadInt (l); obj.typ := struct [l];
            ReadInt (obj.a0); ReadId (objName);
            obj.name := InsertName (objName);
            obj.link := lastpar [parlev]; lastpar [parlev] := obj
          |
          eFldList : (* start field list *)
            IF fldlev < maxParLev - 1 THEN
              INC (fldlev); lastfld [fldlev] := NIL;
            ELSE
              PutStr (" !! Too many field lists\n")
            END
          |
          eFld :
            obj := AllocObj ();  obj.mode := Fld; obj.link := NIL;
            ReadInt (l); obj.typ := struct [l];
            ReadInt (obj.a0); f.Read (SR, obj.visible);
            ReadId (objName); obj.name := InsertName (objName);
            obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
          |
          eLibCall : (* library call procedure *)
            obj := AllocObj (); obj.mode := LibCall;
            ReadInt (l); typ := struct [l];
            ReadInt (l); obj.typ := struct [l];
            ReadInt (obj.a0); ReadId (objName);
            obj.name := InsertName (objName); obj.visible := Exp;
            obj.link := reversedList (lastpar [parlev]); DEC (parlev);
            obj.left := typ.link; typ.link := obj

          |
          eTProcE : (* exported type-bound procedure *)
            obj := AllocObj (); obj.mode := TProc;
            ReadInt (l); typ := struct [l];
            ReadInt (l); obj.typ := struct [l];
            ReadInt (obj.a0); ReadId (objName);
            obj.name := InsertName (objName);
            obj.a1 := typ.n; obj.visible := Exp;
            obj.link := reversedList (lastpar [parlev]); DEC (parlev);
            obj.link.a2 := -1; obj.left := typ.link; typ.link := obj;
          |
          eTProc : (* hidden type-bound procedure *)
            obj := AllocObj (); obj.mode := TProc; obj.typ := notyp;
            ReadInt (l); typ := struct [l];
            ReadInt (obj.a0); obj.name := -1; obj.visible := NotExp;
            obj.link := NIL; obj.left := typ.link; typ.link := obj;
          |
          eHPtr : (* hidden pointer field *)
            obj := AllocObj (); obj.mode := Fld;
            ReadInt (obj.a0); obj.name := -1; obj.typ := notyp;
            obj.visible := NotExp; obj.link := NIL;
            obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
          |
          eHProc : (* hidden procedure field *)
            ReadInt (l);
          |
          eFixup : (* fixup pointer typ *)
            ReadInt (l); typ := struct [l];
            ReadInt (l);
            IF typ.BaseTyp = undftyp THEN
              typ.BaseTyp := struct [l];
              IF typ.BaseTyp.form = DynArr THEN
                typ.size := typ.BaseTyp.size;
              END
            END
          |
          eMod, eMod0 : (* module anchor *)
            ReadLInt (k);
            ReadId (objName); modname := InsertName (objName);
            IF nofLmod = 0 THEN COPY (objName, name) END;
            i := 0;
            WHILE (i < nofGmod) & (modname # GlbMod [i].name) DO
              INC (i);
            END;
            IF i < nofGmod THEN (* module already present *)
              IF k # GlbMod [i].a1 THEN
                PutStr (" !! Bad key for imported module\n")
              END;
              modobj := GlbMod [i];
            ELSE
              NEW (modobj);
              IF nofGmod < maxImps THEN
                GlbMod [nofGmod] := modobj; INC (nofGmod);
              ELSE
                PutStr (" !! Too many global modules\n")
              END;
              modobj.mode := NotYetExp; modobj.name := modname;
              modobj.a1 := k; modobj.a0 := nofGmod;
              modobj.link := NIL; modobj.visible := NotExp;
              IF class = eMod THEN modobj.a2 := 0 ELSE modobj.a2 := 1 END;
            END;
            IF nofLmod < maxMod THEN
              LocMod [nofLmod] := modobj; INC (nofLmod)
            ELSE
              PutStr (" !! Too many local modules\n")
            END
          |
        ELSE
          PutStr (" !! Unrecognised class in symbol file\n");
        END; (* CASE class *)
      END; (* LOOP *)
      OpenScope (1); topScope.link := LocMod [0].link;
      result := TRUE
    ELSE
      PutStr (" !! Bad symbol file tag\n")
    END;
    f.Close (SymFile); f.Set (SR, NIL, 0)
  ELSE
    PutStr (" !! Could not open ");
    PutStr (FileName); PutStr ("\n")
  END;
  RETURN result
END Import;

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

(*------------------------------------*)
PROCEDURE Write ( ch : CHAR );
BEGIN
  f.Write (SR, ch)
END Write;

(*------------------------------------*)
PROCEDURE WriteStr ( str : ARRAY OF CHAR );
BEGIN
  f.WriteBytes (SR, str, SYS.STRLEN (str))
END WriteStr;

(*------------------------------------*)
PROCEDURE Indent ();

  VAR i : INTEGER;

BEGIN
  FOR i := 1 TO indentLevel DO
    Write (" "); Write (" ")
  END
END Indent;

(*------------------------------------*)
PROCEDURE WriteInt ( val : LONGINT );

  VAR i : INTEGER; x0 : LONGINT; a : ARRAY 11 OF CHAR;

BEGIN (* WriteInt *)
  i := 0;
  IF val < 0 THEN
    IF val = MIN (LONGINT) THEN WriteStr ("-2147483648"); RETURN
    ELSE x0 := -val
    END
  ELSE x0 := val
  END;
  REPEAT
    a [i] := CHR (x0 MOD 10 + 30H); x0 := x0 DIV 10; INC (i)
  UNTIL x0 = 0;
  IF val < 0 THEN Write ("-") END;
  REPEAT DEC (i); Write (a [i]) UNTIL i = 0
END WriteInt;

(*------------------------------------*)
PROCEDURE WriteHex ( val : LONGINT );

  VAR i : INTEGER; y : LONGINT; a : ARRAY 10 OF CHAR;

BEGIN (* WriteHex *)
  i := 0; Write ("0");
  REPEAT
    y := val MOD 10H;
    IF y < 10 THEN a [i] := CHR (y + 30H) ELSE a [i] := CHR (y + 37H) END;
    val := val DIV 10H; INC (i)
  UNTIL (val = 0) OR (i = 8);
  REPEAT DEC (i); Write (a [i]) UNTIL i = 0
END WriteHex;

(*------------------------------------*)
PROCEDURE WriteReal ( val : LONGINT );

  VAR e, n : INTEGER; x, x0 : REAL; d : ARRAY 9 OF CHAR;

BEGIN (* WriteReal *)
  x := SYS.VAL (REAL, val);
  e := Reals.Expo (x); n := 8;
  (* there are 2 < n <= 8 digits to be written *)
  IF x < 0.0 THEN Write ("-"); x := -x ELSE Write (" ") END;
  e := (e - 64) * 77 DIV 256;
  IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  Reals.Convert (x, n, d);
  DEC (n); Write (d [n]); Write (".");
  REPEAT DEC (n); Write (d [n]) UNTIL n = 0;
  Write ("E");
  IF e < 0 THEN Write ("-"); e := -e ELSE Write ("+") END;
  Write (CHR (e DIV 10 + 30H)); Write (CHR (e MOD 10 + 30H))
END WriteReal;

(*------------------------------------*)
PROCEDURE WriteLReal ( val1, val2 : LONGINT );
BEGIN (* WriteLReal *)
  WriteReal (val1)
END WriteLReal;

(*------------------------------------*)
PROCEDURE WriteSet ( val : LONGINT );

  VAR set : SET; bit : SHORTINT; comma : BOOLEAN;

BEGIN (* WriteSet *)
  set := SYS.VAL (SET, val); comma := FALSE;
  Write ("{");
  FOR bit := 0 TO 31 DO
    IF bit IN set THEN
      IF comma THEN Write (",") END;
      WriteInt (bit); comma := TRUE
    END
  END;
  Write ("}");
END WriteSet;

(*------------------------------------*)
PROCEDURE WriteBoolean ( val : LONGINT );
BEGIN
  IF val = 0 THEN WriteStr ("TRUE")
  ELSE WriteStr ("FALSE")
  END
END WriteBoolean;

(*------------------------------------*)
PROCEDURE WriteHeader ( name : ARRAY OF CHAR );
(* $D- Don't copy arrays *)
BEGIN (* WriteHeader *)
  WriteStr ("DEFINITION "); WriteStr (name); WriteStr (";\n\n");
  WriteStr ("(* Created using OD 1.1 *)\n");
END WriteHeader;

(*------------------------------------*)
PROCEDURE WriteTrailer ( name : ARRAY OF CHAR );
(* $D- Don't copy arrays *)
BEGIN (* WriteTrailer *)
  WriteStr ("\nEND "); WriteStr (name); WriteStr (".\n")
END WriteTrailer;

(*--------------------------------------
**
** Performs an in-order traverse of the the symbol table,
** applying the 'action' procedure to each node.
*)

PROCEDURE Scan ( action : ActionProc );

  (*------------------------------------*)
  PROCEDURE DoScan ( obj : Object );
  BEGIN (* DoScan *)
    IF obj # NIL THEN
      DoScan (obj.left);
      action (obj);
      DoScan (obj.right);
    END;
  END DoScan;

BEGIN (* Scan *)
  DoScan (topScope.link)
END Scan;

(*------------------------------------*)
PROCEDURE* WriteConsts ( obj : Object );

  VAR
    ch : CHAR; i : INTEGER;

BEGIN (* WriteConsts *)
  IF obj.mode = Con THEN
    GetName (obj.name);
    Indent (); WriteStr (name); WriteStr (" = ");
    CASE obj.typ.form OF
      Bool :
        WriteBoolean (obj.a0)
      |
      Char :
        ch := CHR (obj.a0);
        IF (ch >= " ") & (ch <= "~") OR (ch >= 0A0X) & (ch <= 0FFX) THEN
          Write ('"'); Write (ch); Write ('"')
        ELSE
          WriteHex (ORD (ch)); Write ("X")
        END;
      |
      SInt, Int, LInt :
        WriteInt (obj.a0)
      |
      Real :
        WriteReal (obj.a0)
      |
      LReal :
        WriteLReal (obj.a0, obj.a1)
      |
      BSet, WSet, Set :
        WriteSet (obj.a0)
      |
      String :
        IF obj.a0 < 0 THEN (* This is a character literal *)
          ch := CHR (obj.a2);
          IF (ch >= " ") & (ch <= "~") OR (ch >= 0A0X) & (ch <= 0FFX) THEN
            Write ('"'); Write (ch); Write ('"')
          ELSE
            WriteHex (ORD (ch)); Write ("X")
          END
        ELSE
          Write ('"');
          FOR i := 1 TO obj.a1 - 1 DO Write ("?") END;
          Write ('"')
        END
      |
      NilTyp :
        WriteStr ("NIL")
      |
    ELSE
      WriteHex (obj.a0); Write ("H")
    END;
    WriteStr (";\n")
  END
END WriteConsts;

PROCEDURE^ WriteType ( obj : Object; typ : Struct );

(*------------------------------------*)
PROCEDURE WriteFields ( obj : Object );

BEGIN (* WriteFields *)
  WHILE obj # NIL DO
    IF (obj.mode = Fld) & (obj.name >= 0) THEN
      GetName (obj.name);
      Indent (); WriteStr (name);
      IF verbose THEN
        WriteStr (" <"); WriteInt (obj.a0); Write (">")
      END;
      IF obj.visible = RdOnly THEN WriteStr (" - : ")
      ELSE WriteStr (" : ")
      END;
      WriteType (NIL, obj.typ);
      WriteStr (";\n")
    END;
    obj := obj.left
  END;
END WriteFields;

(*------------------------------------*)
PROCEDURE WritePar ( par : Object );

BEGIN (* WritePar *)
  IF par # NIL THEN
    IF par.mode IN {Ind, IndR} THEN WriteStr ("VAR ") END;
    GetName (par.name); WriteStr (name);
    IF verbose & (par.mode IN {VarR, IndR, VarArg}) THEN
      WriteStr (" [");
      IF par.a0 >= 8 THEN Write ("A") ELSE Write ("D") END;
      WriteInt (par.a0 MOD 8);
      Write ("]")
    END;
    IF par.mode = VarArg THEN WriteStr (" ..: ")
    ELSE WriteStr (" : ")
    END;
    WriteType (NIL, par.typ)
  END
END WritePar;

(*------------------------------------*)
PROCEDURE WriteParList ( par : Object );

BEGIN (* WriteParList *)
  IF par # NIL THEN
    INC (indentLevel);
    Write ("\n"); Indent (); WriteStr ("( ");
    INC (indentLevel);
    LOOP
      WritePar (par);
      par := par.link;
      IF par = NIL THEN EXIT END;
      WriteStr (";\n"); Indent ()
    END;
    WriteStr (" )"); DEC (indentLevel, 2)
  END;
END WriteParList;

(*------------------------------------*)
PROCEDURE WriteLibCalls ( obj : Object );

  VAR
    par : Object;

BEGIN (* WriteLibCalls *)
  WHILE obj # NIL DO
    IF obj.mode = LibCall THEN
      Indent (); WriteStr ("LIBCALL ");
      GetName (obj.name); WriteStr (name);
      par := obj.link.link;
      IF par # NIL THEN WriteParList (par)
      ELSIF obj.typ # notyp THEN WriteStr (" ()")
      END;
      IF obj.typ # notyp THEN
        INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
        WriteType (NIL, obj.typ); DEC (indentLevel)
      END; (* IF *)
      WriteStr (";\n");
      IF verbose THEN
        INC (indentLevel); Indent(); DEC (indentLevel);
        WriteInt (obj.a0); WriteStr (";\n")
      END
    END;
    obj := obj.left
  END;
END WriteLibCalls;

(*------------------------------------*)
PROCEDURE WriteTProcs ( obj : Object );

  VAR
    par : Object;

BEGIN (* WriteTProcs *)
  WHILE obj # NIL DO
    IF (obj.mode = TProc) & (obj.name >= 0) THEN
      Indent (); WriteStr ("METHOD (");
      par := obj.link; WritePar (par); par := par.link;
      WriteStr (") ");
      GetName (obj.name); WriteStr (name);
      IF par # NIL THEN WriteParList (par)
      ELSIF obj.typ # notyp THEN WriteStr (" ()")
      END;
      IF obj.typ # notyp THEN
        INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
        WriteType (NIL, obj.typ); DEC (indentLevel)
      END; (* IF *)
      WriteStr (";\n")
    END;
    obj := obj.left
  END;
END WriteTProcs;

(*------------------------------------*)
PROCEDURE WriteType ( obj : Object; typ : Struct );

  VAR
    mno : INTEGER; par : Object;

BEGIN (* WriteType *)
  IF (typ.strobj # NIL) & (typ.strobj # obj) THEN
    mno := typ.mno - 1;
    IF mno > 0 THEN
      GetName (GlbMod [mno].name);
      WriteStr (name); Write (".")
    END;
    GetName (typ.strobj.name); WriteStr (name);
    IF verbose THEN
      WriteStr (" <"); WriteInt (typ.size); Write (">")
    END
  ELSE
    CASE typ.form OF
      Pointer :
        WriteStr ("POINTER TO ");
        IF verbose THEN
          Write ("<"); WriteInt (typ.size); WriteStr ("> ")
        END;
        WriteType (NIL, typ.BaseTyp)
      |
      CPointer :
        WriteStr ("CPOINTER TO ");
        IF verbose THEN
          Write ("<"); WriteInt (typ.size); WriteStr ("> ")
        END;
        WriteType (NIL, typ.BaseTyp)
      |
      BPointer :
        WriteStr ("BPOINTER TO ");
        IF verbose THEN
          Write ("<"); WriteInt (typ.size); WriteStr ("> ")
        END;
        WriteType (NIL, typ.BaseTyp)
      |
      ProcTyp :
        WriteStr ("PROCEDURE");
        IF verbose THEN
          WriteStr (" <"); WriteInt (typ.size); Write (">")
        END;
        par := typ.link; IF par # NIL THEN WriteParList (par)
        ELSIF obj.typ # notyp THEN WriteStr (" ()")
        END;
        IF typ.BaseTyp # notyp THEN
          INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
          WriteType (NIL, typ.BaseTyp); DEC (indentLevel)
        END
      |
      Array :
        WriteStr ("ARRAY "); WriteInt (typ.n); WriteStr (" OF ");
        IF verbose THEN
          Write ("<"); WriteInt (typ.size); WriteStr ("> ")
        END;
        WriteType (NIL, typ.BaseTyp)
      |
      DynArr :
        WriteStr ("ARRAY OF ");
        IF verbose THEN
          Write ("<"); WriteInt (typ.size); WriteStr ("> ")
        END;
        WriteType (NIL, typ.BaseTyp)
      |
      Record :
        WriteStr ("RECORD");
        IF typ.BaseTyp # NIL THEN
          WriteStr (" (");
          WriteType (NIL, typ.BaseTyp);
          Write (")")
        END;
        Write ("\n");
        INC (indentLevel);
        WriteFields (typ.link);
        WriteLibCalls (typ.link);
        WriteTProcs (typ.link);
        DEC (indentLevel);
        Indent(); WriteStr ("END");
        IF verbose THEN
          WriteStr (" <"); WriteInt (typ.size); Write (">")
        END
      |
    ELSE
      PutStr (" !! Unrecognised type\n");
      HALT (d.returnFail)
    END; (* CASE *)
  END;
END WriteType;

(*------------------------------------*)
PROCEDURE* WriteTypes ( obj : Object );

BEGIN
  IF obj.mode = Typ THEN
    GetName (obj.name);
    Write ("\n"); Indent (); WriteStr (name); WriteStr (" = ");
    WriteType (obj, obj.typ);
    WriteStr (";\n")
  END
END WriteTypes;

(*------------------------------------*)
PROCEDURE* WriteVars ( obj : Object );

BEGIN (* WriteVars *)
  IF obj.mode = Var THEN
    GetName (obj.name);
    Indent (); WriteStr (name);
    IF verbose THEN
      WriteStr (" <"); WriteInt (obj.a0); Write (">")
    END;
    IF obj.visible = RdOnly THEN WriteStr (" - : ")
    ELSE WriteStr (" : ")
    END;
    WriteType (NIL, obj.typ);
    WriteStr (";\n")
  END
END WriteVars;

(*------------------------------------*)
PROCEDURE* WriteProcs ( obj : Object );

  VAR
    par : Object;

BEGIN (* WriteProcs *)
  IF obj.mode IN {XProc, FProc} THEN
    WriteStr ("PROCEDURE "); GetName (obj.name); WriteStr (name);
    IF verbose & (obj.mode = FProc) THEN
      WriteStr (' ["'); WriteStr (obj.symbol^); WriteStr ('"]');
    END;
    par := obj.link;
    IF par # NIL THEN WriteParList (par)
    ELSIF obj.typ # notyp THEN WriteStr (" ()")
    END;
    IF obj.typ # notyp THEN
      INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
      WriteType (NIL, obj.typ); DEC (indentLevel)
    END; (* IF *)
    WriteStr (";\n")
  END
END WriteProcs;

(*------------------------------------*)
PROCEDURE Export * ( fileName, name : ARRAY OF CHAR );

  VAR
    defFile : f.File;

BEGIN (* Export *)
  indentLevel := 0;
  defFile := f.New (fileName);
  IF defFile # NIL THEN
    PutStr ("\x9B\x4B >> "); PutStr (fileName); PutStr ("\n");
    f.Set (SR, defFile, 0);

    PutStr ("\x9B\x4B    Writing Header...\r");
    WriteHeader (name);
    PutStr ("\x9B\x4B    Writing Constants...\r");
    WriteStr ("\nCONST\n\n"); INC (indentLevel);
    Scan (WriteConsts); DEC (indentLevel);
    PutStr ("\x9B\x4B    Writing Types...\r");
    WriteStr ("\nTYPE\n"); INC (indentLevel);
    Scan (WriteTypes); DEC (indentLevel);
    PutStr ("\x9B\x4B    Writing Vars...\r");
    WriteStr ("\nVAR\n\n"); INC (indentLevel);
    Scan (WriteVars); DEC (indentLevel);
    PutStr ("\x9B\x4B    Writing Procedures...\r");
    WriteStr ("\n(* PROCEDURES *)\n\n");
    Scan (WriteProcs);
    PutStr ("\x9B\x4B    Writing Trailer...\r");
    WriteTrailer (name);

    f.Register (defFile); f.Set (SR, NIL, 0)
  ELSE
    PutStr ("\x9B\x4B !! Could not open ");
    PutStr (fileName); PutStr ("\n");
  END;
  CloseScope
END Export;

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

(*------------------------------------*)
PROCEDURE InitStruct (VAR typ : Struct; f : INTEGER);

BEGIN (* InitStruct *)
  typ := AllocStruct (); typ.form := f; typ.size := 1
END InitStruct;

(*------------------------------------*)
(* $D- disable copying of open arrays *)
PROCEDURE EnterTyp (
  name : ARRAY OF CHAR; form, size : INTEGER; VAR res: Struct);

  VAR obj : Object; typ : Struct;

BEGIN (* EnterTyp *)
  Insert (name, obj, Typ); typ := AllocStruct ();
  obj.typ := typ; obj.visible := Exp;
  typ.form := form; typ.strobj := obj; typ.size := size;
  res := typ;
END EnterTyp;

BEGIN (* ODT *)
  nameSize := 0; topScope := NIL;
  InitStruct (undftyp, Undef); InitStruct (notyp, NoTyp);
  InitStruct (stringtyp, String); InitStruct (niltyp, NilTyp);
  OpenScope (0);

  (* initialisation of module SYSTEM *)

  EnterTyp ("SYSTEM.BYTESET", BSet, BSetSize, bsettyp);
  EnterTyp ("SYSTEM.WORDSET", WSet, WSetSize, wsettyp);
  EnterTyp ("SYSTEM.PTR", PtrTyp, PtrSize, ptrtyp);
  EnterTyp ("SYSTEM.BPTR", BPtrTyp, PtrSize, bptrtyp);
  EnterTyp ("SYSTEM.CPTR", CPtrTyp, PtrSize, cptrtyp);
  EnterTyp ("SYSTEM.BYTE", Byte, ByteSize, bytetyp);
  EnterTyp ("SYSTEM.WORD", Word, WordSize, wordtyp);
  EnterTyp ("SYSTEM.LONGWORD", Longword, LongSize, lwordtyp);
  EnterTyp ("SYSTEM.TYPETAG", TagTyp, PtrSize, tagtyp);

  syslink := topScope.link; universe := topScope; topScope.link := NIL;

  (* initialisation of predeclared types and procedures *)

  EnterTyp ("CHAR", Char, CharSize, chartyp);
  EnterTyp ("SET", Set, SetSize, settyp);
  EnterTyp ("REAL", Real, RealSize, realtyp);
  EnterTyp ("INTEGER", Int, IntSize, inttyp);
  EnterTyp ("LONGINT", LInt, LIntSize, linttyp);
  EnterTyp ("LONGREAL", LReal, LRealSize, lrltyp);
  EnterTyp ("SHORTINT", SInt, SIntSize, sinttyp);
  EnterTyp ("BOOLEAN", Bool, BoolSize, booltyp);

  nameOrg := nameX;
  backupTab := nameTab; (* Save hash table for names so we can restore it *)
END ODT.

(*************************************************************************

  $Log: ODT.mod $
  Revision 1.3  1994/08/08  16:35:10  fjc
  Release 1.4

  Revision 1.2  1994/07/22  13:54:09  fjc
  - Added code to handle FProc objects.

  Revision 1.1  1994/07/09  21:54:16  fjc
  Initial revision

*************************************************************************)