home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / source / obrn-a_1.5_src.lha / oberon-a / source3.lha / Source / OC / OCT.mod < prev   
Encoding:
Text File  |  1995-01-26  |  54.2 KB  |  1,852 lines

  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCT.mod $
  4.   Description: Symbol table handler
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.12 $
  8.       $Author: fjc $
  9.         $Date: 1995/01/26 00:17:17 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1995, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. *************************************************************************)
  19.  
  20. <* STANDARD- *> <* MAIN- *>
  21.  
  22. MODULE OCT;
  23.  
  24. IMPORT
  25.   SYS := SYSTEM, E := Exec, Str := Strings, DU := DosUtil,
  26.   F := Files, OCM, OCS, conv := Conversions, OCStrings;
  27.  
  28.  
  29. (* --- Exported declarations -------------------------------------------- *)
  30.  
  31. CONST
  32.   maxImps = 64;
  33.  
  34.   (* structure forms *)
  35.   Undef * = 0; Byte * = 1; Bool * = 2; Char * = 3; SInt * = 4; Int * = 5;
  36.   LInt * = 6; Real * = 7; LReal * = 8; BSet * = 9; WSet * = 10; Set * = 11;
  37.   String * = 12; NilTyp * = 13; NoTyp * = 14; PtrTyp * = 15; AdrTyp * = 16;
  38.   BPtrTyp * = 17; Word * = 18; Longword * = 19; TagTyp * = 20;
  39.   Pointer * = 21; ProcTyp * = 24; Array * = 25; DynArr * = 26;
  40.   Record * = 27;
  41.  
  42.   (* standard procedure codes *)
  43.   pABS * = 0; pCAP * = 1; pCHR * = 2; pENTIER * = 3; pHALT * = 4;
  44.   pLONG * = 5; pMAX * = 6; pMIN * = 7; pNEW * = 8; pODD * = 9;
  45.   pORD * = 10; pSHORT * = 11;
  46.  
  47.   pASH * = 19; pASSERT * = 20; pCOPY * = 21; pDEC * = 22; pEXCL * = 23;
  48.   pINC * = 24; pINCL * = 25; pLEN * = 26;
  49.  
  50.   (* module SYSTEM procedure codes *)
  51.   pADR * = 12; pCC * = 13; pDISPOSE * = 14; pREG * = 15; pSIZE * = 16;
  52.   pSTRLEN * = 17; pTAG * = 18;
  53.  
  54.   pAND * = 27; pBIT * = 28; pGET * = 29; pGETREG * = 30; pLSH * = 31;
  55.   pOR * = 32; pPUT * = 33; pPUTREG * = 34; pSETREG * = pPUTREG;
  56.   pROT * = 35; pVAL * = 36; pXOR * = 37;
  57.  
  58.   pINLINE * = 38; pMOVE * = 39; pSYSNEW * = 40;
  59.  
  60.   LastProc * = pSYSNEW;
  61.   TwoPar * = pASH;
  62.  
  63.   (* String lengths *)
  64.  
  65.   NameLen * = 255;
  66.   PathLen = 256;
  67.   LabelLen = NameLen * 2 + 1;
  68.  
  69.   (* Values for visible field of ObjDesc *)
  70.  
  71.   Exp * = -1;
  72.   NotExp * = 0;
  73.   RdOnly * = 1;
  74.  
  75. TYPE
  76.   Name = ARRAY NameLen + 1 OF CHAR;
  77.   Label * = POINTER TO ARRAY (*LabelLen*) OF CHAR;
  78.  
  79.   Object * = POINTER TO ObjDesc;
  80.   Module * = POINTER TO ModDesc;
  81.   Struct * = POINTER TO StrDesc;
  82.  
  83.   ObjDesc * = RECORD
  84.     left *, right *, link * : Object;
  85.     typ * : Struct;
  86.     a0 *, a1 * : LONGINT;
  87.     a2 * : INTEGER;
  88.     fwd * : BOOLEAN;
  89.     mode * : SHORTINT;
  90.     visible * : SHORTINT;
  91.     name * : LONGINT;
  92.     label * : Label;
  93.   END; (* ObjDesc *)
  94.  
  95.   ModDesc * = RECORD (ObjDesc)
  96.     varLab *, constLab *, gcLab *, endLab * : Label;
  97.   END; (* ModDesc *)
  98.  
  99.   StrDesc * = RECORD
  100.     form *, sysflg *, mno *, ref * : INTEGER;
  101.     n *, size *, adr * : LONGINT;
  102.     BaseTyp * : Struct;
  103.     link *, strobj * : Object;
  104.     label * : Label;
  105.   END; (* StrDesc *)
  106.  
  107.   Desc * = POINTER TO DescRec;
  108.   DescRec = RECORD
  109.     next : Desc;
  110.     mode *, lev * : INTEGER;
  111.     a0 *, a1 * : LONGINT;
  112.     a2 * : INTEGER;
  113.   END; (* DescRec *)
  114.  
  115.   Item * = RECORD
  116.     mode *, lev * : INTEGER;
  117.     a0 *, a1 * : LONGINT;
  118.     a2 * : INTEGER;
  119.     typ * : Struct;
  120.     obj * : Object;
  121.     label * : Label;
  122.     wordIndex *, rdOnly * : BOOLEAN;
  123.     desc * : Desc
  124.   END; (* Item *)
  125.  
  126. VAR
  127.   topScope * : Object;
  128.  
  129.   undftyp *, bytetyp *, booltyp *, chartyp *, sinttyp *, inttyp *,
  130.   linttyp *, realtyp *, lrltyp *, settyp *, stringtyp *, niltyp *, notyp *,
  131.   ptrtyp *, adrtyp *, bptrtyp *, bsettyp *, wsettyp *, wordtyp *,
  132.   lwordtyp *, tagtyp *
  133.     : Struct;
  134.  
  135.   nofGmod * : INTEGER; (* nof imports *)
  136.   GlbMod * : ARRAY maxImps OF Module;
  137.  
  138.   ModuleName * : Name;
  139.  
  140.   VarLabel *, ConstLabel *, InitLabel *, EndLabel *, GCLabel *,
  141.   PointerDesc *
  142.     : Label;
  143.  
  144.  
  145. (* --- Local declarations ----------------------------------------------- *)
  146.  
  147.  
  148. CONST
  149.   (* object modes *)
  150.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  151.   Con = OCM.Con; Reg = OCM.Reg; RegI = OCM.RegI; RegX = OCM.RegX;
  152.   Fld = OCM.Fld; Typ = OCM.Typ; LProc = OCM.LProc; XProc = OCM.XProc;
  153.   SProc = OCM.SProc; LibCall = OCM.LibCall; TProc = OCM.TProc;
  154.   AProc = OCM.AProc; Mod = OCM.Mod; Head = OCM.Head; VarArg = OCM.VarArg;
  155.   M2Proc = OCM.M2Proc; CProc = OCM.CProc;
  156.  
  157.   (* System flags *)
  158.  
  159.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  160.   AsmFlag = OCM.AsmFlag; BCPLFlag = OCM.BCPLFlag;
  161.  
  162.   SFtag * = 53594D08H; (* "SYM" + version # *)
  163.   MinSFtag = 53594D08H; (* Earliest version that can be read. *)
  164.   firstStr = 32; maxStr = 512;
  165.   maxUDP = 128; maxMod = 32; maxParLev = 6; maxExtLib = 8;
  166.   NotYetExp = 0;
  167.  
  168.   (* terminal symbols for symbol file elements *)
  169.   eUndef = 0; eCon = 1; eTypE = 2; eTyp = 3; eVar = 4; eXProc = 5;
  170.   eLibCall = 6; eM2Proc = 7; eCProc = 8; eAProc = 9; ePointer = 10;
  171.   eProcTyp = 11; eArray = 12; eDynArr = 13; eRecord = 14; eParList = 15;
  172.   eValPar = 16; eVarPar = 17; eVarArg = 18; eFldList = 19; eFld = 20;
  173.   eHPtr = 21; eHProc = 22; eTProcE = 23; eTProc = 24; eFixup = 25;
  174.   eMod = 26; eExtLib = 27;
  175.  
  176.   (* name buffer size *)
  177.  
  178.   BufSize = 16384;
  179.   MaxBuffers = 16;
  180.   HashTableSize = 251;
  181.  
  182. TYPE
  183.  
  184.   NameBufPtr = POINTER TO ARRAY BufSize OF CHAR;
  185.  
  186. VAR
  187.   universe, syslink : Object;
  188.   strno, udpinx : INTEGER; (* for export *)
  189.   nofExp : SHORTINT;
  190.   SR : F.Rider;
  191.   undPtr : ARRAY maxUDP OF Struct;
  192.   nameBuf : ARRAY MaxBuffers OF NameBufPtr;
  193.   nameX, nameOrg, nameSize : LONGINT;
  194.   nameTab, backupTab : ARRAY HashTableSize OF LONGINT;
  195.   ObjectList : Object;
  196.   StructList : Struct;
  197.   DescList   : Desc;
  198.  
  199.   (* These are assumed to have all fields zeroed by the loader. *)
  200.   emptyObj  : ObjDesc;
  201.   emptyStr  : StrDesc;
  202.   emptyDesc : DescRec;
  203.  
  204.   nofExtLib : INTEGER;
  205.   extLib : ARRAY maxExtLib OF LONGINT;
  206.  
  207. (* CONST mname = "OCT"; *)
  208.  
  209.  
  210. (*--- Procedure declarations -------------------------------------------*)
  211.  
  212.  
  213. (*------------------------------------*)
  214. PROCEDURE Tagged * ( typ : Struct ) : BOOLEAN;
  215. BEGIN (* Tagged *)
  216.   RETURN ((typ.form IN {Record, Pointer}) & (typ.sysflg = OberonFlag))
  217. END Tagged;
  218.  
  219. (*------------------------------------*)
  220. PROCEDURE Address * ( typ : Struct ) : BOOLEAN;
  221. BEGIN (* Address *)
  222.   RETURN
  223.     ((typ.form = Pointer) & (typ.sysflg IN {M2Flag, CFlag, AsmFlag}))
  224.     OR (typ.form = AdrTyp) OR (typ.form = NilTyp)
  225. END Address;
  226.  
  227. (*------------------------------------*)
  228. PROCEDURE AllocObj * () : Object;
  229.  
  230.   (* CONST name = "AllocObj"; *)
  231.  
  232.   VAR newObj : Object;
  233.  
  234. BEGIN (* AllocObj *)
  235.   (*OCM.TraceIn (mname, name);*)
  236.   IF ObjectList = NIL THEN
  237.     NEW (newObj)
  238.   ELSE
  239.     newObj := ObjectList; ObjectList := ObjectList.link
  240.   END;
  241.   newObj^ := emptyObj;
  242.   (*OCM.TraceOut (mname, name);*)
  243.   RETURN newObj
  244. END AllocObj;
  245.  
  246. (*------------------------------------*)
  247. PROCEDURE FreeObj * (obj : Object);
  248.  
  249.   (* CONST name = "FreeObj"; *)
  250.  
  251. BEGIN (* FreeObj *)
  252.   (*OCM.TraceIn (mname, name);*)
  253.   IF obj # NIL THEN
  254.     FreeObj (obj.left); FreeObj (obj.right);
  255.     obj^ := emptyObj;
  256.     obj.link := ObjectList; ObjectList := obj
  257.   END
  258.   (*;OCM.TraceOut (mname, name);*)
  259. END FreeObj;
  260.  
  261. (*------------------------------------*)
  262. PROCEDURE AllocStruct * () : Struct;
  263.  
  264.   (* CONST name = "AllocStruct"; *)
  265.  
  266.   VAR newStr : Struct;
  267.  
  268. BEGIN (* AllocStruct *)
  269.   (*OCM.TraceIn (mname, name);*)
  270.   IF StructList = NIL THEN
  271.     NEW (newStr)
  272.   ELSE
  273.     newStr := StructList; StructList := StructList.BaseTyp;
  274.     newStr.BaseTyp := NIL
  275.   END;
  276.   (*;OCM.TraceOut (mname, name);*)
  277.   RETURN newStr
  278. END AllocStruct;
  279.  
  280. (*------------------------------------*)
  281. PROCEDURE FreeStruct (str : Struct);
  282.  
  283.   (* CONST name = "FreeStruct"; *)
  284.  
  285. BEGIN (* FreeStruct *)
  286.   (*OCM.TraceIn (mname, name);*)
  287.   IF str # NIL THEN
  288.     FreeObj (str.link); str^ := emptyStr;
  289.     str.BaseTyp := StructList; StructList := str
  290.   END
  291.   (*;OCM.TraceOut (mname, name);*)
  292. END FreeStruct;
  293.  
  294. (*------------------------------------*)
  295. PROCEDURE AllocDesc * () : Desc;
  296.  
  297.   VAR newDesc : Desc;
  298.  
  299.   (* CONST name = "AllocDesc"; *)
  300.  
  301. BEGIN (* AllocDesc *)
  302.   (*OCM.TraceIn (mname, name);*)
  303.   IF DescList = NIL THEN NEW (newDesc)
  304.   ELSE newDesc := DescList; DescList := DescList.next; newDesc.next := NIL
  305.   END;
  306.   (*;OCM.TraceOut (mname, name);*)
  307.   RETURN newDesc
  308. END AllocDesc;
  309.  
  310. (*------------------------------------*)
  311. PROCEDURE FreeDesc * (VAR desc : Desc);
  312.  
  313.   (* CONST name = "FreeDesc"; *)
  314.  
  315. BEGIN (* FreeDesc *)
  316.   (*OCM.TraceIn (mname, name);*)
  317.   IF desc # NIL THEN
  318.     desc^ := emptyDesc; desc.next := DescList; DescList := desc;
  319.     desc := NIL
  320.   END
  321.   (*;OCM.TraceOut (mname, name);*)
  322. END FreeDesc;
  323.  
  324. (*------------------------------------*)
  325. PROCEDURE Init * ();
  326.  
  327.   (* CONST name = "Init"; *)
  328.  
  329. BEGIN (* Init *)
  330.   (* OCM.TraceIn (mname, name); *)
  331.   topScope := universe; strno := 0; udpinx := 0; nofGmod := 0;
  332.   ModuleName := ""; COPY ("VAR", VarLabel^); COPY ("CONST", ConstLabel^);
  333.   COPY ("INIT", InitLabel^); COPY ("END", EndLabel^); COPY ("GC", GCLabel^);
  334.   nofExtLib := 0;
  335.   (* ;OCM.TraceOut (mname, name); *)
  336. END Init;
  337.  
  338. (*------------------------------------*)
  339. PROCEDURE Close * ();
  340.  
  341.   (* CONST name = "Close"; *)
  342.  
  343.   VAR i : INTEGER;
  344.  
  345. BEGIN (* Close *)
  346.   (* OCM.TraceIn (mname, name); *)
  347.   F.Set (SR, NIL, 0);
  348.   i := 0; WHILE i < maxImps DO GlbMod [i] := NIL; INC (i) END;
  349.   (* Restore original hash table for reserved names... *)
  350.   nameTab := backupTab; nameX := nameOrg;
  351.   (* ... Assuming that only one name buffer is required *)
  352.   nameSize := BufSize;
  353.   i := 1; WHILE i < MaxBuffers DO nameBuf [i] := NIL; INC (i) END
  354.   (* ;OCM.TraceOut (mname, name); *)
  355. END Close;
  356.  
  357. (*------------------------------------*)
  358. PROCEDURE^ Join (module, object : LONGINT; VAR name : ARRAY OF CHAR);
  359. PROCEDURE^ InsertName * (n : ARRAY OF CHAR) : LONGINT;
  360.  
  361. PROCEDURE StartModule * ();
  362.  
  363.   (* CONST name = "StartModule"; *)
  364.  
  365.   VAR mn : LONGINT;
  366.  
  367. BEGIN (* StartModule *)
  368.   (* OCM.TraceIn (mname, name); *)
  369.   mn := InsertName (ModuleName);
  370.   Join (mn, InsertName ("VAR"), VarLabel^);
  371.   Join (mn, InsertName ("CONST"), ConstLabel^);
  372.   Join (mn, InsertName ("GC-OFFSET"), GCLabel^);
  373.   (* ;OCM.TraceOut (mname, name); *)
  374. END StartModule;
  375.  
  376. (*------------------------------------*)
  377. PROCEDURE ExtLib * ();
  378. BEGIN (* ExtLib *)
  379.   IF nofExtLib >= maxExtLib THEN OCS.Mark (234); nofExtLib := 0 END;
  380.   extLib [nofExtLib] := InsertName (OCS.name); INC (nofExtLib)
  381. END ExtLib;
  382.  
  383. (*------------------------------------*)
  384. PROCEDURE EndModule * ();
  385.  
  386. BEGIN (* EndModule *)
  387. END EndModule;
  388.  
  389. (*------------------------------------*)
  390. PROCEDURE CheckBuf (size : LONGINT);
  391.  
  392.   (* CONST name = "CheckBuf"; *)
  393.  
  394.   VAR newBuf : NameBufPtr; newX : LONGINT;
  395.  
  396. BEGIN (* CheckBuf *)
  397.   (* OCM.TraceIn (mname, name); *)
  398.   newX := nameX + size + 4;
  399.   IF newX >= nameSize THEN
  400.     IF newX >= BufSize * MaxBuffers THEN
  401.       OCS.Mark (310); nameX := 0
  402.     ELSE
  403.       IF ((newX-1) MOD BufSize) < (size+4) THEN nameX := nameSize END;
  404.       NEW (newBuf);
  405.       INC (nameSize, BufSize);
  406.       nameBuf [(nameSize - 1) DIV BufSize] := newBuf
  407.     END
  408.   END
  409.   (* ;OCM.TraceOut (mname, name); *)
  410. END CheckBuf;
  411.  
  412. (*------------------------------------*)
  413. PROCEDURE InsertName * (n : ARRAY OF CHAR) : LONGINT;
  414.  
  415.   (* CONST name = "InsertName"; *)
  416.  
  417.   VAR i, j, k, len, bufX : INTEGER; x, x1 : LONGINT; ch : CHAR;
  418.       buf : NameBufPtr;
  419.  
  420. <*$CopyArrays-*>
  421. BEGIN (* InsertName *)
  422.   (* OCM.TraceIn (mname, name); *)
  423.   k := 0; len := 0; ch := n [0];
  424.   WHILE ch # 0X DO
  425.     <*$OvflChk-*>
  426.     INC (k, ORD (ch));
  427.     <*$OvflChk+*>
  428.     INC (len); ch := n [len]
  429.   END;
  430.   k := (k + len) MOD HashTableSize;
  431.   x := nameTab [k];
  432.   LOOP
  433.     IF x = 0 THEN
  434.       CheckBuf (len);
  435.       buf := nameBuf [nameX DIV BufSize];
  436.       bufX := SHORT (nameX MOD BufSize);
  437.       buf [bufX] := CHR (nameTab [k] DIV 10000H); INC (bufX);
  438.       buf [bufX] := CHR (nameTab [k] DIV 100H);   INC (bufX);
  439.       buf [bufX] := CHR (nameTab [k]);            INC (bufX);
  440.       i := 0;
  441.       WHILE i <= len DO buf [bufX] := n [i]; INC (bufX); INC (i) END;
  442.       x := nameX + 3; nameTab [k] := x; nameX := nameX + len + 4;
  443.       (* ;OCM.TraceOut (mname, name); *)
  444.       RETURN x
  445.     ELSE
  446.       buf := nameBuf [x DIV BufSize];
  447.       bufX := SHORT (x MOD BufSize);
  448.       x1 :=
  449.         (LONG (ORD (buf [bufX - 3])) * 10000H)
  450.         + (LONG (ORD (buf [bufX - 2])) * 100H)
  451.         + LONG (ORD (buf [bufX - 1]));
  452.       i := bufX; j := 0;
  453.       LOOP
  454.         IF buf [i] # n [j] THEN
  455.           x := x1; EXIT
  456.         ELSIF n [j] = 0X THEN
  457.           (* ;OCM.TraceOut (mname, name); *)
  458.           RETURN x
  459.         ELSE
  460.           INC (i); INC (j)
  461.         END
  462.       END
  463.     END; (* ELSE *)
  464.   END; (* LOOP *)
  465. END InsertName;
  466.  
  467. (*------------------------------------*)
  468. PROCEDURE NameLength (name : LONGINT) : INTEGER;
  469.  
  470.   (* CONST pname = "NameLength"; *)
  471.  
  472.   VAR buf : NameBufPtr; len, bufX : INTEGER;
  473.  
  474. BEGIN (* NameLength *)
  475.   (* OCM.TraceIn (mname, pname); *)
  476.   buf := nameBuf [name DIV BufSize];
  477.   bufX := SHORT (name MOD BufSize);
  478.   len := 0;
  479.   WHILE buf [bufX] # 0X DO INC (len); INC (bufX) END;
  480.   (* ;OCM.TraceOut (mname, pname); *)
  481.   RETURN len
  482. END NameLength;
  483.  
  484. (*------------------------------------*)
  485. PROCEDURE GetName * (adr : LONGINT; VAR name : ARRAY OF CHAR);
  486.  
  487.   (* CONST pname = "GetName"; *)
  488.  
  489.   VAR buf : NameBufPtr; i, bufX : INTEGER; ch :  CHAR;
  490.  
  491. BEGIN (* GetName *)
  492.   (* OCM.TraceIn (mname, pname); *)
  493.   buf := nameBuf [adr DIV BufSize];
  494.   bufX := SHORT (adr MOD BufSize);
  495.   i := 0;
  496.   REPEAT
  497.     ch := buf [bufX]; name [i] := ch;
  498.     INC (i); INC (bufX)
  499.   UNTIL ch = 0X;
  500.   (* ;OCM.TraceOut (mname, pname); *)
  501. END GetName;
  502.  
  503. (*------------------------------------*)
  504. PROCEDURE FindObj (obj : Object; name : ARRAY OF CHAR) : Object;
  505.  
  506.   VAR
  507.     buf : NameBufPtr; n1, n2 : LONGINT; bufX, i : INTEGER; ch1, ch2 : CHAR;
  508.  
  509. <*$CopyArrays-*>
  510. BEGIN (* FindObj *)
  511.   n1 := InsertName (name);
  512.   WHILE (obj # NIL) & (obj.name # n1) DO
  513.     n2 := obj.name; i := 0;
  514.     buf := nameBuf [n2 DIV BufSize]; bufX := SHORT (n2 MOD BufSize);
  515.     REPEAT
  516.       ch1 := name [i]; INC (i);
  517.       ch2 := buf [bufX]; INC (bufX)
  518.     UNTIL ch1 # ch2;
  519.     IF ch1 < ch2 THEN obj := obj.left
  520.     ELSE obj := obj.right
  521.     END
  522.   END;
  523.   RETURN obj
  524. END FindObj;
  525.  
  526. (*------------------------------------*)
  527. PROCEDURE FindImport * (mod : Object; VAR res : Object);
  528.  
  529.   (* CONST name = "FindImport"; *)
  530.  
  531.   VAR obj : Object;
  532.  
  533. BEGIN (* FindImport *)
  534.   (* OCM.TraceIn (mname, name); *)
  535.   obj := FindObj (mod.link, OCS.name);
  536.   IF (obj # NIL) & (obj.mode = Typ) & (obj.visible = NotExp) THEN
  537.     obj := NIL
  538.   END;
  539.   res := obj
  540.   (* ;OCM.TraceOut (mname, name); *)
  541. END FindImport;
  542.  
  543. (*------------------------------------*)
  544. PROCEDURE Find * (VAR res : Object; VAR level : INTEGER);
  545.  
  546.   (* CONST name = "Find"; *)
  547.  
  548.   VAR obj, head : Object;
  549.  
  550. BEGIN (* Find *)
  551.   (* OCM.TraceIn (mname, name); *)
  552.   head := topScope;
  553.   LOOP
  554.     obj := FindObj (head.link, OCS.name);
  555.     IF obj # NIL THEN level := SHORT (head.a0); EXIT END;
  556.     head := head.left;
  557.     IF head = NIL THEN level := 0; EXIT END;
  558.   END;
  559.   res := obj;
  560.   (* ;OCM.TraceOut (mname, name); *)
  561. END Find;
  562.  
  563. (*------------------------------------*)
  564. PROCEDURE FindField * (typ : Struct; VAR res : Object);
  565.  
  566.   (* CONST name = "FindField"; *)
  567.  
  568.   VAR obj : Object; typ1 : Struct; n : LONGINT;
  569.  
  570. BEGIN (* FindField *)
  571.   (* OCM.TraceIn (mname, name); *)
  572.   (* typ.form = Record *)
  573.   typ1 := typ; n := InsertName (OCS.name);
  574.   LOOP
  575.     obj := typ1.link;
  576.     WHILE (obj # NIL) & (obj.name # n) DO obj := obj.left END;
  577.     IF obj # NIL THEN EXIT END;
  578.     typ1 := typ1.BaseTyp;
  579.     IF typ1 = NIL THEN EXIT END
  580.   END;
  581.   res := obj;
  582.   (* ;OCM.TraceOut (mname, name); *)
  583. END FindField;
  584.  
  585. (*------------------------------------*)
  586. PROCEDURE SuperCall * (pname : LONGINT; typ : Struct; VAR proc : Object);
  587.  
  588.   (* CONST name = "SuperCall"; *)
  589.  
  590.   VAR obj : Object;
  591.  
  592. BEGIN (* SuperCall *)
  593.   (* OCM.TraceIn (mname, name); *)
  594.   obj := NIL;
  595.   IF (typ # NIL) & (typ.form = Pointer) THEN typ := typ.BaseTyp END;
  596.   IF (typ # NIL) & (typ # undftyp) THEN
  597.     LOOP
  598.       typ := typ.BaseTyp;
  599.       IF typ = NIL THEN EXIT END;
  600.       obj := typ.link;
  601.       WHILE (obj # NIL) & ((obj.mode # TProc) OR (obj.name # pname)) DO
  602.         obj := obj.left
  603.       END;
  604.       IF obj # NIL THEN EXIT END
  605.     END
  606.   END;
  607.   proc := obj
  608.   (* ;OCM.TraceOut (mname, name); *)
  609. END SuperCall;
  610.  
  611. (*------------------------------------*)
  612. PROCEDURE NextProc * (typ : Struct) : LONGINT;
  613.  
  614.   (* CONST name = "NextProc"; *)
  615.  
  616.   VAR pno : LONGINT; obj : Object;
  617.  
  618. BEGIN (* NextProc *)
  619.   (* OCM.TraceIn (mname, name); *)
  620.   (* typ.form = Record *)
  621.   pno := 0;
  622.   REPEAT
  623.     obj := typ.link;
  624.     WHILE obj # NIL DO
  625.       IF (obj.mode = TProc) & (obj.a0 > pno) THEN pno := obj.a0 END;
  626.       obj := obj.left
  627.     END;
  628.     typ := typ.BaseTyp;
  629.   UNTIL typ = NIL;
  630.   (* ;OCM.TraceOut (mname, name); *)
  631.   RETURN pno + 1
  632. END NextProc;
  633.  
  634. (*------------------------------------*)
  635. PROCEDURE InsertObj
  636.   ( VAR name : ARRAY OF CHAR; root : Object; mode : SHORTINT;
  637.     VAR res : Object ) : BOOLEAN;
  638.  
  639.   (* CONST pname = "InsertObj"; *)
  640.  
  641.   VAR
  642.     obj, prev : Object; mod : Module; result : BOOLEAN;
  643.     buf : NameBufPtr; n1, n2 : LONGINT; bufX, i : INTEGER; ch1, ch2 : CHAR;
  644.  
  645. BEGIN (* InsertObj *)
  646.   (* OCM.TraceIn (mname, pname); *)
  647.  
  648.   prev := root; obj := root.link; n1 := InsertName (name);
  649.   WHILE (obj # NIL) & (obj.name # n1) DO
  650.     prev := obj; n2 := obj.name; i := 0;
  651.     buf := nameBuf [n2 DIV BufSize]; bufX := SHORT (n2 MOD BufSize);
  652.     REPEAT
  653.       ch1 := name [i]; INC (i);
  654.       ch2 := buf [bufX]; INC (bufX)
  655.     UNTIL ch1 # ch2;
  656.     IF ch1 < ch2 THEN obj := obj.left
  657.     ELSE obj := obj.right
  658.     END
  659.   END;
  660.   IF obj = NIL THEN
  661.     IF mode = Mod THEN NEW (mod); obj := mod
  662.     ELSE obj := AllocObj ()
  663.     END;
  664.     obj.name := n1; obj.mode := mode;
  665.     IF prev = root THEN
  666.       root.link := obj
  667.     ELSE
  668.       IF ch1 < ch2 THEN prev.left := obj
  669.       ELSE prev.right := obj
  670.       END
  671.     END;
  672.     result := TRUE
  673.   ELSE
  674.     result := FALSE
  675.   END;
  676.   res := obj;
  677.   (* ;OCM.TraceOut (mname, pname); *)
  678.   RETURN result
  679. END InsertObj;
  680.  
  681. (*------------------------------------*)
  682. PROCEDURE Insert *
  683.   ( VAR name : ARRAY OF CHAR; VAR res : Object; mode : SHORTINT );
  684.  
  685.   (* CONST pname = "Insert"; *)
  686.  
  687. BEGIN (* Insert *)
  688.   (* OCM.TraceIn (mname, pname); *)
  689.   IF ~InsertObj (name, topScope, mode, res) THEN
  690.     IF res.mode # Undef THEN OCS.Mark (1) END;
  691.     res.mode := mode
  692.   END
  693.   (* ;OCM.TraceOut (mname, pname); *)
  694. END Insert;
  695.  
  696. (*------------------------------------*)
  697. PROCEDURE OpenScope * (level : INTEGER);
  698.  
  699.   (* CONST name = "OpenScope"; *)
  700.  
  701.   VAR head : Object;
  702.  
  703. BEGIN (* OpenScope *)
  704.   (* OCM.TraceIn (mname, name); *)
  705.   head := AllocObj ();
  706.   head.mode := Head; head.a0 := level; head.left := topScope;
  707.   topScope := head;
  708.   (* ;OCM.TraceOut (mname, name); *)
  709. END OpenScope;
  710.  
  711. (*------------------------------------*)
  712. PROCEDURE CloseScope * ();
  713.  
  714.   (* CONST name = "CloseScope"; *)
  715.  
  716.   VAR oldHead : Object;
  717.  
  718. BEGIN (* CloseScope *)
  719.   (* OCM.TraceIn (mname, name); *)
  720.   oldHead := topScope; topScope := topScope.left;
  721.   oldHead^ := emptyObj; oldHead.link := ObjectList; ObjectList := oldHead;
  722.   (* ;OCM.TraceOut (mname, name); *)
  723. END CloseScope;
  724.  
  725.  
  726. (*--- SYMBOLS ---------------------------------*)
  727.  
  728.  
  729. (*------------------------------------*)
  730. PROCEDURE Join (name1, name2 : LONGINT; VAR name : ARRAY OF CHAR);
  731.  
  732.   (* CONST pname = "Join"; *)
  733.  
  734.   VAR src, dst : INTEGER; buf : NameBufPtr; ch : CHAR;
  735.  
  736. BEGIN (* Join *)
  737.   (* OCM.TraceIn (mname, pname); *)
  738.   dst := 0;
  739.  
  740.   buf := nameBuf [name1 DIV BufSize];
  741.   src := SHORT (name1 MOD BufSize);
  742.   ch := buf [src];
  743.   WHILE ch # 0X DO
  744.     name [dst] := ch; INC (src); INC (dst); ch := buf [src]
  745.   END; (* WHILE *)
  746.  
  747.   name [dst] := "_"; INC (dst);
  748.  
  749.   buf := nameBuf [name2 DIV BufSize];
  750.   src := SHORT (name2 MOD BufSize);
  751.   ch := buf [src];
  752.   WHILE ch # 0X DO
  753.     name [dst] := ch; INC (src); INC (dst); ch := buf [src]
  754.   END; (* WHILE *)
  755.  
  756.   name [dst] := 0X
  757.   (* ;OCM.TraceOut (mname, pname); *)
  758. END Join;
  759.  
  760. (*------------------------------------*)
  761. PROCEDURE MakeLabel (moduleName, name : LONGINT; VAR label : Label);
  762.  
  763.   (* CONST pname = "MakeLabel"; *)
  764.  
  765. BEGIN (* MakeLabel *)
  766.   (* OCM.TraceIn (mname, pname); *)
  767.   IF label = NIL THEN
  768.     NEW (label, NameLength (moduleName) + NameLength (name) + 4)
  769.   END;
  770.   Join (moduleName, name, label^)
  771.   (* ;OCM.TraceOut (mname, pname); *)
  772. END MakeLabel;
  773.  
  774. (*------------------------------------*)
  775. PROCEDURE MakeInitProcLabel (module, key : LONGINT; VAR label : Label);
  776.  
  777.   (* CONST name = "MakeInitProcLabel"; *)
  778.  
  779.   VAR
  780.     keyPart : ARRAY 10 OF CHAR;
  781.     modname : ARRAY 40 OF CHAR;
  782.  
  783. BEGIN (* MakeInitProcLabel *)
  784.   (* OCM.TraceIn (mname, name); *)
  785.   GetName (module, modname);
  786.   ASSERT (conv.IntToStr (key, 16, 9, "0", keyPart));
  787.   IF label = NIL THEN NEW (label, Str.Length (modname) + 16) END;
  788.   COPY (modname, label^); Str.Append ("_", label^);
  789.   Str.Append (keyPart, label^); Str.Append ("INIT", label^)
  790.   (* ;OCM.TraceOut (mname, name); *)
  791. END MakeInitProcLabel;
  792.  
  793. (*------------------------------------*)
  794. PROCEDURE MakeProcLabel * (obj : Object);
  795.  
  796.   (* CONST name = "MakeProcLabel"; *)
  797.  
  798.   VAR pnoPart : ARRAY 6 OF CHAR; mn : LONGINT;
  799.  
  800. BEGIN (* MakeProcLabel *)
  801.   (* OCM.TraceIn (mname, name); *)
  802.   IF obj.a0 = 0 THEN
  803.     MakeLabel (InsertName (ModuleName), obj.name, obj.label);
  804.   ELSE
  805.     ASSERT (conv.IntToStr (obj.a0, 10, 0, "0", pnoPart));
  806.     NEW (obj.label, Str.Length (ModuleName) + Str.Length (pnoPart) + 4);
  807.     COPY (ModuleName, obj.label^);
  808.     Str.Append ("_", obj.label^);
  809.     Str.Append (pnoPart, obj.label^);
  810.     Str.Append ("P", obj.label^)
  811.   END
  812.   (* ;OCM.TraceOut (mname, name); *)
  813. END MakeProcLabel;
  814.  
  815. (*------------------------------------*)
  816. PROCEDURE MakeTypeLabel * (typ : Struct);
  817.  
  818.   (* CONST name = "MakeTypeLabel"; *)
  819.  
  820.   VAR
  821.     label : ARRAY LabelLen OF CHAR; typname : Name;
  822.     typnum : ARRAY 16 OF CHAR;
  823.  
  824. BEGIN (* MakeTypeLabel *)
  825.   (* OCM.TraceIn (mname, name); *)
  826.   IF
  827.     (typ.label = NIL) & (typ.sysflg = OberonFlag) &
  828.     ( (typ.form = Record) OR
  829.       ((typ.form = Pointer) & (typ.BaseTyp.form = DynArr)))
  830.   THEN
  831.     IF typ.mno > 0 THEN GetName (GlbMod [typ.mno-1].name, label)
  832.     ELSE COPY (ModuleName, label)
  833.     END;
  834.     Str.Append ("_", label);
  835.     ASSERT (conv.IntToStr (typ.adr, 10, 0, "0", typnum));
  836.     Str.Append (typnum, label); Str.Append ("T", label);
  837.     NEW (typ.label, Str.Length (label) + 1);
  838.     COPY (label, typ.label^)
  839.   END
  840.   (* ;OCM.TraceOut (mname, name); *)
  841. END MakeTypeLabel;
  842.  
  843. (*------------------------------------*)
  844. PROCEDURE MakeTProcLabel * (typ : Struct; proc : Object);
  845.  
  846.   (* CONST pname = "MakeTProcLabel"; *)
  847.  
  848.   VAR
  849.     modname, typname, procname : Name; typnum : ARRAY 16 OF CHAR;
  850.     label : ARRAY LabelLen OF CHAR;
  851.  
  852. BEGIN (* MakeTProcLabel *)
  853.   (* OCM.TraceIn (mname, pname); *)
  854.   IF typ.mno > 0 THEN GetName (GlbMod [typ.mno-1].name, label)
  855.   ELSE COPY (ModuleName, label)
  856.   END;
  857.   Str.Append ("_", label);
  858.   ASSERT (conv.IntToStr (typ.adr, 10, 0, "0", typnum));
  859.   Str.Append (typnum, label); Str.Append ("T_", label);
  860.   GetName (proc.name, procname); Str.Append (procname, label);
  861.   NEW (proc.label, Str.Length (label) + 1);
  862.   COPY (label, proc.label^)
  863.   (* ;OCM.TraceOut (mname, pname); *)
  864. END MakeTProcLabel;
  865.  
  866. (*--- IMPORT ---------------------------------*)
  867.  
  868. (*------------------------------------*)
  869. PROCEDURE ReadInt(VAR i: LONGINT);
  870. (*
  871.   Reads integers written in a compacted form. Taken from J. Templ.
  872.   SPARC-Oberon. User's Guide and Implementation. Computersysteme ETH
  873.   Zürich, Technical Report No. 133, June 1990.
  874. *)
  875.  
  876.   VAR n: LONGINT; s: INTEGER; x: CHAR;
  877.  
  878. BEGIN
  879.   s := 0; n := 0; F.Read(SR, x);
  880.   WHILE ORD(x) >= 128 DO
  881.     INC(n, ASH(ORD(x) - 128, s)); INC(s, 7); F.Read(SR, x)
  882.   END;
  883.   i := n + ASH(ORD(x) MOD 64 - ORD(x) DIV 64 * 64, s)
  884. END ReadInt;
  885.  
  886. (*------------------------------------*)
  887. PROCEDURE ReadLInt (VAR k : LONGINT);
  888.  
  889. BEGIN (* ReadLInt *)
  890.   F.ReadBytes (SR, k, 4);
  891. END ReadLInt;
  892.  
  893. (*------------------------------------*)
  894. PROCEDURE ReadId (VAR id : ARRAY OF CHAR);
  895.  
  896.   VAR i : INTEGER; ch : CHAR;
  897.  
  898. BEGIN (* ReadId *)
  899.   i := 0;
  900.   REPEAT
  901.     F.Read (SR, ch); id [i] := ch; INC (i)
  902.   UNTIL ch = 0X;
  903. END ReadId;
  904.  
  905. (*-----------------------------------*)
  906. PROCEDURE Import * (name, alias : ARRAY OF CHAR);
  907.  
  908.   (* CONST pname = "Import"; *)
  909.  
  910.   VAR
  911.     i, m, s, nofLmod, strno, parlev, fldlev : INTEGER;
  912.     k, l, modname : LONGINT;
  913.     obj : Object;
  914.     modobj : Module;
  915.     class : SHORTINT;
  916.     SymFile : F.File;
  917.     LocMod : ARRAY maxMod OF Module;
  918.     struct : ARRAY maxStr OF Struct;
  919.     lastpar, lastfld : ARRAY maxParLev OF Object;
  920.     pathName : ARRAY 256 OF CHAR;
  921.  
  922.     link : Object;
  923.     typ : Struct;
  924.     a0, a1 : LONGINT;
  925.     a2 : INTEGER;
  926.     mode : SHORTINT;
  927.     visible : SHORTINT;
  928.     label : Label;
  929.     objName : ARRAY NameLen+1 OF CHAR;
  930.  
  931.   (*------------------------------------*)
  932.   PROCEDURE reversedList (p : Object) : Object;
  933.  
  934.     VAR q, r : Object;
  935.  
  936.   BEGIN (* reversedList *)
  937.     q := NIL;
  938.     WHILE p # NIL DO r := p.link; p.link := q; q := p; p := r END;
  939.     RETURN q
  940.   END reversedList;
  941.  
  942. <*$CopyArrays-*>
  943. BEGIN (* Import *)
  944.   (* OCM.TraceIn (mname, pname); *)
  945.   nofLmod := 0; strno := firstStr; parlev := -1; fldlev := -1;
  946.   IF name = "SYSTEM" THEN
  947.     Insert (alias, obj, Mod); obj.link := syslink;
  948.     obj.a0 := 0; obj.typ := notyp
  949.   ELSE
  950.     IF OCM.FindSymbolFile (name, pathName) THEN SymFile := F.Old (pathName)
  951.     ELSE SymFile := NIL
  952.     END;
  953.     IF SymFile # NIL THEN
  954.       IF OCM.Verbose THEN
  955.         OCM.OutStr (" << "); OCM.OutStr (pathName); OCM.OutLn
  956.       END;
  957.       F.Set (SR, SymFile, 0); ReadLInt (k);
  958.       IF k = SFtag THEN
  959.         struct [Undef] := undftyp; struct [Byte] := bytetyp;
  960.         struct [Bool] := booltyp; struct [Char] := chartyp;
  961.         struct [SInt] := sinttyp; struct [Int] := inttyp;
  962.         struct [LInt] := linttyp; struct [Real] := realtyp;
  963.         struct [LReal] := lrltyp; struct [Set] := settyp;
  964.         struct [String] := stringtyp; struct [NilTyp] := niltyp;
  965.         struct [NoTyp] := notyp; struct [BSet] := bsettyp;
  966.         struct [WSet] := wsettyp; struct [PtrTyp] := ptrtyp;
  967.         struct [AdrTyp] := adrtyp; struct [BPtrTyp] := bptrtyp;
  968.         struct [Word] := wordtyp; struct [Longword] := lwordtyp;
  969.         struct [TagTyp] := tagtyp;
  970.         LOOP (* read next item from symbol file *)
  971.           F.Read (SR, class); IF SR.eof THEN EXIT END;
  972.           link := NIL; typ := NIL; a0 := 0; a1 := 0; a2 := 0;
  973.           mode := Undef; visible := NotExp; label := NIL;
  974.           objName := "";
  975.           CASE class OF
  976.             eUndef : OCS.Mark (151);
  977.             |
  978.             eCon .. eAProc : (* object *)
  979.               m := 0; ReadInt (l); s := SHORT (l); typ := struct [s];
  980.               CASE class OF
  981.                 eCon :
  982.                   mode := Con;
  983.                   CASE typ.form OF
  984.                     Byte, Char, BSet, Bool, SInt, Int, WSet,
  985.                     Word, LInt, Real, LReal, Set, Longword :
  986.                       ReadInt (a0);
  987.                     |
  988.                     (*LReal : ReadInt (a0); ReadInt (a1);
  989.                     |*)
  990.                     String :
  991.                       ReadInt (a0); ReadInt (a1);
  992.                       IF a1 <= 2 THEN
  993.                         ReadInt (l); a2 := SHORT (l); label := NIL
  994.                       ELSE
  995.                         label := LocMod[0].constLab
  996.                       END
  997.                     |
  998.                     NilTyp : (* NIL *)
  999.                     |
  1000.                     AdrTyp, BPtrTyp, Pointer, ProcTyp :
  1001.                       (* This is all VERY dodgy, but ... *)
  1002.                       ReadInt (a0)
  1003.                     |
  1004.                   ELSE
  1005.                     OCS.Mark (1002); OCS.Mark (typ.form)
  1006.                   END; (* CASE obj.typ.form *)
  1007.                 |
  1008.                 eTypE, eTyp :
  1009.                   mode := Typ; ReadInt (l); m := SHORT (l);
  1010.                   IF class = eTypE THEN visible := Exp
  1011.                   ELSE visible := NotExp
  1012.                   END
  1013.                 |
  1014.                 eVar :
  1015.                   mode := Var; ReadInt (a0); F.Read (SR, visible)
  1016.                 |
  1017.                 eXProc :
  1018.                   mode := XProc;
  1019.                   link := reversedList (lastpar [parlev]); DEC (parlev)
  1020.                 |
  1021.                 eLibCall : (* library call procedure *)
  1022.                   mode := LibCall;
  1023.                   ReadInt (a0); ReadInt (a1); visible := Exp;
  1024.                   link := reversedList (lastpar [parlev]); DEC (parlev);
  1025.                 |
  1026.                 eM2Proc, eCProc, eAProc :
  1027.                   IF class = eM2Proc THEN mode := M2Proc
  1028.                   ELSIF class = eCProc THEN mode := CProc
  1029.                   ELSE mode := AProc
  1030.                   END;
  1031.                   link := reversedList (lastpar [parlev]); DEC (parlev);
  1032.                   ReadId (objName); NEW (label, Str.Length (objName) + 1);
  1033.                   COPY (objName, label^)
  1034.                 |
  1035.               ELSE
  1036.                 OCS.Mark (1003); OCS.Mark (class)
  1037.               END; (* CASE class *)
  1038.               ReadId (objName);
  1039.               IF InsertObj (objName, LocMod [m], mode, obj) THEN
  1040.                 obj.link := link; obj.typ := typ; obj.a0 := a0;
  1041.                 obj.a1 := a1; obj.a2 := a2; obj.visible := visible;
  1042.                 obj.label := label;
  1043.                 IF class = eXProc THEN
  1044.                   MakeLabel (LocMod [m].name, obj.name, obj.label);
  1045.                 ELSIF mode = Typ THEN
  1046.                   IF typ.strobj = NIL THEN typ.strobj := obj END
  1047.                 END;
  1048.               ELSIF mode = Typ THEN
  1049.                 FreeStruct (typ); struct [s] := obj.typ
  1050.               END
  1051.             |
  1052.             ePointer .. eRecord :
  1053.               (* structure *)
  1054.               typ := AllocStruct (); typ.strobj := NIL; typ.ref := 0;
  1055.               typ.sysflg := OberonFlag;
  1056.               ReadInt (l); typ.BaseTyp := struct [l];
  1057.               ReadInt (l); typ.mno := SHORT (LocMod [l].a0);
  1058.               CASE class OF
  1059.                 ePointer :
  1060.                   typ.form := Pointer; typ.size := OCM.PtrSize;
  1061.                   typ.n := 0; typ.label := PointerDesc;
  1062.                   ReadInt (l); typ.sysflg := SHORT (l);
  1063.                   ReadInt (typ.adr);
  1064.                   IF
  1065.                     (typ.BaseTyp.form = DynArr) & (typ.sysflg = OberonFlag)
  1066.                   THEN
  1067.                     typ.size := typ.BaseTyp.size; MakeTypeLabel (typ)
  1068.                   END
  1069.                 |
  1070.                 eProcTyp :
  1071.                   typ.form := ProcTyp; typ.size := OCM.ProcSize;
  1072.                   typ.link := reversedList (lastpar [parlev]);
  1073.                   DEC (parlev);
  1074.                 |
  1075.                 eArray :
  1076.                   typ.form := Array; ReadInt (typ.size);
  1077.                   ReadInt (typ.adr); ReadInt (l); typ.n := SHORT (l);
  1078.                 |
  1079.                 eDynArr :
  1080.                   typ.form := DynArr; ReadInt (typ.size);
  1081.                   ReadInt (typ.adr);
  1082.                 |
  1083.                 eRecord :
  1084.                   typ.form := Record;
  1085.                   ReadInt (typ.size); typ.n := 0;
  1086.                   typ.link := reversedList (lastfld [fldlev]);
  1087.                   DEC (fldlev);
  1088.                   IF typ.BaseTyp = notyp THEN
  1089.                     typ.BaseTyp := NIL; typ.n := 0
  1090.                   ELSE
  1091.                     typ.n := typ.BaseTyp.n + 1;
  1092.                   END;
  1093.                   ReadInt (l); typ.sysflg := SHORT (l);
  1094.                   ReadInt (typ.adr); (* of descriptor *)
  1095.                   IF typ.sysflg = OberonFlag THEN MakeTypeLabel (typ) END
  1096.                 |
  1097.               ELSE
  1098.                 OCS.Mark (1004); OCS.Mark (class)
  1099.               END; (* CASE class *)
  1100.               struct [strno] := typ; INC (strno);
  1101.             |
  1102.             eParList : (* parameter list start *)
  1103.               IF parlev < maxParLev - 1 THEN
  1104.                 INC (parlev); lastpar [parlev] := NIL;
  1105.               ELSE
  1106.                 OCS.Mark (229)
  1107.               END
  1108.             |
  1109.             eValPar, eVarPar, eVarArg : (* parameter *)
  1110.               obj := AllocObj ();
  1111.               IF class = eValPar THEN obj.mode := Var
  1112.               ELSIF class = eVarPar THEN obj.mode := Ind
  1113.               ELSE obj.mode := VarArg
  1114.               END;
  1115.               ReadInt (l); obj.typ := struct [l];
  1116.               ReadInt (obj.a0); ReadId (objName);
  1117.               obj.name := InsertName (objName);
  1118.               obj.link := lastpar [parlev]; lastpar [parlev] := obj
  1119.             |
  1120.             eFldList : (* start field list *)
  1121.               IF fldlev < maxParLev - 1 THEN
  1122.                 INC (fldlev); lastfld [fldlev] := NIL;
  1123.               ELSE
  1124.                 OCS.Mark (229);
  1125.               END
  1126.             |
  1127.             eFld :
  1128.               obj := AllocObj ();  obj.mode := Fld; obj.link := NIL;
  1129.               ReadInt (l); obj.typ := struct [l];
  1130.               ReadInt (obj.a0); F.Read (SR, obj.visible);
  1131.               ReadId (objName); obj.name := InsertName (objName);
  1132.               obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
  1133.             |
  1134.             eTProcE : (* exported type-bound procedure *)
  1135.               obj := AllocObj (); obj.mode := TProc;
  1136.               ReadInt (l); typ := struct [l];
  1137.               ReadInt (l); obj.typ := struct [l];
  1138.               ReadInt (obj.a0); ReadId (objName);
  1139.               obj.name := InsertName (objName);
  1140.               obj.a1 := typ.n; obj.visible := Exp;
  1141.               obj.link := reversedList (lastpar [parlev]); DEC (parlev);
  1142.               obj.link.a2 := -1; obj.left := typ.link; typ.link := obj;
  1143.               MakeTProcLabel (typ, obj)
  1144.             |
  1145.             eTProc : (* hidden type-bound procedure *)
  1146.               obj := AllocObj (); obj.mode := TProc; obj.typ := notyp;
  1147.               ReadInt (l); typ := struct [l];
  1148.               ReadInt (obj.a0); ReadId (objName);
  1149.               obj.name := InsertName (objName);
  1150.               obj.a1 := typ.n; obj.visible := NotExp;
  1151.               obj.link := NIL; obj.left := typ.link; typ.link := obj;
  1152.               MakeTProcLabel (typ, obj)
  1153.             |
  1154.             eHPtr : (* hidden pointer field *)
  1155.               obj := AllocObj (); obj.mode := Fld;
  1156.               ReadInt (obj.a0); obj.name := -1; obj.typ := notyp;
  1157.               obj.visible := NotExp; obj.link := NIL;
  1158.               obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
  1159.             |
  1160.             eHProc : (* hidden procedure field *)
  1161.               ReadInt (l);
  1162.             |
  1163.             eFixup : (* fixup pointer typ *)
  1164.               ReadInt (l); typ := struct [l];
  1165.               ReadInt (l);
  1166.               IF typ.BaseTyp = undftyp THEN
  1167.                 typ.BaseTyp := struct [l];
  1168.                 IF typ.BaseTyp.form = DynArr THEN
  1169.                   typ.size := typ.BaseTyp.size;
  1170.                   MakeTypeLabel (typ)
  1171.                 END
  1172.               END
  1173.             |
  1174.             eMod : (* module anchor *)
  1175.               ReadLInt (k);
  1176.               ReadId (objName); modname := InsertName (objName);
  1177.               IF (modname = InsertName (ModuleName)) THEN OCS.Mark (49) END;
  1178.               i := 0;
  1179.               WHILE (i < nofGmod) & (modname # GlbMod [i].name) DO
  1180.                 INC (i);
  1181.               END;
  1182.               IF i < nofGmod THEN (* module already present *)
  1183.                 IF k # GlbMod [i].a1 THEN OCS.Mark (150); END;
  1184.                 modobj := GlbMod [i];
  1185.               ELSE
  1186.                 NEW (modobj);
  1187.                 IF nofGmod < maxImps THEN
  1188.                   GlbMod [nofGmod] := modobj; INC (nofGmod);
  1189.                 ELSE
  1190.                   OCS.Mark (227);
  1191.                 END;
  1192.                 modobj.mode := NotYetExp; modobj.name := modname;
  1193.                 modobj.a1 := k; modobj.a0 := nofGmod;
  1194.                 modobj.link := NIL; modobj.visible := NotExp;
  1195.                 IF class = eMod THEN modobj.a2 := 0 ELSE modobj.a2 := 1 END;
  1196.  
  1197.                 MakeInitProcLabel (modname, k, modobj.label);
  1198.                 MakeLabel (modname, InsertName ("VAR"), modobj.varLab);
  1199.                 MakeLabel (modname, InsertName ("CONST"), modobj.constLab);
  1200.                 MakeLabel (modname, InsertName ("GC-OFFSET"), modobj.gcLab);
  1201.                 MakeLabel (modname, InsertName ("END"), modobj.endLab)
  1202.               END;
  1203.               IF nofLmod < maxMod THEN
  1204.                 LocMod [nofLmod] := modobj; INC (nofLmod)
  1205.               ELSE
  1206.                 OCS.Mark (227);
  1207.               END
  1208.             |
  1209.             eExtLib : (* External library, ignore *)
  1210.               ReadId (objName)
  1211.             |
  1212.           ELSE
  1213.             OCS.Mark (1005); OCS.Mark (class)
  1214.           END; (* CASE class *)
  1215.         END; (* LOOP *)
  1216.         Insert (alias, obj, Mod); modobj := obj (Module);
  1217.         modobj.link := LocMod [0].link; modobj.a0 := LocMod [0].a0;
  1218.         modobj.typ := notyp; LocMod [0].visible := Exp;
  1219.         modobj.visible := NotExp; modobj.label := LocMod [0].label;
  1220.         modobj.varLab := LocMod [0].varLab;
  1221.         modobj.constLab := LocMod [0].constLab;
  1222.         modobj.gcLab := LocMod [0].gcLab;
  1223.         modobj.endLab := LocMod [0].endLab
  1224.       ELSE
  1225.         OCS.Mark (157) (* illegal file tag *)
  1226.       END;
  1227.       F.Set (SR, NIL, 0); F.Close (SymFile)
  1228.     ELSE
  1229.       OCS.Mark (152); (* sym file not found *)
  1230.       OCM.SymbolFileName (name, pathName, FALSE);
  1231.       OCM.OutStr1 (OCStrings.OCT1, pathName);
  1232.     END;
  1233.   END (* ELSE *)
  1234.   (* ;OCM.TraceOut (mname, pname); *)
  1235. END Import;
  1236.  
  1237.  
  1238. (*------------------------------------*)
  1239. PROCEDURE ModuleInit * (name : ARRAY OF CHAR; VAR lab : Label);
  1240.  
  1241.   (* CONST pname = "ModuleInit"; *)
  1242.  
  1243.   VAR
  1244.     s : SHORTINT;
  1245.     k : LONGINT;
  1246.     SymFile : F.File;
  1247.     fileName : ARRAY 32 OF CHAR;
  1248.     pathName : ARRAY 256 OF CHAR;
  1249.     modName : Name;
  1250.  
  1251. <*$CopyArrays-*>
  1252. BEGIN (* ModuleInit *)
  1253.   (* OCM.TraceIn (mname, pname); *)
  1254.   lab := NIL; k := 0;
  1255.   IF OCM.FindSymbolFile (name, pathName) THEN
  1256.     SymFile := F.Old (pathName);
  1257.     IF SymFile # NIL THEN
  1258.       F.Set (SR, SymFile, 0); ReadLInt (k);
  1259.       IF k = SFtag THEN
  1260.         F.Read (SR, s);
  1261.         IF s = eMod THEN
  1262.           ReadLInt (k); ReadId (modName);
  1263.           IF modName # name THEN
  1264.             OCM.OutStr1 (OCStrings.OCT2, pathName)
  1265.           END;
  1266.         ELSE
  1267.           OCM.OutStr1 (OCStrings.OCT2, pathName)
  1268.         END
  1269.       ELSE
  1270.         OCM.OutStr1 (OCStrings.OCT2, pathName)
  1271.       END;
  1272.       F.Set (SR, NIL, 0); F.Close (SymFile)
  1273.     ELSE
  1274.       OCM.OutStr1 (OCStrings.OCT3, pathName)
  1275.     END
  1276.   ELSE
  1277.     OCM.SymbolFileName (name, pathName, FALSE);
  1278.     OCM.OutStr1 (OCStrings.OCT1, pathName)
  1279.   END;
  1280.   MakeInitProcLabel (InsertName (name), k, lab)
  1281.   (* ;OCM.TraceOut (mname, pname); *)
  1282. END ModuleInit;
  1283.  
  1284.  
  1285. (*--- EXPORT ---------------------------------*)
  1286.  
  1287. (*------------------------------------*)
  1288. PROCEDURE WriteInt(i: LONGINT);
  1289. (*
  1290.   Writes integers written in a compacted form. Taken from J. Templ.
  1291.   SPARC-Oberon. User's Guide and Implementation. Computersysteme ETH
  1292.   Zürich, Technical Report No. 133, June 1990.
  1293. *)
  1294. BEGIN
  1295.   WHILE (i < -64) OR (i > 63) DO
  1296.     F.Write(SR, CHR(i MOD 128 + 128)); i := i DIV 128
  1297.   END;
  1298.   F.Write(SR, CHR(i MOD 128))
  1299. END WriteInt;
  1300.  
  1301. (*------------------------------------*)
  1302. PROCEDURE WriteLInt (k : LONGINT);
  1303. BEGIN (* WriteLInt *)
  1304.   F.WriteBytes (SR, k, 4)
  1305. END WriteLInt;
  1306.  
  1307. (*------------------------------------*)
  1308. PROCEDURE WriteId (i : LONGINT);
  1309.  
  1310.   VAR ch : CHAR; lim, bufX : INTEGER; buf : NameBufPtr;
  1311.  
  1312. BEGIN (* WriteId *)
  1313.   buf := nameBuf [i DIV BufSize];
  1314.   bufX := SHORT (i MOD BufSize);
  1315.   REPEAT
  1316.     ch := buf [bufX]; F.Write (SR, ch); INC (bufX)
  1317.   UNTIL ch = 0X;
  1318. END WriteId;
  1319.  
  1320.  
  1321. (*------------------------------------*)
  1322. PROCEDURE WriteLabel ( label : Label );
  1323.  
  1324.   VAR i : LONGINT; ch : CHAR;
  1325.  
  1326. BEGIN (* WriteLabel *)
  1327.   i := 0;
  1328.   REPEAT
  1329.     ch := label [i]; F.Write (SR, ch); INC (i)
  1330.   UNTIL ch = 0X;
  1331. END WriteLabel;
  1332.  
  1333. (*------------------------------------*)
  1334. PROCEDURE^ OutStr (typ : Struct);
  1335.  
  1336. (*------------------------------------*)
  1337. PROCEDURE OutPars (par : Object; mode : INTEGER);
  1338.  
  1339.   (* CONST name = "OutPars"; *)
  1340.  
  1341. BEGIN (* OutPars *)
  1342.   (*OCM.TraceIn (mname, name);*)
  1343.   F.Write (SR, eParList);
  1344.   WHILE (par # NIL) & ((par.mode <= Ind) & (par.a0 >= 0)) DO
  1345.     OutStr (par.typ);
  1346.     IF par.mode = Var THEN F.Write (SR, eValPar)
  1347.     ELSIF par.mode = Ind THEN F.Write (SR, eVarPar)
  1348.     ELSE F.Write (SR, eVarArg)
  1349.     END;
  1350.     WriteInt (par.typ.ref);
  1351.     IF mode IN {LibCall, AProc} THEN WriteInt (par.a0)
  1352.     ELSE WriteInt (0)
  1353.     END;
  1354.     WriteId (par.name);
  1355.     par := par.link
  1356.   END;
  1357.   (*;OCM.TraceOut (mname, name);*)
  1358. END OutPars;
  1359.  
  1360. (*------------------------------------*)
  1361. PROCEDURE OutFlds (fld : Object; adr : LONGINT; visible : BOOLEAN);
  1362.   (* CONST name = "OutFlds"; *)
  1363.  
  1364. BEGIN (* OutFlds *)
  1365.   (*OCM.TraceIn (mname, name);*)
  1366.   IF visible THEN F.Write (SR, eFldList) END;
  1367.   WHILE fld # NIL DO
  1368.     IF fld.mode = Fld THEN
  1369.       IF visible & (fld.visible # NotExp) THEN
  1370.         OutStr (fld.typ); F.Write (SR, eFld); WriteInt (fld.typ.ref);
  1371.         WriteInt (fld.a0); F.Write (SR, fld.visible); WriteId (fld.name)
  1372.       ELSIF fld.typ.form = Record THEN
  1373.         OutFlds (fld.typ.link, fld.a0 + adr, FALSE)
  1374.       ELSIF
  1375.         ((fld.typ.form = Pointer) & (fld.typ.sysflg = OberonFlag))
  1376.         OR (fld.name < 0)
  1377.       THEN
  1378.         F.Write (SR, eHPtr); WriteInt (fld.a0 + adr)
  1379.       END
  1380.     END;
  1381.     fld := fld.left
  1382.   END;
  1383.   (*;OCM.TraceOut (mname, name);*)
  1384. END OutFlds;
  1385.  
  1386. (*------------------------------------*)
  1387. PROCEDURE OutProcs (ref : INTEGER; fld : Object);
  1388.  
  1389.   (* CONST name = "OutProcs"; *)
  1390.  
  1391. BEGIN (* OutProcs *)
  1392.   (*OCM.TraceIn (mname, name);*)
  1393.   WHILE fld # NIL DO
  1394.     IF fld.mode = TProc THEN
  1395.       IF fld.visible = Exp THEN
  1396.         OutStr (fld.typ); OutPars (fld.link, ProcTyp);
  1397.         F.Write (SR, eTProcE); WriteInt (ref); WriteInt (fld.typ.ref);
  1398.         WriteInt (fld.a0); WriteId (fld.name)
  1399.       ELSE
  1400.         F.Write (SR, eTProc); WriteInt (ref); WriteInt (fld.a0);
  1401.         WriteId (fld.name)
  1402.       END
  1403.     END;
  1404.     fld := fld.left
  1405.   END; (* WHILE *)
  1406.   (*;OCM.TraceOut (mname, name);*)
  1407. END OutProcs;
  1408.  
  1409. (*------------------------------------*)
  1410. PROCEDURE OutMod (VAR m : INTEGER);
  1411.  
  1412.   (* CONST name = "OutMod"; *)
  1413.  
  1414.   VAR em : INTEGER; mod : Module;
  1415.  
  1416. BEGIN (* OutMod *)
  1417.   (*OCM.TraceIn (mname, name);*)
  1418.   mod := GlbMod [m - 1]; em := mod.mode;
  1419.   IF em = NotYetExp THEN
  1420.     GlbMod [m - 1].mode := nofExp; m := nofExp; INC (nofExp);
  1421.     F.Write (SR, eMod); WriteLInt (mod.a1); WriteId (mod.name);
  1422.   ELSE
  1423.     m := em;
  1424.   END
  1425.   (*;OCM.TraceOut (mname, name);*)
  1426. END OutMod;
  1427.  
  1428. (*------------------------------------*)
  1429. PROCEDURE OutStr (typ : Struct);
  1430.  
  1431.   (* CONST name = "OutStr"; *)
  1432.  
  1433.   VAR m, r : INTEGER; btyp : Struct;
  1434.  
  1435. BEGIN (* OutStr *)
  1436.   (*OCM.TraceIn (mname, name);*)
  1437.   IF typ.ref = NotYetExp THEN (* type not yet exported *)
  1438.     m := typ.mno; btyp := typ.BaseTyp;
  1439.     IF m > 0 THEN OutMod (m) END;
  1440.     CASE typ.form OF
  1441.       Undef .. NoTyp :
  1442.       |
  1443.       Pointer :
  1444.         F.Write (SR, ePointer);
  1445.         IF btyp.ref > 0 THEN
  1446.           WriteInt (btyp.ref);
  1447.         ELSE
  1448.           F.Write (SR, eUndef);
  1449.           IF udpinx < maxUDP THEN
  1450.             undPtr [udpinx] := typ; INC (udpinx);
  1451.           ELSE
  1452.             OCS.Mark (224);
  1453.           END
  1454.         END;
  1455.         WriteInt (m); WriteInt (typ.sysflg); WriteInt (typ.adr)
  1456.       |
  1457.       ProcTyp :
  1458.         OutStr (btyp); OutPars (typ.link, ProcTyp);
  1459.         F.Write (SR, eProcTyp); WriteInt (btyp.ref); WriteInt (m);
  1460.       |
  1461.       Array :
  1462.         OutStr (btyp);
  1463.         F.Write (SR, eArray); WriteInt (btyp.ref); WriteInt (m);
  1464.         WriteInt (typ.size); WriteInt (typ.adr); WriteInt (typ.n);
  1465.       |
  1466.       DynArr :
  1467.         OutStr (btyp);
  1468.         F.Write (SR, eDynArr); WriteInt (btyp.ref); WriteInt (m);
  1469.         WriteInt (typ.size); WriteInt (typ.adr);
  1470.       |
  1471.       Record :
  1472.         IF btyp = NIL THEN r := NoTyp
  1473.         ELSE OutStr (btyp); r := btyp.ref
  1474.         END;
  1475.         OutFlds (typ.link, 0, TRUE);
  1476.         F.Write (SR, eRecord);
  1477.         WriteInt (r); WriteInt (m); WriteInt (typ.size);
  1478.         WriteInt (typ.sysflg); WriteInt (typ.adr);
  1479.       |
  1480.     ELSE
  1481.       OCS.Mark (1006); OCS.Mark (typ.form)
  1482.     END; (* CASE typ.form *)
  1483.     typ.ref := strno; INC (strno);
  1484.     IF strno > maxStr THEN OCS.Mark (228) END;
  1485.     IF typ.strobj # NIL THEN
  1486.       IF typ.strobj.visible = Exp THEN F.Write (SR, eTypE)
  1487.       ELSE F.Write (SR, eTyp);
  1488.       END;
  1489.       WriteInt (strno-1); WriteInt (m); WriteId (typ.strobj.name);
  1490.       IF (typ.form = Record)  & (typ.sysflg = OberonFlag) THEN
  1491.         OutProcs (strno-1, typ.link)
  1492.       END
  1493.     END
  1494.   END; (* IF *)
  1495.   (*;OCM.TraceOut (mname, name);*)
  1496. END OutStr;
  1497.  
  1498. (*------------------------------------*)
  1499. PROCEDURE OutObj (obj : Object);
  1500.  
  1501.   (* CONST name = "OutObj"; *)
  1502.  
  1503.   VAR f, m : INTEGER;
  1504.  
  1505. BEGIN (* OutObj *)
  1506.   (*OCM.TraceIn (mname, name);*)
  1507.   IF obj # NIL THEN
  1508.     IF obj.visible # NotExp THEN
  1509.       IF obj.mode = Con THEN
  1510.         OutStr (obj.typ); F.Write (SR, eCon);
  1511.         f := obj.typ.form;
  1512.         IF f = Pointer THEN WriteInt (obj.typ.ref)
  1513.         ELSE WriteInt (f)
  1514.         END;
  1515.         CASE f OF
  1516.           Undef :
  1517.           |
  1518.           Byte, Bool, Char, SInt, BSet, Int, WSet,
  1519.           Word, LInt, Real, LReal, Set, Longword :
  1520.             WriteInt (obj.a0)
  1521.           |
  1522.           (*LReal : WriteInt (obj.a0); WriteInt (obj.a1);
  1523.           |*)
  1524.           String :
  1525.             IF obj.a1 <= 2 THEN
  1526.               WriteInt (-1); WriteInt (obj.a1); WriteInt (obj.a2)
  1527.             ELSE
  1528.               WriteInt (obj.a0); WriteInt (obj.a1);
  1529.             END
  1530.           |
  1531.           NilTyp :
  1532.           |
  1533.           AdrTyp, BPtrTyp, Pointer, ProcTyp :
  1534.             (* This is all VERY dodgy, but ... *)
  1535.             WriteInt (obj.a0);
  1536.           |
  1537.         ELSE
  1538.           OCS.Mark (1007); OCS.Mark (f)
  1539.         END; (* CASE f *)
  1540.         WriteId (obj.name);
  1541.       ELSIF obj.mode = Typ THEN
  1542.         OutStr (obj.typ);
  1543.         IF (obj.typ.strobj # obj) & (obj.typ.strobj # NIL) THEN
  1544.           F.Write (SR, eTypE); WriteInt (obj.typ.ref);
  1545.           WriteInt (0);(*<- module no *) WriteId (obj.name);
  1546.         END; (* IF *)
  1547.       ELSIF obj.mode = Var THEN
  1548.         OutStr (obj.typ); F.Write (SR, eVar);
  1549.         WriteInt (obj.typ.ref); WriteInt (obj.a0);
  1550.         F.Write (SR, obj.visible); WriteId (obj.name)
  1551.       ELSIF obj.mode = XProc THEN
  1552.         OutStr (obj.typ); OutPars (obj.link, XProc);
  1553.         F.Write (SR, eXProc); WriteInt (obj.typ.ref); WriteId (obj.name);
  1554.       ELSIF obj.mode IN {M2Proc, CProc, AProc} THEN
  1555.         OutStr (obj.typ); OutPars (obj.link, obj.mode);
  1556.         IF obj.mode = M2Proc THEN F.Write (SR, eM2Proc)
  1557.         ELSIF obj.mode = CProc THEN F.Write (SR, eCProc)
  1558.         ELSE F.Write (SR, eAProc)
  1559.         END;
  1560.         WriteInt (obj.typ.ref); WriteLabel (obj.label);
  1561.         WriteId (obj.name);
  1562.       ELSIF obj.mode = LibCall THEN
  1563.         OutStr (obj.typ); OutPars (obj.link, LibCall);
  1564.         F.Write (SR, eLibCall); WriteInt (obj.typ.ref);
  1565.         WriteInt (obj.a0); WriteInt (obj.a1); WriteId (obj.name);
  1566.       END
  1567.     END; (* IF *)
  1568.     OutObj (obj.left); OutObj (obj.right)
  1569.   END; (* IF *)
  1570.   (*;OCM.TraceOut (mname, name);*)
  1571. END OutObj;
  1572.  
  1573. (*------------------------------------*)
  1574. PROCEDURE OutImports ();
  1575.  
  1576.   (* CONST name = "OutImports"; *)
  1577.  
  1578.   VAR m : INTEGER; mod : Module;
  1579.  
  1580. BEGIN (* OutImports *)
  1581.   (*OCM.TraceIn (mname, name);*)
  1582.   FOR m := 0 TO (nofGmod - 1) DO
  1583.     mod := GlbMod [m];
  1584.     IF (mod.visible = Exp) & (mod.mode = NotYetExp) THEN
  1585.       mod.mode := nofExp; INC (nofExp);
  1586.       F.Write (SR, eMod); WriteLInt (mod.a1); WriteId (mod.name);
  1587.     END
  1588.   END;
  1589.   FOR m := 0 TO (nofExtLib - 1) DO
  1590.     F.Write (SR, eExtLib); WriteId (extLib [m])
  1591.   END;
  1592.   (*;OCM.TraceOut (mname, name);*)
  1593. END OutImports;
  1594.  
  1595. (*------------------------------------*)
  1596. PROCEDURE Export * (
  1597.   name : ARRAY OF CHAR;
  1598.   VAR newSF : BOOLEAN; VAR key : LONGINT);
  1599.  
  1600.   (* CONST name = "Export"; *)
  1601.  
  1602.   VAR
  1603.     i : INTEGER;
  1604.     ch0, ch1 : CHAR;
  1605.     oldkey : LONGINT;
  1606.     typ : Struct;
  1607.     oldFile, newFile : F.File;
  1608.     res : LONGINT;
  1609.     oldSR : F.Rider;
  1610.     equal : BOOLEAN;
  1611.     pathName, oldPathName : ARRAY 256 OF CHAR;
  1612.  
  1613. <*$CopyArrays-*>
  1614. BEGIN (* Export *)
  1615.   (* OCM.TraceIn (mname, name); *)
  1616.   OCM.SymbolFileName (name, pathName, TRUE);
  1617.   newFile := F.New (pathName);
  1618.   IF newFile # NIL THEN
  1619.     F.Set (SR, newFile, 0);
  1620.     WriteLInt (SFtag);
  1621.     F.Write (SR, eMod); WriteLInt (key); WriteId (InsertName (ModuleName));
  1622.  
  1623.     strno := firstStr; nofExp := 1;
  1624.     OutImports ();
  1625.     OutObj (topScope.link);
  1626.  
  1627.     i := 0;
  1628.     WHILE i < udpinx DO
  1629.       typ := undPtr [i]; OutStr (typ.BaseTyp); undPtr [i] := NIL; INC (i);
  1630.       F.Write (SR, eFixup);
  1631.       WriteInt (typ.ref); WriteInt (typ.BaseTyp.ref)
  1632.     END;
  1633.  
  1634.     IF OCM.Force OR ~OCS.scanerr THEN
  1635.       IF OCM.FindSymbolFile (name, oldPathName) THEN
  1636.         oldFile := F.Old (oldPathName)
  1637.       ELSE
  1638.         oldFile := NIL
  1639.       END;
  1640.       IF oldFile # NIL THEN
  1641.         F.Set (oldSR, oldFile, 5); F.ReadBytes (oldSR, oldkey, 4);
  1642.         F.Set (SR, newFile, 9);
  1643.         REPEAT
  1644.           F.Read (oldSR, ch0); F.Read(SR, ch1);
  1645.         UNTIL (ch0 # ch1) OR SR.eof;
  1646.         equal := oldSR.eof & SR.eof;
  1647.         F.Set (oldSR, NIL, 0); F.Close (oldFile);
  1648.         F.Set (SR, NIL, 0);
  1649.         IF equal THEN
  1650.           newSF := FALSE; key := oldkey; F.Purge (newFile);
  1651.         ELSIF newSF THEN
  1652.           F.Register (newFile);
  1653.         ELSE
  1654.           OCS.Mark (155); F.Purge (newFile);
  1655.           OCM.OutStr1 (OCStrings.OCT4, oldPathName)
  1656.         END
  1657.       ELSE
  1658.         F.Set (SR, NIL, 0); F.Register (newFile); newSF := TRUE
  1659.       END;
  1660.  
  1661.       IF newSF THEN
  1662.         IF OCM.Verbose THEN OCM.OutStr1 (OCStrings.OCT5, pathName) END;
  1663.         OCM.MakeIcon (pathName, OCM.iconSym)
  1664.       END;
  1665.  
  1666.       MakeInitProcLabel (InsertName (ModuleName), key, InitLabel);
  1667.       MakeLabel (InsertName (ModuleName), InsertName ("END"), EndLabel)
  1668.     ELSE
  1669.       F.Set (SR, NIL, 0); F.Purge (newFile); newSF := FALSE
  1670.     END;
  1671.  
  1672.   ELSE
  1673.     OCM.OutStr1 (OCStrings.OCT3, pathName);
  1674.     OCS.Mark (153)
  1675.   END;
  1676.   (* ;OCM.TraceOut (mname, name); *)
  1677. END Export;
  1678.  
  1679. (*--- INITIALISATION ---------------------------------*)
  1680.  
  1681. (*------------------------------------*)
  1682. PROCEDURE InitStruct (VAR typ : Struct; f : INTEGER);
  1683.  
  1684. BEGIN (* InitStruct *)
  1685.   typ := AllocStruct (); typ.form := f; typ.ref := f; typ.size := 1;
  1686.   typ.sysflg := OberonFlag
  1687. END InitStruct;
  1688.  
  1689. (*------------------------------------*)
  1690. PROCEDURE EnterConst (name : ARRAY OF CHAR; value : INTEGER);
  1691.  
  1692.   VAR obj : Object;
  1693.  
  1694. <*$CopyArrays-*>
  1695. BEGIN (* EnterConst *)
  1696.   Insert (name, obj, Con); obj.typ := booltyp; obj.a0 := value;
  1697. END EnterConst;
  1698.  
  1699. (*------------------------------------*)
  1700. PROCEDURE EnterTyp (
  1701.   name : ARRAY OF CHAR; form, size : INTEGER; VAR res: Struct);
  1702.  
  1703.   VAR obj : Object; typ : Struct;
  1704.  
  1705. <*$CopyArrays-*>
  1706. BEGIN (* EnterTyp *)
  1707.   Insert (name, obj, Typ); typ := AllocStruct ();
  1708.   obj.typ := typ; obj.visible := Exp;
  1709.   typ.form := form; typ.strobj := obj; typ.size := size;
  1710.   typ.sysflg := OberonFlag; typ.ref := form; res := typ;
  1711. END EnterTyp;
  1712.  
  1713. (*------------------------------------*)
  1714. PROCEDURE EnterProc (name : ARRAY OF CHAR; num : INTEGER);
  1715.  
  1716.   VAR obj : Object;
  1717.  
  1718. <*$CopyArrays-*>
  1719. BEGIN (* EnterProc *)
  1720.   Insert (name, obj, SProc); obj.typ := notyp; obj.a0 := num
  1721. END EnterProc;
  1722.  
  1723. BEGIN (* OCT *)
  1724.   nameSize := 0; topScope := NIL;
  1725.   InitStruct (undftyp, Undef); InitStruct (notyp, NoTyp);
  1726.   InitStruct (stringtyp, String); InitStruct (niltyp, NilTyp);
  1727.   OpenScope (0);
  1728.  
  1729.   (* initialisation of module SYSTEM *)
  1730.  
  1731.   EnterTyp ("BYTESET", BSet, OCM.BSetSize, bsettyp);
  1732.   EnterTyp ("WORDSET", WSet, OCM.WSetSize, wsettyp);
  1733.   EnterTyp ("PTR", PtrTyp, OCM.PtrSize, ptrtyp);
  1734.   EnterTyp ("BPTR", BPtrTyp, OCM.PtrSize, bptrtyp);
  1735.   bptrtyp.sysflg := BCPLFlag;
  1736.   EnterTyp ("ADDRESS", AdrTyp, OCM.PtrSize, adrtyp);
  1737.   adrtyp.sysflg := CFlag;
  1738.   EnterTyp ("BYTE", Byte, OCM.ByteSize, bytetyp);
  1739.   EnterTyp ("WORD", Word, 2, wordtyp);
  1740.   EnterTyp ("LONGWORD", Longword, 4, lwordtyp);
  1741.   EnterTyp ("TYPETAG", TagTyp, 4, tagtyp);
  1742.  
  1743.   EnterProc ("ADR", pADR);         EnterProc ("AND", pAND);
  1744.   EnterProc ("BIT", pBIT);         EnterProc ("CC", pCC);
  1745.   EnterProc ("DISPOSE", pDISPOSE); EnterProc ("GET", pGET);
  1746.   EnterProc ("GETREG", pGETREG);   EnterProc ("INLINE", pINLINE);
  1747.   EnterProc ("LOR", pOR);          EnterProc ("LSH", pLSH);
  1748.   EnterProc ("MOVE", pMOVE);       EnterProc ("NEW", pSYSNEW);
  1749.   EnterProc ("PUT", pPUT);         EnterProc ("ROT", pROT);
  1750.   EnterProc ("STRLEN", pSTRLEN);   EnterProc ("PUTREG", pPUTREG);
  1751.   EnterProc ("VAL", pVAL);         EnterProc ("XOR", pXOR);
  1752.   EnterProc ("SETREG", pSETREG);   EnterProc ("REG", pREG);
  1753.   EnterProc ("TAG", pTAG);
  1754.  
  1755.   syslink := topScope.link; universe := topScope; topScope.link := NIL;
  1756.  
  1757.   (* initialisation of predeclared types and procedures *)
  1758.  
  1759.   EnterTyp ("CHAR", Char, OCM.CharSize, chartyp);
  1760.   EnterTyp ("SET", Set, OCM.SetSize, settyp);
  1761.   EnterTyp ("REAL", Real, OCM.RealSize, realtyp);
  1762.   EnterTyp ("INTEGER", Int, OCM.IntSize, inttyp);
  1763.   EnterTyp ("LONGINT", LInt, OCM.LIntSize, linttyp);
  1764.   EnterTyp ("LONGREAL", LReal, OCM.LRealSize, lrltyp);
  1765.   EnterTyp ("SHORTINT", SInt, OCM.SIntSize, sinttyp);
  1766.   EnterTyp ("BOOLEAN", Bool, OCM.BoolSize, booltyp);
  1767.  
  1768.   EnterConst ("FALSE", 0);  EnterConst ("TRUE", 1);
  1769.  
  1770.   EnterProc ("INC", pINC);     EnterProc ("DEC", pDEC);
  1771.   EnterProc ("HALT", pHALT);   EnterProc ("NEW", pNEW);
  1772.   EnterProc ("ABS", pABS);     EnterProc ("CAP", pCAP);
  1773.   EnterProc ("ORD", pORD);     EnterProc ("ENTIER", pENTIER);
  1774.   EnterProc ("ODD", pODD);     EnterProc ("MIN", pMIN);
  1775.   EnterProc ("MAX", pMAX);     EnterProc ("CHR", pCHR);
  1776.   EnterProc ("SHORT", pSHORT); EnterProc ("LONG", pLONG);
  1777.   EnterProc ("INCL", pINCL);   EnterProc ("EXCL", pEXCL);
  1778.   EnterProc ("LEN", pLEN);     EnterProc ("ASH", pASH);
  1779.   EnterProc ("COPY", pCOPY);   EnterProc ("SIZE", pSIZE);
  1780.   EnterProc ("ASSERT", pASSERT);
  1781.  
  1782.   (* Save hash table for names so we can restore it *)
  1783.  
  1784.   nameOrg := nameX; backupTab := nameTab;
  1785.  
  1786.   (* initialisation of labels *)
  1787.  
  1788.   NEW (VarLabel, 64);
  1789.   NEW (ConstLabel, 64);
  1790.   NEW (InitLabel, 64);
  1791.   NEW (EndLabel, 64);
  1792.   NEW (GCLabel, 64);
  1793.   NEW (PointerDesc, 16); COPY ("Kernel_0T", PointerDesc^)
  1794. END OCT.
  1795.  
  1796. (***************************************************************************
  1797.  
  1798.   $Log: OCT.mod $
  1799.   Revision 5.12  1995/01/26  00:17:17  fjc
  1800.   - Release 1.5
  1801.  
  1802.   Revision 5.11  1995/01/09  13:50:25  fjc
  1803.   - Added call to OCM.MakeIcon().
  1804.   - Changed console output depending on OCM.Verbose.
  1805.  
  1806.   Revision 5.10  1995/01/05  11:29:50  fjc
  1807.   - Changed to force output of symbol file if OCM.Force is TRUE.
  1808.  
  1809.   Revision 5.9  1995/01/03  21:13:22  fjc
  1810.   - Changed OCG to OCM.
  1811.   - Changed to use catalogs:
  1812.     - Uses OCM for console I/O instead of Out.
  1813.     - Gets text from OCStrings instead of hard-coding it.
  1814.  
  1815.   Revision 5.7  1994/12/16  17:05:39  fjc
  1816.   - Moved code for constructing symbol file names and
  1817.     searching for symbol files to module OCG.
  1818.   - Renamed the Symbol type as Label and renamed associated
  1819.     variables, record fields and procedures.
  1820.   - Changed the way linker labels are generated.
  1821.  
  1822.   Revision 5.6  1994/11/13  11:20:48  fjc
  1823.   - Added CC to module SYSTEM.
  1824.  
  1825.   Revision 5.5  1994/10/23  15:44:27  fjc
  1826.   - Changed all references to OberonSys.lib to module Kernel.
  1827.   - Removed obsolete SYSTEM procedures: GC, RC, ARGLEN, ARGS,
  1828.     SIZETAG, SETCLEANUP, BIND, GETNAME and NEWTAG.
  1829.   - Increased # of modules that can be imported.
  1830.   - Renamed SYSTEM.CPTR to SYSTEM.ADDRESS, CPtrTyp to AdrTyp,
  1831.     and cptrtyp to adrtyp.
  1832.   - Uses new interface to module Strings, and module
  1833.     Conversions.
  1834.   - Added ModuleInit().
  1835.  
  1836.   Revision 5.4  1994/09/25  17:37:28  fjc
  1837.   - Removed code dealing with CPOINTERS, BPOINTERS and
  1838.     LIBCALLS.
  1839.   - Added code for new system flags and procedure types.
  1840.   - Implemented new symbol-file format.
  1841.  
  1842.   Revision 5.3  1994/09/19  23:10:05  fjc
  1843.   - Re-implemented Amiga library calls
  1844.  
  1845.   Revision 5.2  1994/09/15  10:15:51  fjc
  1846.   - Replaced switches with pragmas.
  1847.  
  1848.   Revision 5.1  1994/09/03  19:29:08  fjc
  1849.   - Bumped version number
  1850.  
  1851. ***************************************************************************)
  1852.