home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / useful / dev / obero / oberon-a / source / od / odt.mod < prev   
Encoding:
Text File  |  1994-08-08  |  39.4 KB  |  1,391 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: ODT.mod $
  4.   Description: Symbol table handler for OD.
  5.  
  6.                This module is adapted from Modules OCG and OCT, which are
  7.                part of the Oberon-A compiler 'OC'.
  8.  
  9.    Created by: fjc (Frank Copeland)
  10.     $Revision: 1.3 $
  11.       $Author: fjc $
  12.         $Date: 1994/08/08 16:35:10 $
  13.  
  14.   Copyright © 1994, Frank Copeland.
  15.   This file is part of Oberon-A.
  16.   See Oberon-A.doc for conditions of use and distribution.
  17.  
  18.   Log entries are at the end of the file.
  19.  
  20. *************************************************************************)
  21.  
  22. MODULE ODT;
  23.  
  24. (*
  25. ** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
  26. ** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  27. ** $V= OvflChk       $Z= ZeroVars
  28. *)
  29.  
  30. IMPORT
  31.   SYS := SYSTEM,
  32.   d   := Dos,
  33.   f   := Files,
  34.   Reals,
  35.   str := Strings;
  36.  
  37. (*
  38. ** Object and item modes. These are the same as those declared in module
  39. ** OCG and must be updated if that module is changed.
  40. *)
  41.  
  42. CONST
  43.  
  44.   Undef   =  0;
  45.   Var     =  1; (* local and global variables and value parameters *)
  46.   VarX    =  2; (* indexed array variables *)
  47.   VarR    =  3; (* value parameter passed in a register *)
  48.   VarArg  =  4; (* C-style vararg pushed on stack, for libcalls only *)
  49.   Ind     =  5; (* variable parameters *)
  50.   IndX    =  6; (* indexed dynamic array parameters *)
  51.   IndR    =  7; (* variable parameter passed in a register *)
  52.   RegI    =  8; (* register indirect mode with displacement *)
  53.   RegX    =  9; (* register indirect mode with displacement and index *)
  54.   Lab     = 10; (* absolute mode, the address of a label *)
  55.   LabI    = 11; (* immediate mode, the address of a label *)
  56.   Abs     = 12; (* absolute mode *)
  57.   Con     = 13; (* constants *)
  58.   Push    = 14; (* register indirect mode with predecrement *)
  59.   Pop     = 15; (* register indirect mode with postincrement *)
  60.   Coc     = 16; (* condition code *)
  61.   Reg     = 17; (* register direct mode *)
  62.   Fld     = 18; (* record fields *)
  63.   Typ     = 19; (* types *)
  64.   LProc   = 20; (* local (non-exportable) procedures *)
  65.   XProc   = 21; (* exportable procedures *)
  66.   SProc   = 22; (* standard procedures *)
  67.   LibCall = 23; (* Amiga library functions *)
  68.   TProc   = 24; (* Type-bound procedure *)
  69.   FProc   = 25; (* Foreign procedures (such as in amiga.lib) *)
  70.   Mod     = 26; (* Modules *)
  71.   Head    = 27; (* symbol scope header *)
  72.   RList   = 28; (* Register list for MOVEM *)
  73.  
  74.   (* Sizes in bytes of basic data types. *)
  75.  
  76.   ByteSize = 1; WordSize = 2; LongSize = 4;
  77.   BoolSize = 1; CharSize = 1;
  78.   SIntSize = 1; IntSize = 2; LIntSize = 4;
  79.   RealSize = 4; LRealSize = RealSize;
  80.   BSetSize = 1; WSetSize = 2; SetSize = 4;
  81.   PtrSize  = 4; ProcSize = 4;
  82.  
  83. (*
  84. ** The following declarations are adapted from Module OCT. They must be
  85. ** updated if that module is changed.
  86. *)
  87.  
  88. CONST
  89.  
  90.   maxImps = 32;
  91.  
  92.   (* structure forms *)
  93.   Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5;
  94.   LInt = 6; Real = 7; LReal = 8; BSet = 9; WSet = 10; Set = 11;
  95.   String = 12; NilTyp = 13; NoTyp = 14; PtrTyp = 15; CPtrTyp = 16;
  96.   BPtrTyp = 17; Word = 18; Longword = 19; TagTyp = 20;
  97.   Pointer = 21; CPointer = 22; BPointer = 23; ProcTyp = 24;
  98.   Array = 25; DynArr = 26; Record = 27;
  99.  
  100.   (* String lengths *)
  101.  
  102.   NameLen = 255;
  103.   PathLen = 256;
  104.  
  105.   (* Values for visible field of ObjDesc *)
  106.  
  107.   Exp = -1;
  108.   NotExp = 0;
  109.   RdOnly = 1;
  110.  
  111. TYPE
  112.  
  113.   Name = ARRAY NameLen + 1 OF CHAR;
  114.   Symbol * = POINTER TO ARRAY OF CHAR;
  115.  
  116.   Object = POINTER TO ObjDesc;
  117.   Struct = POINTER TO StrDesc;
  118.  
  119.   ObjDesc = RECORD
  120.     left, right, link : Object;
  121.     typ : Struct;
  122.     a0, a1 : LONGINT;
  123.     a2 : INTEGER;
  124.     mode : SHORTINT;
  125.     visible : SHORTINT;
  126.     name : LONGINT;
  127.     symbol : Symbol;
  128.   END; (* ObjDesc *)
  129.  
  130.   ActionProc = PROCEDURE (obj : Object);
  131.  
  132.   StrDesc = RECORD
  133.     form, n, mno : INTEGER;
  134.     size, adr : LONGINT;
  135.     BaseTyp : Struct;
  136.     link, strobj : Object;
  137.   END; (* StrDesc *)
  138.  
  139. VAR
  140.   topScope : Object;
  141.  
  142.   undftyp, bytetyp, booltyp, chartyp, sinttyp, inttyp,
  143.   linttyp, realtyp, lrltyp, settyp, stringtyp, niltyp, notyp,
  144.   ptrtyp, cptrtyp, bptrtyp, bsettyp, wsettyp, wordtyp,
  145.   lwordtyp, tagtyp
  146.     : Struct;
  147.  
  148.   nofGmod : INTEGER; (* nof imports *)
  149.   GlbMod : ARRAY maxImps OF Object;
  150.  
  151. CONST
  152.  
  153.   SFtag = 53594D07H; (* "SYM" + version # *)
  154.   firstStr = 32; maxStr = 512;
  155.   maxMod = 24; maxParLev = 6;
  156.   NotYetExp = 0;
  157.  
  158.   (* terminal symbols for symbol file elements *)
  159.   eUndef = 0; eCon = 1; eTypE = 2; eTyp = 3; eVar = 4; eXProc = 5;
  160.   eLibCall = 6; ePointer = 7; eProcTyp = 8; eArray = 9; eDynArr = 10;
  161.   eRecord = 11; eParList = 12; eValPar = 13; eVarPar = 14; eValRegPar = 15;
  162.   eVarRegPar = 16; eFldList = 17; eFld = 18; eHPtr = 19; eHProc = 20;
  163.   eFixup = 21; eMod = 22; eBPointer = 23; eCPointer = 24; eMod0 = 25;
  164.   eTProcE = 26; eTProc = 27; eVarArg = 28; eFProc = 29;
  165.  
  166.   (* name buffer size *)
  167.  
  168.   BufSize = 16384;
  169.   MaxBuffers = 16;
  170.   HashTableSize = 251;
  171.  
  172. TYPE
  173.  
  174.   NameBufPtr = POINTER TO ARRAY BufSize OF CHAR;
  175.  
  176. VAR
  177.   universe, syslink : Object;
  178.   SR : f.Rider;
  179.   nameBuf : ARRAY MaxBuffers OF NameBufPtr;
  180.   nameX, nameOrg, nameSize : LONGINT;
  181.   nameTab, backupTab : ARRAY HashTableSize OF LONGINT;
  182.   ObjectList : Object;
  183.   StructList : Struct;
  184.  
  185.   (* These are assumed to have all fields zeroed by the loader. *)
  186.   emptyObj  : ObjDesc;
  187.   emptyStr  : StrDesc;
  188.  
  189.   indentLevel : INTEGER;
  190.   name : Name;
  191.   verbose * : BOOLEAN;
  192.  
  193. (*--- CONSOLE IO ---------------------------------*)
  194.  
  195. (* -------------------------------------
  196. **
  197. ** Writes a string to the standard output.
  198. *)
  199.  
  200. PROCEDURE PutStr ( str : ARRAY OF CHAR );
  201. (* $D- Don't copy open arrays *)
  202. BEGIN (* PutStr *)
  203.   SYS.SETREG (0, d.base.PutStr (str))
  204. END PutStr;
  205.  
  206. (*--- MEMORY MANAGEMENT ---------------------------------*)
  207.  
  208. (*------------------------------------*)
  209. PROCEDURE AllocObj () : Object;
  210.  
  211.   VAR newObj : Object;
  212.  
  213. BEGIN (* AllocObj *)
  214.   IF ObjectList = NIL THEN
  215.     NEW (newObj)
  216.   ELSE
  217.     newObj := ObjectList; ObjectList := ObjectList.link
  218.   END;
  219.   newObj^ := emptyObj;
  220.   RETURN newObj
  221. END AllocObj;
  222.  
  223. (*------------------------------------*)
  224. PROCEDURE FreeObj (obj : Object);
  225.  
  226. BEGIN (* FreeObj *)
  227.   IF obj # NIL THEN
  228.     FreeObj (obj.left); FreeObj (obj.right);
  229.     obj^ := emptyObj;
  230.     obj.link := ObjectList; ObjectList := obj
  231.   END
  232. END FreeObj;
  233.  
  234. (*------------------------------------*)
  235. PROCEDURE AllocStruct () : Struct;
  236.  
  237.   VAR newStr : Struct;
  238.  
  239. BEGIN (* AllocStruct *)
  240.   IF StructList = NIL THEN
  241.     NEW (newStr)
  242.   ELSE
  243.     newStr := StructList; StructList := StructList.BaseTyp;
  244.     newStr.BaseTyp := NIL
  245.   END;
  246.   RETURN newStr
  247. END AllocStruct;
  248.  
  249. (*------------------------------------*)
  250. PROCEDURE FreeStruct (str : Struct);
  251.  
  252. BEGIN (* FreeStruct *)
  253.   IF str # NIL THEN
  254.     FreeObj (str.link); str^ := emptyStr;
  255.     str.BaseTyp := StructList; StructList := str
  256.   END
  257. END FreeStruct;
  258.  
  259. (*--- NAME TABLE HANDLER ---------------------------------*)
  260.  
  261. (*------------------------------------*)
  262. PROCEDURE CheckBuf (size : LONGINT);
  263.  
  264.   VAR newBuf : NameBufPtr; newX : LONGINT;
  265.  
  266. BEGIN (* CheckBuf *)
  267.   newX := nameX + size + 4;
  268.   IF newX >= nameSize THEN
  269.     IF newX >= BufSize * MaxBuffers THEN
  270.       PutStr (" !! Name buffer overflow\n"); nameX := 0
  271.     ELSE
  272.       IF ((newX-1) MOD BufSize) < (size+4) THEN nameX := nameSize END;
  273.       NEW (newBuf);
  274.       INC (nameSize, BufSize);
  275.       nameBuf [(nameSize - 1) DIV BufSize] := newBuf
  276.     END
  277.   END
  278. END CheckBuf;
  279.  
  280. (*------------------------------------*)
  281. PROCEDURE InsertName (n : ARRAY OF CHAR) : LONGINT;
  282.  
  283.   VAR i, j, k, len, bufX : INTEGER; x, x1 : LONGINT; ch : CHAR;
  284.       buf : NameBufPtr;
  285.  
  286. (* $D- disable copying of open arrays *)
  287. BEGIN (* InsertName *)
  288.   k := 0; len := 0; ch := n [0];
  289.   WHILE ch # 0X DO
  290.     (*$V- ignore overflows*)
  291.     INC (k, ORD (ch));
  292.     (*$V=*)
  293.     INC (len); ch := n [len]
  294.   END;
  295.   k := (k + len) MOD HashTableSize;
  296.   x := nameTab [k];
  297.   LOOP
  298.     IF x = 0 THEN
  299.       CheckBuf (len);
  300.       buf := nameBuf [nameX DIV BufSize];
  301.       bufX := SHORT (nameX MOD BufSize);
  302.       buf [bufX] := CHR (nameTab [k] DIV 10000H); INC (bufX);
  303.       buf [bufX] := CHR (nameTab [k] DIV 100H);   INC (bufX);
  304.       buf [bufX] := CHR (nameTab [k]);            INC (bufX);
  305.       i := 0;
  306.       WHILE i <= len DO buf [bufX] := n [i]; INC (bufX); INC (i) END;
  307.       x := nameX + 3; nameTab [k] := x; nameX := nameX + len + 4;
  308.       RETURN x
  309.     ELSE
  310.       buf := nameBuf [x DIV BufSize];
  311.       bufX := SHORT (x MOD BufSize);
  312.       x1 :=
  313.         (LONG (ORD (buf [bufX - 3])) * 10000H)
  314.         + (LONG (ORD (buf [bufX - 2])) * 100H)
  315.         + LONG (ORD (buf [bufX - 1]));
  316.       i := bufX; j := 0;
  317.       LOOP
  318.         IF buf [i] # n [j] THEN
  319.           x := x1; EXIT
  320.         ELSIF n [j] = 0X THEN
  321.           RETURN x
  322.         ELSE
  323.           INC (i); INC (j)
  324.         END
  325.       END
  326.     END; (* ELSE *)
  327.   END; (* LOOP *)
  328. END InsertName;
  329.  
  330. (*------------------------------------*)
  331. PROCEDURE NameLength (name : LONGINT) : INTEGER;
  332.  
  333.   VAR buf : NameBufPtr; len, bufX : INTEGER;
  334.  
  335. BEGIN (* NameLength *)
  336.   buf := nameBuf [name DIV BufSize];
  337.   bufX := SHORT (name MOD BufSize);
  338.   len := 0;
  339.   WHILE buf [bufX] # 0X DO INC (len); INC (bufX) END;
  340.   RETURN len
  341. END NameLength;
  342.  
  343. (*------------------------------------*)
  344. PROCEDURE GetName (adr : LONGINT);
  345.  
  346.   VAR buf : NameBufPtr; i, bufX : INTEGER; ch :  CHAR;
  347.  
  348. BEGIN (* GetName *)
  349.   buf := nameBuf [adr DIV BufSize];
  350.   bufX := SHORT (adr MOD BufSize);
  351.   i := 0;
  352.   REPEAT
  353.     ch := buf [bufX]; name [i] := ch;
  354.     INC (i); INC (bufX)
  355.   UNTIL ch = 0X;
  356. END GetName;
  357.  
  358. (*--- TABLE INSERTION ---------------------------------*)
  359.  
  360. (*------------------------------------*)
  361. PROCEDURE InsertObj
  362.   ( VAR name : ARRAY OF CHAR; root : Object; mode : SHORTINT;
  363.     VAR res : Object ) : BOOLEAN;
  364.  
  365.   VAR
  366.     obj, prev : Object; result : BOOLEAN;
  367.     buf : NameBufPtr; n1, n2 : LONGINT; bufX, i : INTEGER; ch1, ch2 : CHAR;
  368.  
  369. BEGIN (* InsertObj *)
  370.   prev := root; obj := root.link; n1 := InsertName (name);
  371.   WHILE (obj # NIL) & (obj.name # n1) DO
  372.     prev := obj; n2 := obj.name; i := 0;
  373.     buf := nameBuf [n2 DIV BufSize]; bufX := SHORT (n2 MOD BufSize);
  374.     REPEAT
  375.       ch1 := name [i]; INC (i);
  376.       ch2 := buf [bufX]; INC (bufX)
  377.     UNTIL ch1 # ch2;
  378.     IF ch1 < ch2 THEN obj := obj.left
  379.     ELSE obj := obj.right
  380.     END
  381.   END;
  382.   IF obj = NIL THEN
  383.     obj := AllocObj (); obj.name := n1; obj.mode := mode;
  384.     IF prev = root THEN
  385.       root.link := obj
  386.     ELSE
  387.       IF ch1 < ch2 THEN prev.left := obj
  388.       ELSE prev.right := obj
  389.       END
  390.     END;
  391.     result := TRUE
  392.   ELSE
  393.     result := FALSE
  394.   END;
  395.   res := obj;
  396.   RETURN result
  397. END InsertObj;
  398.  
  399. (*------------------------------------*)
  400. PROCEDURE Insert
  401.   ( VAR name : ARRAY OF CHAR;
  402.     VAR res : Object;
  403.     mode : SHORTINT );
  404.  
  405. BEGIN (* Insert *)
  406.   IF ~InsertObj (name, topScope, mode, res) THEN
  407.     IF res.mode # Undef THEN PutStr (" !! name used twice\n") END;
  408.     res.mode := mode
  409.   END
  410. END Insert;
  411.  
  412. (*------------------------------------*)
  413. PROCEDURE OpenScope (level : INTEGER);
  414.  
  415.   VAR head : Object;
  416.  
  417. BEGIN (* OpenScope *)
  418.   head := AllocObj ();
  419.   head.mode := Head; head.a0 := level; head.left := topScope;
  420.   topScope := head;
  421. END OpenScope;
  422.  
  423. (*------------------------------------*)
  424. PROCEDURE CloseScope ();
  425.  
  426.   VAR oldHead : Object;
  427.  
  428. BEGIN (* CloseScope *)
  429.   oldHead := topScope; topScope := topScope.left;
  430.   oldHead^ := emptyObj; oldHead.link := ObjectList; ObjectList := oldHead;
  431. END CloseScope;
  432.  
  433. (*--- MODULE INITIALISATION ---------------------------------*)
  434.  
  435. (*------------------------------------*)
  436. PROCEDURE Init * ();
  437.  
  438. BEGIN (* Init *)
  439.   topScope := universe; nofGmod := 0
  440. END Init;
  441.  
  442. (*------------------------------------*)
  443. PROCEDURE Close * ();
  444.  
  445.   VAR i : INTEGER;
  446.  
  447. BEGIN (* Close *)
  448.   f.Set (SR, NIL, 0);
  449.   i := 0; WHILE i < maxImps DO GlbMod [i] := NIL; INC (i) END;
  450.   (* Restore original hash table for reserved names... *)
  451.   nameTab := backupTab; nameX := nameOrg;
  452.   (* ... Assuming that only one name buffer is required *)
  453.   nameSize := BufSize;
  454.   i := 1; WHILE i < MaxBuffers DO nameBuf [i] := NIL; INC (i) END
  455. END Close;
  456.  
  457. (*--- IMPORT ---------------------------------*)
  458.  
  459. (*------------------------------------*)
  460. PROCEDURE ReadInt(VAR i: LONGINT);
  461. (*
  462.   Reads integers written in a compacted form. Taken from J. Templ.
  463.   SPARC-Oberon. User's Guide and Implementation. Computersysteme ETH
  464.   Zürich, Technical Report No. 133, June 1990.
  465. *)
  466.  
  467.   VAR n: LONGINT; s: INTEGER; x: CHAR;
  468.  
  469. BEGIN
  470.   s := 0; n := 0; f.Read(SR, x);
  471.   WHILE ORD(x) >= 128 DO
  472.     INC(n, ASH(ORD(x) - 128, s)); INC(s, 7); f.Read(SR, x)
  473.   END;
  474.   i := n + ASH(ORD(x) MOD 64 - ORD(x) DIV 64 * 64, s)
  475. END ReadInt;
  476.  
  477. (*------------------------------------*)
  478. PROCEDURE ReadLInt (VAR k : LONGINT);
  479.  
  480. BEGIN (* ReadLInt *)
  481.   f.ReadBytes (SR, k, 4);
  482. END ReadLInt;
  483.  
  484. (*------------------------------------*)
  485. PROCEDURE ReadId (VAR id : ARRAY OF CHAR);
  486.  
  487.   VAR i : INTEGER; ch : CHAR;
  488.  
  489. BEGIN (* ReadId *)
  490.   i := 0;
  491.   REPEAT
  492.     f.Read (SR, ch); id [i] := ch; INC (i)
  493.   UNTIL ch = 0X;
  494. END ReadId;
  495.  
  496. (*------------------------------------*)
  497. PROCEDURE Import *
  498.   ( FileName : ARRAY OF CHAR;
  499.     VAR name : ARRAY OF CHAR )
  500.   : BOOLEAN;
  501.  
  502.   VAR
  503.     i, m, s, nofLmod, strno, parlev, fldlev : INTEGER;
  504.     k, l, modname : LONGINT;
  505.     obj : Object;
  506.     modobj : Object;
  507.     class : SHORTINT;
  508.     SymFile : f.File;
  509.     LocMod : ARRAY maxMod OF Object;
  510.     struct : ARRAY maxStr OF Struct;
  511.     lastpar, lastfld : ARRAY maxParLev OF Object;
  512.     result : BOOLEAN;
  513.  
  514.     link : Object;
  515.     typ : Struct;
  516.     a0, a1 : LONGINT;
  517.     a2 : INTEGER;
  518.     mode : SHORTINT;
  519.     visible : SHORTINT;
  520.     symbol : Symbol;
  521.     objName : ARRAY NameLen+1 OF CHAR;
  522.  
  523.   (*------------------------------------*)
  524.   PROCEDURE reversedList (p : Object) : Object;
  525.  
  526.     VAR q, r : Object;
  527.  
  528.   BEGIN (* reversedList *)
  529.     q := NIL;
  530.     WHILE p # NIL DO r := p.link; p.link := q; q := p; p := r END;
  531.     RETURN q
  532.   END reversedList;
  533.  
  534.   (*------------------------------------*)
  535.   PROCEDURE reversedList2 (p : Object) : Object;
  536.  
  537.     VAR q, r : Object;
  538.  
  539.   BEGIN (* reversedList2 *)
  540.     q := NIL;
  541.     WHILE p # NIL DO r := p.left; p.left := q; q := p; p := r END;
  542.     RETURN q
  543.   END reversedList2;
  544.  
  545. (* $D- Don't copy arrays *)
  546. BEGIN (* Import *)
  547.   result := FALSE;
  548.   nofLmod := 0; strno := firstStr; parlev := -1; fldlev := -1;
  549.   SymFile := f.Old (FileName);
  550.   IF SymFile # NIL THEN
  551.     PutStr ("\x9B\x4B << "); PutStr (FileName); PutStr ("\r");
  552.     f.Set (SR, SymFile, 0); ReadLInt (k);
  553.     IF k = SFtag THEN
  554.       struct [Undef] := undftyp; struct [Byte] := bytetyp;
  555.       struct [Bool] := booltyp; struct [Char] := chartyp;
  556.       struct [SInt] := sinttyp; struct [Int] := inttyp;
  557.       struct [LInt] := linttyp; struct [Real] := realtyp;
  558.       struct [LReal] := lrltyp; struct [Set] := settyp;
  559.       struct [String] := stringtyp; struct [NilTyp] := niltyp;
  560.       struct [NoTyp] := notyp; struct [BSet] := bsettyp;
  561.       struct [WSet] := wsettyp; struct [PtrTyp] := ptrtyp;
  562.       struct [CPtrTyp] := cptrtyp; struct [BPtrTyp] := bptrtyp;
  563.       struct [Word] := wordtyp; struct [Longword] := lwordtyp;
  564.       struct [TagTyp] := tagtyp;
  565.       LOOP (* read next item from symbol file *)
  566.         f.Read (SR, class); IF SR.eof THEN EXIT END;
  567.         link := NIL; typ := NIL; a0 := 0; a1 := 0; a2 := 0;
  568.         mode := Undef; visible := NotExp; symbol := NIL;
  569.         objName := "";
  570.         CASE class OF
  571.           eUndef : PutStr (" !! Corrupt symbol file\n")
  572.           |
  573.           eCon .. eXProc, eFProc : (* object *)
  574.             m := 0; ReadInt (l); s := SHORT (l); typ := struct [s];
  575.             CASE class OF
  576.               eCon :
  577.                 mode := Con;
  578.                 CASE typ.form OF
  579.                   Byte, Char, BSet, Bool, SInt, Int, WSet,
  580.                   Word, LInt, Real, LReal, Set, Longword :
  581.                     ReadInt (a0);
  582.                   |
  583.                   (*LReal : ReadInt (a0); ReadInt (a1);
  584.                   |*)
  585.                   String :
  586.                     ReadInt (a0); ReadInt (a1);
  587.                     IF a1 <= 2 THEN
  588.                       ReadInt (l); a2 := SHORT (l)
  589.                     END
  590.                   |
  591.                   NilTyp : (* NIL *)
  592.                   |
  593.                   CPtrTyp, BPtrTyp, CPointer, BPointer, ProcTyp :
  594.                     (* This is all VERY dodgy, but ... *)
  595.                     ReadInt (a0)
  596.                   |
  597.                 ELSE
  598.                   PutStr (" !! Unrecognised form in symbol file\n")
  599.                 END; (* CASE obj.typ.form *)
  600.               |
  601.               eTypE, eTyp :
  602.                 mode := Typ; ReadInt (l); m := SHORT (l);
  603.                 IF class = eTypE THEN visible := Exp
  604.                 ELSE visible := NotExp
  605.                 END
  606.               |
  607.               eVar :
  608.                 mode := Var; ReadInt (a0); f.Read (SR, visible)
  609.               |
  610.               eXProc :
  611.                 mode := XProc; link := reversedList (lastpar [parlev]);
  612.                 DEC (parlev);
  613.               |
  614.             eFProc :
  615.               mode := FProc;
  616.               link := reversedList (lastpar [parlev]); DEC (parlev);
  617.               ReadId (objName); NEW (symbol, str.Length (objName) + 1);
  618.               COPY (objName, symbol^)
  619.             |
  620.             ELSE
  621.               PutStr (" !! Unrecognised class in symbol file\n")
  622.             END; (* CASE class *)
  623.             ReadId (objName);
  624.             IF InsertObj (objName, LocMod [m], mode, obj) THEN
  625.               obj.link := link; obj.typ := typ; obj.a0 := a0;
  626.               obj.a1 := a1; obj.a2 := a2; obj.visible := visible;
  627.               obj.symbol := symbol;
  628.               IF mode = Typ THEN
  629.                 IF typ.strobj = NIL THEN typ.strobj := obj END
  630.               END;
  631.             ELSIF mode = Typ THEN
  632.               FreeStruct (typ); struct [s] := obj.typ
  633.             END
  634.           |
  635.           ePointer .. eRecord, eBPointer, eCPointer :
  636.             (* structure *)
  637.             typ := AllocStruct (); typ.strobj := NIL;
  638.             ReadInt (l); typ.BaseTyp := struct [l];
  639.             ReadInt (l); typ.mno := SHORT (LocMod [l].a0);
  640.             CASE class OF
  641.               ePointer, eBPointer, eCPointer :
  642.                 typ.size := PtrSize; typ.n := 0;
  643.                 IF class = ePointer THEN
  644.                   typ.form := Pointer; ReadInt (typ.adr);
  645.                   IF typ.BaseTyp.form = DynArr THEN
  646.                     typ.size := typ.BaseTyp.size;
  647.                   END
  648.                 ELSIF class = eCPointer THEN typ.form := CPointer
  649.                 ELSE typ.form := BPointer
  650.                 END;
  651.               |
  652.               eProcTyp :
  653.                 typ.form := ProcTyp; typ.size := ProcSize;
  654.                 typ.link := reversedList (lastpar [parlev]);
  655.                 DEC (parlev);
  656.               |
  657.               eArray :
  658.                 typ.form := Array; ReadInt (typ.size);
  659.                 ReadInt (typ.adr); ReadInt (l); typ.n := SHORT (l);
  660.               |
  661.               eDynArr :
  662.                 typ.form := DynArr; ReadInt (typ.size);
  663.                 ReadInt (typ.adr);
  664.               |
  665.               eRecord :
  666.                 typ.form := Record;
  667.                 ReadInt (typ.size); typ.n := 0;
  668.                 typ.link := reversedList2 (lastfld [fldlev]);
  669.                 DEC (fldlev);
  670.                 IF typ.BaseTyp = notyp THEN
  671.                   typ.BaseTyp := NIL; typ.n := 0;
  672.                 ELSE
  673.                   typ.n := typ.BaseTyp.n + 1;
  674.                 END;
  675.                 ReadInt (typ.adr); (* of descriptor *)
  676.               |
  677.             ELSE
  678.               PutStr (" !! Unrecognised class in symbol file\n")
  679.             END; (* CASE class *)
  680.             struct [strno] := typ; INC (strno);
  681.           |
  682.           eParList : (* parameter list start *)
  683.             IF parlev < maxParLev - 1 THEN
  684.               INC (parlev); lastpar [parlev] := NIL;
  685.             ELSE
  686.               PutStr (" !! Too many parameter lists\n")
  687.             END
  688.           |
  689.           eValPar, eVarPar, eValRegPar, eVarRegPar, eVarArg :
  690.           (* parameter *)
  691.             obj := AllocObj ();
  692.             IF class = eValPar THEN obj.mode := Var
  693.             ELSIF class = eVarPar THEN obj.mode := Ind
  694.             ELSIF class = eValRegPar THEN obj.mode := VarR
  695.             ELSIF class = eVarRegPar THEN obj.mode := IndR
  696.             ELSE obj.mode := VarArg
  697.             END;
  698.             ReadInt (l); obj.typ := struct [l];
  699.             ReadInt (obj.a0); ReadId (objName);
  700.             obj.name := InsertName (objName);
  701.             obj.link := lastpar [parlev]; lastpar [parlev] := obj
  702.           |
  703.           eFldList : (* start field list *)
  704.             IF fldlev < maxParLev - 1 THEN
  705.               INC (fldlev); lastfld [fldlev] := NIL;
  706.             ELSE
  707.               PutStr (" !! Too many field lists\n")
  708.             END
  709.           |
  710.           eFld :
  711.             obj := AllocObj ();  obj.mode := Fld; obj.link := NIL;
  712.             ReadInt (l); obj.typ := struct [l];
  713.             ReadInt (obj.a0); f.Read (SR, obj.visible);
  714.             ReadId (objName); obj.name := InsertName (objName);
  715.             obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
  716.           |
  717.           eLibCall : (* library call procedure *)
  718.             obj := AllocObj (); obj.mode := LibCall;
  719.             ReadInt (l); typ := struct [l];
  720.             ReadInt (l); obj.typ := struct [l];
  721.             ReadInt (obj.a0); ReadId (objName);
  722.             obj.name := InsertName (objName); obj.visible := Exp;
  723.             obj.link := reversedList (lastpar [parlev]); DEC (parlev);
  724.             obj.left := typ.link; typ.link := obj
  725.  
  726.           |
  727.           eTProcE : (* exported type-bound procedure *)
  728.             obj := AllocObj (); obj.mode := TProc;
  729.             ReadInt (l); typ := struct [l];
  730.             ReadInt (l); obj.typ := struct [l];
  731.             ReadInt (obj.a0); ReadId (objName);
  732.             obj.name := InsertName (objName);
  733.             obj.a1 := typ.n; obj.visible := Exp;
  734.             obj.link := reversedList (lastpar [parlev]); DEC (parlev);
  735.             obj.link.a2 := -1; obj.left := typ.link; typ.link := obj;
  736.           |
  737.           eTProc : (* hidden type-bound procedure *)
  738.             obj := AllocObj (); obj.mode := TProc; obj.typ := notyp;
  739.             ReadInt (l); typ := struct [l];
  740.             ReadInt (obj.a0); obj.name := -1; obj.visible := NotExp;
  741.             obj.link := NIL; obj.left := typ.link; typ.link := obj;
  742.           |
  743.           eHPtr : (* hidden pointer field *)
  744.             obj := AllocObj (); obj.mode := Fld;
  745.             ReadInt (obj.a0); obj.name := -1; obj.typ := notyp;
  746.             obj.visible := NotExp; obj.link := NIL;
  747.             obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
  748.           |
  749.           eHProc : (* hidden procedure field *)
  750.             ReadInt (l);
  751.           |
  752.           eFixup : (* fixup pointer typ *)
  753.             ReadInt (l); typ := struct [l];
  754.             ReadInt (l);
  755.             IF typ.BaseTyp = undftyp THEN
  756.               typ.BaseTyp := struct [l];
  757.               IF typ.BaseTyp.form = DynArr THEN
  758.                 typ.size := typ.BaseTyp.size;
  759.               END
  760.             END
  761.           |
  762.           eMod, eMod0 : (* module anchor *)
  763.             ReadLInt (k);
  764.             ReadId (objName); modname := InsertName (objName);
  765.             IF nofLmod = 0 THEN COPY (objName, name) END;
  766.             i := 0;
  767.             WHILE (i < nofGmod) & (modname # GlbMod [i].name) DO
  768.               INC (i);
  769.             END;
  770.             IF i < nofGmod THEN (* module already present *)
  771.               IF k # GlbMod [i].a1 THEN
  772.                 PutStr (" !! Bad key for imported module\n")
  773.               END;
  774.               modobj := GlbMod [i];
  775.             ELSE
  776.               NEW (modobj);
  777.               IF nofGmod < maxImps THEN
  778.                 GlbMod [nofGmod] := modobj; INC (nofGmod);
  779.               ELSE
  780.                 PutStr (" !! Too many global modules\n")
  781.               END;
  782.               modobj.mode := NotYetExp; modobj.name := modname;
  783.               modobj.a1 := k; modobj.a0 := nofGmod;
  784.               modobj.link := NIL; modobj.visible := NotExp;
  785.               IF class = eMod THEN modobj.a2 := 0 ELSE modobj.a2 := 1 END;
  786.             END;
  787.             IF nofLmod < maxMod THEN
  788.               LocMod [nofLmod] := modobj; INC (nofLmod)
  789.             ELSE
  790.               PutStr (" !! Too many local modules\n")
  791.             END
  792.           |
  793.         ELSE
  794.           PutStr (" !! Unrecognised class in symbol file\n");
  795.         END; (* CASE class *)
  796.       END; (* LOOP *)
  797.       OpenScope (1); topScope.link := LocMod [0].link;
  798.       result := TRUE
  799.     ELSE
  800.       PutStr (" !! Bad symbol file tag\n")
  801.     END;
  802.     f.Close (SymFile); f.Set (SR, NIL, 0)
  803.   ELSE
  804.     PutStr (" !! Could not open ");
  805.     PutStr (FileName); PutStr ("\n")
  806.   END;
  807.   RETURN result
  808. END Import;
  809.  
  810. (*--- EXPORT ---------------------------------*)
  811.  
  812. (*------------------------------------*)
  813. PROCEDURE Write ( ch : CHAR );
  814. BEGIN
  815.   f.Write (SR, ch)
  816. END Write;
  817.  
  818. (*------------------------------------*)
  819. PROCEDURE WriteStr ( str : ARRAY OF CHAR );
  820. BEGIN
  821.   f.WriteBytes (SR, str, SYS.STRLEN (str))
  822. END WriteStr;
  823.  
  824. (*------------------------------------*)
  825. PROCEDURE Indent ();
  826.  
  827.   VAR i : INTEGER;
  828.  
  829. BEGIN
  830.   FOR i := 1 TO indentLevel DO
  831.     Write (" "); Write (" ")
  832.   END
  833. END Indent;
  834.  
  835. (*------------------------------------*)
  836. PROCEDURE WriteInt ( val : LONGINT );
  837.  
  838.   VAR i : INTEGER; x0 : LONGINT; a : ARRAY 11 OF CHAR;
  839.  
  840. BEGIN (* WriteInt *)
  841.   i := 0;
  842.   IF val < 0 THEN
  843.     IF val = MIN (LONGINT) THEN WriteStr ("-2147483648"); RETURN
  844.     ELSE x0 := -val
  845.     END
  846.   ELSE x0 := val
  847.   END;
  848.   REPEAT
  849.     a [i] := CHR (x0 MOD 10 + 30H); x0 := x0 DIV 10; INC (i)
  850.   UNTIL x0 = 0;
  851.   IF val < 0 THEN Write ("-") END;
  852.   REPEAT DEC (i); Write (a [i]) UNTIL i = 0
  853. END WriteInt;
  854.  
  855. (*------------------------------------*)
  856. PROCEDURE WriteHex ( val : LONGINT );
  857.  
  858.   VAR i : INTEGER; y : LONGINT; a : ARRAY 10 OF CHAR;
  859.  
  860. BEGIN (* WriteHex *)
  861.   i := 0; Write ("0");
  862.   REPEAT
  863.     y := val MOD 10H;
  864.     IF y < 10 THEN a [i] := CHR (y + 30H) ELSE a [i] := CHR (y + 37H) END;
  865.     val := val DIV 10H; INC (i)
  866.   UNTIL (val = 0) OR (i = 8);
  867.   REPEAT DEC (i); Write (a [i]) UNTIL i = 0
  868. END WriteHex;
  869.  
  870. (*------------------------------------*)
  871. PROCEDURE WriteReal ( val : LONGINT );
  872.  
  873.   VAR e, n : INTEGER; x, x0 : REAL; d : ARRAY 9 OF CHAR;
  874.  
  875. BEGIN (* WriteReal *)
  876.   x := SYS.VAL (REAL, val);
  877.   e := Reals.Expo (x); n := 8;
  878.   (* there are 2 < n <= 8 digits to be written *)
  879.   IF x < 0.0 THEN Write ("-"); x := -x ELSE Write (" ") END;
  880.   e := (e - 64) * 77 DIV 256;
  881.   IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  882.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  883.   x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  884.   IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  885.   Reals.Convert (x, n, d);
  886.   DEC (n); Write (d [n]); Write (".");
  887.   REPEAT DEC (n); Write (d [n]) UNTIL n = 0;
  888.   Write ("E");
  889.   IF e < 0 THEN Write ("-"); e := -e ELSE Write ("+") END;
  890.   Write (CHR (e DIV 10 + 30H)); Write (CHR (e MOD 10 + 30H))
  891. END WriteReal;
  892.  
  893. (*------------------------------------*)
  894. PROCEDURE WriteLReal ( val1, val2 : LONGINT );
  895. BEGIN (* WriteLReal *)
  896.   WriteReal (val1)
  897. END WriteLReal;
  898.  
  899. (*------------------------------------*)
  900. PROCEDURE WriteSet ( val : LONGINT );
  901.  
  902.   VAR set : SET; bit : SHORTINT; comma : BOOLEAN;
  903.  
  904. BEGIN (* WriteSet *)
  905.   set := SYS.VAL (SET, val); comma := FALSE;
  906.   Write ("{");
  907.   FOR bit := 0 TO 31 DO
  908.     IF bit IN set THEN
  909.       IF comma THEN Write (",") END;
  910.       WriteInt (bit); comma := TRUE
  911.     END
  912.   END;
  913.   Write ("}");
  914. END WriteSet;
  915.  
  916. (*------------------------------------*)
  917. PROCEDURE WriteBoolean ( val : LONGINT );
  918. BEGIN
  919.   IF val = 0 THEN WriteStr ("TRUE")
  920.   ELSE WriteStr ("FALSE")
  921.   END
  922. END WriteBoolean;
  923.  
  924. (*------------------------------------*)
  925. PROCEDURE WriteHeader ( name : ARRAY OF CHAR );
  926. (* $D- Don't copy arrays *)
  927. BEGIN (* WriteHeader *)
  928.   WriteStr ("DEFINITION "); WriteStr (name); WriteStr (";\n\n");
  929.   WriteStr ("(* Created using OD 1.1 *)\n");
  930. END WriteHeader;
  931.  
  932. (*------------------------------------*)
  933. PROCEDURE WriteTrailer ( name : ARRAY OF CHAR );
  934. (* $D- Don't copy arrays *)
  935. BEGIN (* WriteTrailer *)
  936.   WriteStr ("\nEND "); WriteStr (name); WriteStr (".\n")
  937. END WriteTrailer;
  938.  
  939. (*--------------------------------------
  940. **
  941. ** Performs an in-order traverse of the the symbol table,
  942. ** applying the 'action' procedure to each node.
  943. *)
  944.  
  945. PROCEDURE Scan ( action : ActionProc );
  946.  
  947.   (*------------------------------------*)
  948.   PROCEDURE DoScan ( obj : Object );
  949.   BEGIN (* DoScan *)
  950.     IF obj # NIL THEN
  951.       DoScan (obj.left);
  952.       action (obj);
  953.       DoScan (obj.right);
  954.     END;
  955.   END DoScan;
  956.  
  957. BEGIN (* Scan *)
  958.   DoScan (topScope.link)
  959. END Scan;
  960.  
  961. (*------------------------------------*)
  962. PROCEDURE* WriteConsts ( obj : Object );
  963.  
  964.   VAR
  965.     ch : CHAR; i : INTEGER;
  966.  
  967. BEGIN (* WriteConsts *)
  968.   IF obj.mode = Con THEN
  969.     GetName (obj.name);
  970.     Indent (); WriteStr (name); WriteStr (" = ");
  971.     CASE obj.typ.form OF
  972.       Bool :
  973.         WriteBoolean (obj.a0)
  974.       |
  975.       Char :
  976.         ch := CHR (obj.a0);
  977.         IF (ch >= " ") & (ch <= "~") OR (ch >= 0A0X) & (ch <= 0FFX) THEN
  978.           Write ('"'); Write (ch); Write ('"')
  979.         ELSE
  980.           WriteHex (ORD (ch)); Write ("X")
  981.         END;
  982.       |
  983.       SInt, Int, LInt :
  984.         WriteInt (obj.a0)
  985.       |
  986.       Real :
  987.         WriteReal (obj.a0)
  988.       |
  989.       LReal :
  990.         WriteLReal (obj.a0, obj.a1)
  991.       |
  992.       BSet, WSet, Set :
  993.         WriteSet (obj.a0)
  994.       |
  995.       String :
  996.         IF obj.a0 < 0 THEN (* This is a character literal *)
  997.           ch := CHR (obj.a2);
  998.           IF (ch >= " ") & (ch <= "~") OR (ch >= 0A0X) & (ch <= 0FFX) THEN
  999.             Write ('"'); Write (ch); Write ('"')
  1000.           ELSE
  1001.             WriteHex (ORD (ch)); Write ("X")
  1002.           END
  1003.         ELSE
  1004.           Write ('"');
  1005.           FOR i := 1 TO obj.a1 - 1 DO Write ("?") END;
  1006.           Write ('"')
  1007.         END
  1008.       |
  1009.       NilTyp :
  1010.         WriteStr ("NIL")
  1011.       |
  1012.     ELSE
  1013.       WriteHex (obj.a0); Write ("H")
  1014.     END;
  1015.     WriteStr (";\n")
  1016.   END
  1017. END WriteConsts;
  1018.  
  1019. PROCEDURE^ WriteType ( obj : Object; typ : Struct );
  1020.  
  1021. (*------------------------------------*)
  1022. PROCEDURE WriteFields ( obj : Object );
  1023.  
  1024. BEGIN (* WriteFields *)
  1025.   WHILE obj # NIL DO
  1026.     IF (obj.mode = Fld) & (obj.name >= 0) THEN
  1027.       GetName (obj.name);
  1028.       Indent (); WriteStr (name);
  1029.       IF verbose THEN
  1030.         WriteStr (" <"); WriteInt (obj.a0); Write (">")
  1031.       END;
  1032.       IF obj.visible = RdOnly THEN WriteStr (" - : ")
  1033.       ELSE WriteStr (" : ")
  1034.       END;
  1035.       WriteType (NIL, obj.typ);
  1036.       WriteStr (";\n")
  1037.     END;
  1038.     obj := obj.left
  1039.   END;
  1040. END WriteFields;
  1041.  
  1042. (*------------------------------------*)
  1043. PROCEDURE WritePar ( par : Object );
  1044.  
  1045. BEGIN (* WritePar *)
  1046.   IF par # NIL THEN
  1047.     IF par.mode IN {Ind, IndR} THEN WriteStr ("VAR ") END;
  1048.     GetName (par.name); WriteStr (name);
  1049.     IF verbose & (par.mode IN {VarR, IndR, VarArg}) THEN
  1050.       WriteStr (" [");
  1051.       IF par.a0 >= 8 THEN Write ("A") ELSE Write ("D") END;
  1052.       WriteInt (par.a0 MOD 8);
  1053.       Write ("]")
  1054.     END;
  1055.     IF par.mode = VarArg THEN WriteStr (" ..: ")
  1056.     ELSE WriteStr (" : ")
  1057.     END;
  1058.     WriteType (NIL, par.typ)
  1059.   END
  1060. END WritePar;
  1061.  
  1062. (*------------------------------------*)
  1063. PROCEDURE WriteParList ( par : Object );
  1064.  
  1065. BEGIN (* WriteParList *)
  1066.   IF par # NIL THEN
  1067.     INC (indentLevel);
  1068.     Write ("\n"); Indent (); WriteStr ("( ");
  1069.     INC (indentLevel);
  1070.     LOOP
  1071.       WritePar (par);
  1072.       par := par.link;
  1073.       IF par = NIL THEN EXIT END;
  1074.       WriteStr (";\n"); Indent ()
  1075.     END;
  1076.     WriteStr (" )"); DEC (indentLevel, 2)
  1077.   END;
  1078. END WriteParList;
  1079.  
  1080. (*------------------------------------*)
  1081. PROCEDURE WriteLibCalls ( obj : Object );
  1082.  
  1083.   VAR
  1084.     par : Object;
  1085.  
  1086. BEGIN (* WriteLibCalls *)
  1087.   WHILE obj # NIL DO
  1088.     IF obj.mode = LibCall THEN
  1089.       Indent (); WriteStr ("LIBCALL ");
  1090.       GetName (obj.name); WriteStr (name);
  1091.       par := obj.link.link;
  1092.       IF par # NIL THEN WriteParList (par)
  1093.       ELSIF obj.typ # notyp THEN WriteStr (" ()")
  1094.       END;
  1095.       IF obj.typ # notyp THEN
  1096.         INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
  1097.         WriteType (NIL, obj.typ); DEC (indentLevel)
  1098.       END; (* IF *)
  1099.       WriteStr (";\n");
  1100.       IF verbose THEN
  1101.         INC (indentLevel); Indent(); DEC (indentLevel);
  1102.         WriteInt (obj.a0); WriteStr (";\n")
  1103.       END
  1104.     END;
  1105.     obj := obj.left
  1106.   END;
  1107. END WriteLibCalls;
  1108.  
  1109. (*------------------------------------*)
  1110. PROCEDURE WriteTProcs ( obj : Object );
  1111.  
  1112.   VAR
  1113.     par : Object;
  1114.  
  1115. BEGIN (* WriteTProcs *)
  1116.   WHILE obj # NIL DO
  1117.     IF (obj.mode = TProc) & (obj.name >= 0) THEN
  1118.       Indent (); WriteStr ("METHOD (");
  1119.       par := obj.link; WritePar (par); par := par.link;
  1120.       WriteStr (") ");
  1121.       GetName (obj.name); WriteStr (name);
  1122.       IF par # NIL THEN WriteParList (par)
  1123.       ELSIF obj.typ # notyp THEN WriteStr (" ()")
  1124.       END;
  1125.       IF obj.typ # notyp THEN
  1126.         INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
  1127.         WriteType (NIL, obj.typ); DEC (indentLevel)
  1128.       END; (* IF *)
  1129.       WriteStr (";\n")
  1130.     END;
  1131.     obj := obj.left
  1132.   END;
  1133. END WriteTProcs;
  1134.  
  1135. (*------------------------------------*)
  1136. PROCEDURE WriteType ( obj : Object; typ : Struct );
  1137.  
  1138.   VAR
  1139.     mno : INTEGER; par : Object;
  1140.  
  1141. BEGIN (* WriteType *)
  1142.   IF (typ.strobj # NIL) & (typ.strobj # obj) THEN
  1143.     mno := typ.mno - 1;
  1144.     IF mno > 0 THEN
  1145.       GetName (GlbMod [mno].name);
  1146.       WriteStr (name); Write (".")
  1147.     END;
  1148.     GetName (typ.strobj.name); WriteStr (name);
  1149.     IF verbose THEN
  1150.       WriteStr (" <"); WriteInt (typ.size); Write (">")
  1151.     END
  1152.   ELSE
  1153.     CASE typ.form OF
  1154.       Pointer :
  1155.         WriteStr ("POINTER TO ");
  1156.         IF verbose THEN
  1157.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1158.         END;
  1159.         WriteType (NIL, typ.BaseTyp)
  1160.       |
  1161.       CPointer :
  1162.         WriteStr ("CPOINTER TO ");
  1163.         IF verbose THEN
  1164.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1165.         END;
  1166.         WriteType (NIL, typ.BaseTyp)
  1167.       |
  1168.       BPointer :
  1169.         WriteStr ("BPOINTER TO ");
  1170.         IF verbose THEN
  1171.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1172.         END;
  1173.         WriteType (NIL, typ.BaseTyp)
  1174.       |
  1175.       ProcTyp :
  1176.         WriteStr ("PROCEDURE");
  1177.         IF verbose THEN
  1178.           WriteStr (" <"); WriteInt (typ.size); Write (">")
  1179.         END;
  1180.         par := typ.link; IF par # NIL THEN WriteParList (par)
  1181.         ELSIF obj.typ # notyp THEN WriteStr (" ()")
  1182.         END;
  1183.         IF typ.BaseTyp # notyp THEN
  1184.           INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
  1185.           WriteType (NIL, typ.BaseTyp); DEC (indentLevel)
  1186.         END
  1187.       |
  1188.       Array :
  1189.         WriteStr ("ARRAY "); WriteInt (typ.n); WriteStr (" OF ");
  1190.         IF verbose THEN
  1191.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1192.         END;
  1193.         WriteType (NIL, typ.BaseTyp)
  1194.       |
  1195.       DynArr :
  1196.         WriteStr ("ARRAY OF ");
  1197.         IF verbose THEN
  1198.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1199.         END;
  1200.         WriteType (NIL, typ.BaseTyp)
  1201.       |
  1202.       Record :
  1203.         WriteStr ("RECORD");
  1204.         IF typ.BaseTyp # NIL THEN
  1205.           WriteStr (" (");
  1206.           WriteType (NIL, typ.BaseTyp);
  1207.           Write (")")
  1208.         END;
  1209.         Write ("\n");
  1210.         INC (indentLevel);
  1211.         WriteFields (typ.link);
  1212.         WriteLibCalls (typ.link);
  1213.         WriteTProcs (typ.link);
  1214.         DEC (indentLevel);
  1215.         Indent(); WriteStr ("END");
  1216.         IF verbose THEN
  1217.           WriteStr (" <"); WriteInt (typ.size); Write (">")
  1218.         END
  1219.       |
  1220.     ELSE
  1221.       PutStr (" !! Unrecognised type\n");
  1222.       HALT (d.returnFail)
  1223.     END; (* CASE *)
  1224.   END;
  1225. END WriteType;
  1226.  
  1227. (*------------------------------------*)
  1228. PROCEDURE* WriteTypes ( obj : Object );
  1229.  
  1230. BEGIN
  1231.   IF obj.mode = Typ THEN
  1232.     GetName (obj.name);
  1233.     Write ("\n"); Indent (); WriteStr (name); WriteStr (" = ");
  1234.     WriteType (obj, obj.typ);
  1235.     WriteStr (";\n")
  1236.   END
  1237. END WriteTypes;
  1238.  
  1239. (*------------------------------------*)
  1240. PROCEDURE* WriteVars ( obj : Object );
  1241.  
  1242. BEGIN (* WriteVars *)
  1243.   IF obj.mode = Var THEN
  1244.     GetName (obj.name);
  1245.     Indent (); WriteStr (name);
  1246.     IF verbose THEN
  1247.       WriteStr (" <"); WriteInt (obj.a0); Write (">")
  1248.     END;
  1249.     IF obj.visible = RdOnly THEN WriteStr (" - : ")
  1250.     ELSE WriteStr (" : ")
  1251.     END;
  1252.     WriteType (NIL, obj.typ);
  1253.     WriteStr (";\n")
  1254.   END
  1255. END WriteVars;
  1256.  
  1257. (*------------------------------------*)
  1258. PROCEDURE* WriteProcs ( obj : Object );
  1259.  
  1260.   VAR
  1261.     par : Object;
  1262.  
  1263. BEGIN (* WriteProcs *)
  1264.   IF obj.mode IN {XProc, FProc} THEN
  1265.     WriteStr ("PROCEDURE "); GetName (obj.name); WriteStr (name);
  1266.     IF verbose & (obj.mode = FProc) THEN
  1267.       WriteStr (' ["'); WriteStr (obj.symbol^); WriteStr ('"]');
  1268.     END;
  1269.     par := obj.link;
  1270.     IF par # NIL THEN WriteParList (par)
  1271.     ELSIF obj.typ # notyp THEN WriteStr (" ()")
  1272.     END;
  1273.     IF obj.typ # notyp THEN
  1274.       INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
  1275.       WriteType (NIL, obj.typ); DEC (indentLevel)
  1276.     END; (* IF *)
  1277.     WriteStr (";\n")
  1278.   END
  1279. END WriteProcs;
  1280.  
  1281. (*------------------------------------*)
  1282. PROCEDURE Export * ( fileName, name : ARRAY OF CHAR );
  1283.  
  1284.   VAR
  1285.     defFile : f.File;
  1286.  
  1287. BEGIN (* Export *)
  1288.   indentLevel := 0;
  1289.   defFile := f.New (fileName);
  1290.   IF defFile # NIL THEN
  1291.     PutStr ("\x9B\x4B >> "); PutStr (fileName); PutStr ("\n");
  1292.     f.Set (SR, defFile, 0);
  1293.  
  1294.     PutStr ("\x9B\x4B    Writing Header...\r");
  1295.     WriteHeader (name);
  1296.     PutStr ("\x9B\x4B    Writing Constants...\r");
  1297.     WriteStr ("\nCONST\n\n"); INC (indentLevel);
  1298.     Scan (WriteConsts); DEC (indentLevel);
  1299.     PutStr ("\x9B\x4B    Writing Types...\r");
  1300.     WriteStr ("\nTYPE\n"); INC (indentLevel);
  1301.     Scan (WriteTypes); DEC (indentLevel);
  1302.     PutStr ("\x9B\x4B    Writing Vars...\r");
  1303.     WriteStr ("\nVAR\n\n"); INC (indentLevel);
  1304.     Scan (WriteVars); DEC (indentLevel);
  1305.     PutStr ("\x9B\x4B    Writing Procedures...\r");
  1306.     WriteStr ("\n(* PROCEDURES *)\n\n");
  1307.     Scan (WriteProcs);
  1308.     PutStr ("\x9B\x4B    Writing Trailer...\r");
  1309.     WriteTrailer (name);
  1310.  
  1311.     f.Register (defFile); f.Set (SR, NIL, 0)
  1312.   ELSE
  1313.     PutStr ("\x9B\x4B !! Could not open ");
  1314.     PutStr (fileName); PutStr ("\n");
  1315.   END;
  1316.   CloseScope
  1317. END Export;
  1318.  
  1319. (*--- INITIALISATION ---------------------------------*)
  1320.  
  1321. (*------------------------------------*)
  1322. PROCEDURE InitStruct (VAR typ : Struct; f : INTEGER);
  1323.  
  1324. BEGIN (* InitStruct *)
  1325.   typ := AllocStruct (); typ.form := f; typ.size := 1
  1326. END InitStruct;
  1327.  
  1328. (*------------------------------------*)
  1329. (* $D- disable copying of open arrays *)
  1330. PROCEDURE EnterTyp (
  1331.   name : ARRAY OF CHAR; form, size : INTEGER; VAR res: Struct);
  1332.  
  1333.   VAR obj : Object; typ : Struct;
  1334.  
  1335. BEGIN (* EnterTyp *)
  1336.   Insert (name, obj, Typ); typ := AllocStruct ();
  1337.   obj.typ := typ; obj.visible := Exp;
  1338.   typ.form := form; typ.strobj := obj; typ.size := size;
  1339.   res := typ;
  1340. END EnterTyp;
  1341.  
  1342. BEGIN (* ODT *)
  1343.   nameSize := 0; topScope := NIL;
  1344.   InitStruct (undftyp, Undef); InitStruct (notyp, NoTyp);
  1345.   InitStruct (stringtyp, String); InitStruct (niltyp, NilTyp);
  1346.   OpenScope (0);
  1347.  
  1348.   (* initialisation of module SYSTEM *)
  1349.  
  1350.   EnterTyp ("SYSTEM.BYTESET", BSet, BSetSize, bsettyp);
  1351.   EnterTyp ("SYSTEM.WORDSET", WSet, WSetSize, wsettyp);
  1352.   EnterTyp ("SYSTEM.PTR", PtrTyp, PtrSize, ptrtyp);
  1353.   EnterTyp ("SYSTEM.BPTR", BPtrTyp, PtrSize, bptrtyp);
  1354.   EnterTyp ("SYSTEM.CPTR", CPtrTyp, PtrSize, cptrtyp);
  1355.   EnterTyp ("SYSTEM.BYTE", Byte, ByteSize, bytetyp);
  1356.   EnterTyp ("SYSTEM.WORD", Word, WordSize, wordtyp);
  1357.   EnterTyp ("SYSTEM.LONGWORD", Longword, LongSize, lwordtyp);
  1358.   EnterTyp ("SYSTEM.TYPETAG", TagTyp, PtrSize, tagtyp);
  1359.  
  1360.   syslink := topScope.link; universe := topScope; topScope.link := NIL;
  1361.  
  1362.   (* initialisation of predeclared types and procedures *)
  1363.  
  1364.   EnterTyp ("CHAR", Char, CharSize, chartyp);
  1365.   EnterTyp ("SET", Set, SetSize, settyp);
  1366.   EnterTyp ("REAL", Real, RealSize, realtyp);
  1367.   EnterTyp ("INTEGER", Int, IntSize, inttyp);
  1368.   EnterTyp ("LONGINT", LInt, LIntSize, linttyp);
  1369.   EnterTyp ("LONGREAL", LReal, LRealSize, lrltyp);
  1370.   EnterTyp ("SHORTINT", SInt, SIntSize, sinttyp);
  1371.   EnterTyp ("BOOLEAN", Bool, BoolSize, booltyp);
  1372.  
  1373.   nameOrg := nameX;
  1374.   backupTab := nameTab; (* Save hash table for names so we can restore it *)
  1375. END ODT.
  1376.  
  1377. (*************************************************************************
  1378.  
  1379.   $Log: ODT.mod $
  1380.   Revision 1.3  1994/08/08  16:35:10  fjc
  1381.   Release 1.4
  1382.  
  1383.   Revision 1.2  1994/07/22  13:54:09  fjc
  1384.   - Added code to handle FProc objects.
  1385.  
  1386.   Revision 1.1  1994/07/09  21:54:16  fjc
  1387.   Initial revision
  1388.  
  1389. *************************************************************************)
  1390.  
  1391.