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