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 / OCC.mod < prev    next >
Encoding:
Text File  |  1995-01-26  |  68.0 KB  |  2,366 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCC.mod $
  4.   Description: Code generation
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.11 $
  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 OCC;
  23.  
  24. IMPORT SYS := SYSTEM, Files, Str := Strings, OCM, OCS, OCT;
  25.  
  26.  
  27. (* --- Exported declarations ------------------------------------------ *)
  28.  
  29.  
  30. CONST
  31.  
  32.   (* Condition codes *)
  33.  
  34.    T * =  0;  F * =  1; HI * =  2; LS * =  3; CC * =  4; CS * =  5;
  35.   NE * =  6; EQ * =  7; VC * =  8; VS * =  9; PL * = 10; MI * = 11;
  36.   GE * = 12; LT * = 13; GT * = 14; LE * = 15;
  37.  
  38.   (* Instruction mnemonics *)
  39.  
  40.   Bcc  * = 6000H;  DBcc * = 50C8H;  Scc * = 50C0H;
  41.  
  42.   ADD  * = -3000H; ADDI * = 0600H;  ADDQ * = 5000H;  AND  * = -4000H;
  43.   ANDI * = 0200H;  ASL  * = -1F00H; ASR  * = -2000H; BCC  * = 6400H;
  44.   BCLR * = 0080H;  BCS  * = 6500H;  BEQ  * = 6700H;  BGE  * = 6C00H;
  45.   BGT  * = 6E00H;  BHI  * = 6200H;  BLE  * = 6F00H;  BLS  * = 6300H;
  46.   BLT  * = 6D00H;  BMI  * = 6B00H;  BNE  * = 6600H;  BPL  * = 6A00H;
  47.   BRA  * = 6000H;  BSET * = 00C0H;  BSR  * = 6100H;  BTST * = 0000H;
  48.   BVC  * = 6800H;  BVS  * = 6900H;  CHK  * = 4180H;  CLR  * = 4200H;
  49.   CMP  * = -5000H; CMPI * = 0C00H;  DBCC * = 54C8H;  DBCS * = 55C8H;
  50.   DBEQ * = 57C8H;  DBF  * = 51C8H;  DBGE * = 5CC8H;  DBGT * = 5EC8H;
  51.   DBHI * = 52C8H;  DBLE * = 5FC8H;  DBLS * = 53C8H;  DBLT * = 5DC8H;
  52.   DBMI * = 5BC8H;  DBNE * = 56C8H;  DBPL * = 5AC8H;  DBRA * = 50C8H;
  53.   DBT  * = 50C8H;  DBVC * = 58C8H;  DBVS * = 59C8H;  DIVS * = -7E40H;
  54.   EOR  * = -4F00H; EORI * = 0A00H;  EXG  * = -3EC0H; EXTW * = 4880H;
  55.   EXTL * = 48C0H;  JMP  * = 4EC0H;  JSR  * = 4E80H;  LEA  * = 41C0H;
  56.   LINK * = 4E50H;  LSL  * = -1EF8H; LSR  * = -1FF8H; MOVEQ* = 7000H;
  57.   MULS * = -3E40H; NEG  * = 4400H;  NOP  * = 4E71H;  NOT  * = 4600H;
  58.   iOR  * = -8000H; ORI  * = 0000H;  PEA  * = 4840H;  ROL  * = -1EE8H;
  59.   ROR  * = -1FE8H; RTE  * = 4E73H;  RTS  * = 4E75H;  SCS  * = 55C0H;
  60.   SEQ  * = 57C0H;  SF   * = 51C0H;  SGE  * = 5CC0H;  SGT  * = 5EC0H;
  61.   SHI  * = 52C0H;  SLE  * = 5FC0H;  SLS  * = 53C0H;  SLT  * = 5DC0H;
  62.   SMI  * = 5BC0H;  SNE  * = 56C0H;  SPL  * = 5AC0H;  SRA  * = 50C0H;
  63.   ST   * = 50C0H;  SVC  * = 58C0H;  SVS  * = 59C0H;  SUB  * = -7000H;
  64.   SUBI * = 0400H;  SUBQ * = 5100H;  SWAP * = 4840H;  TRAP * = 4E40H;
  65.   TRAPV* = 4E76H;  TST  * = 4A00H;  UNLK * = 4E58H;
  66.  
  67.   (* Trap numbers *)
  68.  
  69.   OverflowCheck * = -1;
  70.   IndexCheck *    = 0;
  71.   TypeCheck *     = 1;
  72.   NilCheck *      = 2;
  73.   CaseCheck *     = 3;
  74.   ReturnCheck *   = 4;
  75.   StackCheck *    = 5;
  76.  
  77.   (* CPU Registers *)
  78.  
  79.   D0 = 0; D1 = 1; D2 = 2; D7 = 7; A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  80.   A6 = 14; A7 = 15; BP = A4 - 8; FP = A5 - 8; SP = A7 - 8;
  81.   DataRegs = {D0 .. D7};
  82.   AdrRegs = {A0 .. A7};
  83.  
  84.   (* Register masks for SaveRegisters () *)
  85.  
  86.   ScratchRegs * = {D0, D1, A0, A1};
  87.   AllRegs * = {D0 .. A3};
  88.  
  89.   (* Procedures in Kernel *)
  90.  
  91.   kHalt *      = 0;
  92.   kNewRecord * = 1;
  93.   kNewArray *  = 2;
  94.   kNewSysBlk * = 3;
  95.   kDispose *   = 4;
  96.   kInitGC *    = 5;
  97.   kMove *      = 6;
  98.   kStackChk *  = 7;
  99.   kMul32 *     = 8;
  100.   kDiv32 *     = 9;
  101.   kSPFix *     = 10;
  102.   kSPFlt *     = 11;
  103.   kSPCmp *     = 12;
  104.   kSPTst *     = 13;
  105.   kSPNeg *     = 14;
  106.   kSPAdd *     = 15;
  107.   kSPSub *     = 16;
  108.   kSPMul *     = 17;
  109.   kSPDiv *     = 18;
  110.   kSPAbs *     = 19;
  111.   kInit *      = 20;
  112.   kEnd *       = 21;
  113.   numKProcs    = 22;
  114.  
  115. VAR
  116.   pc *, level * : INTEGER;
  117.   wasderef * : OCT.Object;
  118.   RegSet * : SET;
  119.  
  120.  
  121. (* --- Local declarations ----------------------------------------------- *)
  122.  
  123. CONST
  124.   MaxBufferSize  = 32000;
  125.   MaxCodeLength  = MaxBufferSize DIV SIZE (INTEGER);
  126.   MaxConstLength = MaxBufferSize DIV SIZE (CHAR);
  127.   CodeLength     = MaxCodeLength;
  128.   ConstLength    = MaxConstLength;
  129.   NumTypes       = 64;
  130.  
  131.   (* Object file hunk types *)
  132.   hunkUnit    =  999; hunkName    = 1000; hunkCode    = 1001;
  133.   hunkData    = 1002; hunkBSS     = 1003; hunkReloc32 = 1004;
  134.   hunkExt     = 1007; hunkSymbol  = 1008; hunkEnd     = 1010;
  135.  
  136.   (* External symbol types *)
  137.   extDef   =   1; extRef32 = 129; extRef16 = 131; extSymb = 0;
  138.  
  139.   (* Addressing mode flag values *)
  140.  
  141.   DReg   = 0; (* Data Register *)
  142.   ARDir  = 1; (* Address Register Direct *)
  143.   ARInd  = 2; (* Address Register Indirect *)
  144.   ARPost = 3; (* Address Register with Post-Increment *)
  145.   ARPre  = 4; (* Address Register with Pre-Decrement *)
  146.   ARDisp = 5; (* Address Register with Displacement *)
  147.   ARDisX = 6; (* Address Register with Disp. & Index *)
  148.   Mode7  = 7;
  149.   AbsW   = 0; (* Absolute Short (16-bit Address) *)
  150.   AbsL   = 1; (* Absolute Long (32-bit Address) *)
  151.   PCDisX = 3; (* Program Counter Relative, with Disp. & Index *)
  152.   Imm    = 4; (* Immediate *)
  153.   PCDisp = 5; (* Program Counter Relative, with Displacement *)
  154.  
  155.   B = 1; W = 2; L = 4; (* Size types *)
  156.  
  157.   (* object modes *)
  158.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  159.   RegI = OCM.RegI; RegX = OCM.RegX; Lab = OCM.Lab; LabI = OCM.LabI;
  160.   Abs = OCM.Abs; Con = OCM.Con; Push = OCM.Push; Pop = OCM.Pop;
  161.   Coc = OCM.Coc; Reg = OCM.Reg; Fld = OCM.Fld; Typ = OCM.Typ;
  162.   LProc = OCM.LProc; XProc = OCM.XProc; SProc = OCM.SProc;
  163.   LibCall = OCM.LibCall; TProc = OCM.TProc; Mod = OCM.Mod;
  164.   Head = OCM.Head; RList = OCM.RList; M2Proc = OCM.M2Proc;
  165.   CProc = OCM.CProc; AProc = OCM.AProc;
  166.  
  167.   (* structure forms *)
  168.   Undef = OCT.Undef; Pointer = OCT.Pointer; Array = OCT.Array;
  169.   Record = OCT.Record; ProcTyp = OCT.ProcTyp; PtrTyp = OCT.PtrTyp;
  170.  
  171.   (* System flags *)
  172.  
  173.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  174.   AsmFlag = OCM.AsmFlag;
  175.  
  176. TYPE
  177.  
  178.   CodeHunk = POINTER TO CodeHunkDesc;
  179.   Def = POINTER TO DefDesc;
  180.   Ref = POINTER TO RefDesc;
  181.   Offset = POINTER TO OffsetDesc;
  182.  
  183.   CodeHunkDesc = RECORD
  184.     next   : CodeHunk;
  185.     start,
  186.     length : INTEGER;
  187.     defs   : Def;
  188.     refs   : Ref;
  189.   END; (* CodeHunkDesc *)
  190.  
  191.   DefDesc = RECORD
  192.     next   : Def;
  193.     object : OCT.Object;
  194.     offset : LONGINT;
  195.   END; (* DefDesc *)
  196.  
  197.   RefDesc = RECORD
  198.     next    : Ref;
  199.     size    : INTEGER;
  200.     label   : OCT.Label;
  201.     count   : LONGINT;
  202.     offsets : Offset;
  203.   END; (* RefDesc *)
  204.  
  205.   OffsetDesc = RECORD
  206.     next : Offset;
  207.     n    : LONGINT;
  208.   END; (* OffsetDesc *)
  209.  
  210. VAR
  211.   (* Labels in Module Kernel *)
  212.   kernelLab : ARRAY numKProcs OF OCT.Label;
  213.   i : INTEGER;
  214.  
  215.   FirstCodeHunk, CurrCodeHunk, InitCodeHunk, Prologue : CodeHunk;
  216.   codex, conx, typex, dataCount : INTEGER;
  217.   numPtrs : LONGINT;
  218.   constant : ARRAY ConstLength OF CHAR;
  219.   type : ARRAY NumTypes OF OCT.Struct;
  220.   code : ARRAY CodeLength OF INTEGER;
  221.  
  222. TYPE
  223.  
  224.   Arg = RECORD
  225.     form  : INTEGER;
  226.     data  : LONGINT;
  227.     label : OCT.Label;
  228.   END; (* Arg *)
  229.  
  230. CONST
  231.   (* Arg forms *)
  232.   none = 0; word = 1; long = 2; wordRef = 3; longRef = 4;
  233.  
  234. CONST mname = "OCC";
  235.  
  236. (* --- Procedure declarations ------------------------------------------- *)
  237.  
  238. (*------------------------------------*)
  239. PROCEDURE Init * ();
  240.  
  241.   (* CONST pname = "Init"; *)
  242.  
  243. BEGIN (* Init *)
  244.   (* OCM.TraceIn (mname, pname); *)
  245.   pc := 0; level := 0; RegSet := {}; conx := 0; codex := 0; typex := 0;
  246.   OCT.ModuleInit ("Kernel", kernelLab [kInit]);
  247.   (* ;OCM.TraceOut (mname, pname); *)
  248. END Init;
  249.  
  250. (*------------------------------------*)
  251. PROCEDURE Close * ();
  252.  
  253.   VAR i : INTEGER;
  254.  
  255. BEGIN (* Close *)
  256.   FirstCodeHunk := NIL; CurrCodeHunk := NIL; InitCodeHunk := NIL;
  257.   Prologue := NIL;
  258.   i := 0; WHILE i < NumTypes DO type [i] := NIL; INC (i) END
  259. END Close;
  260.  
  261. (*------------------------------------*)
  262. PROCEDURE StartModule* (name : ARRAY OF CHAR);
  263.   VAR i : INTEGER; ch : CHAR;
  264. <*$CopyArrays-*>
  265. BEGIN (* StartModule *)
  266.   i := 0;
  267.   REPEAT
  268.     IF conx >= ConstLength THEN OCS.Mark (230); conx := 0 END;
  269.     ch := name [i]; constant [conx] := ch; INC (i); INC (conx)
  270.   UNTIL ch = 0X;
  271. END StartModule;
  272.  
  273. (*------------------------------------*)
  274. PROCEDURE StartPrologue * ();
  275.  
  276.   (* CONST pname = "StartPrologue"; *)
  277.  
  278.   VAR codeHunk : CodeHunk;
  279.  
  280. BEGIN (* StartPrologue *)
  281.   (* OCM.TraceIn (mname, pname); *)
  282.   NEW (codeHunk);
  283.   FirstCodeHunk := codeHunk; CurrCodeHunk := codeHunk;
  284.   codeHunk.next := NIL; codeHunk.start := codex; codeHunk.length := 0;
  285.   codeHunk.defs := NIL; codeHunk.refs := NIL;
  286.   Prologue := codeHunk
  287.   (* ;OCM.TraceOut (mname, pname); *)
  288. END StartPrologue;
  289.  
  290. (*------------------------------------*)
  291. PROCEDURE StartCodeHunk * (initProc : BOOLEAN);
  292.  
  293.   (* CONST pname = "StartCodeHunk"; *)
  294.  
  295.   VAR codeHunk : CodeHunk;
  296.  
  297. BEGIN (* StartCodeHunk *)
  298.   (* OCM.TraceIn (mname, pname); *)
  299.   NEW (codeHunk);
  300.   IF FirstCodeHunk = NIL THEN
  301.     FirstCodeHunk := codeHunk; CurrCodeHunk := codeHunk
  302.   ELSE
  303.     CurrCodeHunk.next := codeHunk; CurrCodeHunk := codeHunk;
  304.   END; (* ELSE *)
  305.   codeHunk.next := NIL; codeHunk.start := codex; codeHunk.length := 0;
  306.   codeHunk.defs := NIL; codeHunk.refs := NIL;
  307.   IF initProc THEN InitCodeHunk := codeHunk END;
  308.   (* ;OCM.TraceOut (mname, pname); *)
  309. END StartCodeHunk;
  310.  
  311. (*------------------------------------*)
  312. PROCEDURE StartProcedure * (proc : OCT.Object);
  313.  
  314.   (* CONST pname = "StartProcedure"; *)
  315.  
  316.   VAR def : Def;
  317.  
  318. BEGIN (* StartProcedure *)
  319.   (* OCM.TraceIn (mname, pname); *)
  320.   NEW (def);
  321.   def.next := CurrCodeHunk.defs; CurrCodeHunk.defs := def;
  322.   def.object := proc; def.offset := pc - (CurrCodeHunk.start * 2)
  323.   (* ;OCM.TraceOut (mname, pname); *)
  324. END StartProcedure;
  325.  
  326. (*------------------------------------*)
  327. PROCEDURE EndCodeHunk * ();
  328.  
  329.   (* CONST pname = "EndCodeHunk"; *)
  330.  
  331. BEGIN (* EndCodeHunk *)
  332.   (* OCM.TraceIn (mname, pname); *)
  333.   CurrCodeHunk.length := codex - CurrCodeHunk.start;
  334.   (* ;OCM.TraceOut (mname, pname); *)
  335. END EndCodeHunk;
  336.  
  337. (*------------------------------------*)
  338. PROCEDURE AllocString *
  339.   (VAR s : ARRAY OF CHAR; len : LONGINT; VAR x : OCT.Item);
  340.  
  341.   (* CONST pname = "AllocString"; *)
  342.  
  343.   VAR i : INTEGER;
  344.  
  345. BEGIN (* AllocString *)
  346.   (* OCM.TraceIn (mname, pname); *)
  347.   IF len = 0 THEN
  348.     x.lev := 0; x.a0 := -1; x.a1 := 1; x.a2 := 0; x.label := NIL
  349.   ELSIF len = 1 THEN
  350.     x.lev := 0; x.a0 := -1; x.a1 := 2; x.a2 := ORD (s [0]); x.label := NIL
  351.   ELSE
  352.     i := 0;
  353.     IF (conx + len) >= ConstLength THEN OCS.Mark (230); conx := 0 END;
  354.     REPEAT
  355.       constant [conx] := s [i]; INC (i); INC (conx)
  356.     UNTIL i = len + 1;
  357.     x.lev := 0; x.a0 := conx - i; x.a1 := i; x.a2 := 0;
  358.     x.label := OCT.ConstLabel
  359.   END;
  360.   x.obj := NIL
  361.   (* ;OCM.TraceOut (mname, pname); *)
  362. END AllocString;
  363.  
  364. (*------------------------------------*)
  365. PROCEDURE AllocStringFromChar * (VAR x : OCT.Item);
  366.  
  367.   (* CONST pname = "AllocStringFromChar"; *)
  368.  
  369. BEGIN (* AllocStringFromChar *)
  370.   (* OCM.TraceIn (mname, pname); *)
  371.   IF x.a1 > 2 THEN OCS.Mark (212)
  372.   ELSIF x.a0 < 0 THEN
  373.     IF x.a1 = 1 THEN
  374.       IF conx = 0 THEN constant [0] := 0X; conx := 1 END;
  375.       x.a0 := conx - 1; x.label := OCT.ConstLabel
  376.     ELSIF x.a1 = 2 THEN
  377.       IF conx >= ConstLength - 1 THEN OCS.Mark (230); conx := 0 END;
  378.       x.a0 := conx; constant [conx] := CHR (x.a2); INC (conx);
  379.       constant [conx] := 0X; INC (conx); x.label := OCT.ConstLabel
  380.     END;
  381.     IF x.obj # NIL THEN x.obj.a0 := x.a0; x.obj.label := x.label END
  382.   END
  383.   (* ;OCM.TraceOut (mname, pname); *)
  384. END AllocStringFromChar;
  385.  
  386. (*------------------------------------*)
  387. PROCEDURE ConcatString *
  388.   (VAR s : ARRAY OF CHAR; len : LONGINT; VAR x : OCT.Item);
  389.  
  390.   (* CONST pname = "ConcatString"; *)
  391.  
  392.   VAR i : INTEGER; newLen : LONGINT;
  393.  
  394. BEGIN (* ConcatString *)
  395.   (* OCM.TraceIn (mname, pname); *)
  396.   IF len > 0 THEN
  397.     newLen := len + x.a1 - 1;
  398.     IF len + x.a1 = 2 THEN
  399.       x.a1 := 2; x.a2 := ORD (s [0])
  400.     ELSIF x.a1 = 1 THEN
  401.       AllocString (s, len, x)
  402.     ELSE
  403.       IF x.a1 = 2 THEN AllocStringFromChar (x) END;
  404.       i := 0; DEC (conx);
  405.       IF (conx + len) >= ConstLength THEN OCS.Mark (230); conx := 0 END;
  406.       REPEAT
  407.         constant [conx] := s [i]; INC (i); INC (conx)
  408.       UNTIL i = len + 1;
  409.       INC (x.a1, len)
  410.     END
  411.   END
  412.   (* ;OCM.TraceOut (mname, pname); *)
  413. END ConcatString;
  414.  
  415. (*------------------------------------*)
  416. PROCEDURE AllocTypDesc * (typ : OCT.Struct);
  417.  
  418.   (* CONST pname = "AllocTypDesc"; *)
  419.  
  420.   VAR t : INTEGER;
  421.  
  422. BEGIN (* AllocTypDesc *)
  423.   (* OCM.TraceIn (mname, pname); *)
  424.   IF typ.form = Pointer THEN
  425.     t := 0;
  426.     WHILE t < typex DO
  427.       IF (type [t].form = Pointer) & (type [t].size = typ.size) THEN
  428.         typ.adr := t; typ.mno := 0; typ.label := type [t].label;
  429.         RETURN
  430.       END;
  431.       INC (t)
  432.     END
  433.   END;
  434.   IF typex >= NumTypes THEN OCS.Mark (233); typex := 0 END;
  435.   type [typex] := typ; typ.adr := typex; INC (typex);
  436.   typ.mno := 0; OCT.MakeTypeLabel (typ)
  437.   (* ;OCM.TraceOut (mname, pname); *)
  438. END AllocTypDesc;
  439.  
  440. (*------------------------------------*)
  441. PROCEDURE GetDReg * (VAR x : OCT.Item);
  442.  
  443.   (* CONST pname = "GetDReg"; *)
  444.  
  445.   VAR i : INTEGER;
  446.  
  447. BEGIN (* GetDReg *)
  448.   (*OCM.TraceIn (mname, pname);*)
  449.   i := D7; x.mode := Reg;
  450.   LOOP
  451.     IF ~(i IN RegSet) THEN x.a0 := i; INCL (RegSet, i); EXIT END;
  452.     IF i = D2 THEN x.a0 := D0; OCS.Mark (215); EXIT ELSE DEC (i) END
  453.   END
  454.   (*;OCM.TraceOut (mname, pname);*)
  455. END GetDReg;
  456.  
  457. (*------------------------------------*)
  458. PROCEDURE GetAReg * (VAR x : OCT.Item);
  459.  
  460.   (* CONST pname = "GetAReg"; *)
  461.  
  462.   VAR i : INTEGER;
  463.  
  464. BEGIN (* GetAReg *)
  465.   (*OCM.TraceIn (mname, pname);*)
  466.   i := A3; x.mode := Reg;
  467.   LOOP
  468.     IF ~(i IN RegSet) THEN x.a0 := i; INCL (RegSet, i); EXIT END;
  469.     IF i = A0 THEN x.a0 := A0; OCS.Mark (215); EXIT ELSE DEC (i) END
  470.   END; (* LOOP *)
  471.   (*;OCM.TraceOut (mname, pname);*)
  472. END GetAReg;
  473.  
  474. (*------------------------------------*)
  475. PROCEDURE GetAnyReg * (VAR x : OCT.Item);
  476.  
  477.   (* CONST pname = "GetAnyReg"; *)
  478.  
  479.   VAR i : INTEGER;
  480.  
  481. BEGIN (* GetAnyReg *)
  482.   (*OCM.TraceIn (mname, pname);*)
  483.   x.mode := Reg;
  484.   i := D7;
  485.   LOOP
  486.     IF ~(i IN RegSet) THEN x.a0 := i; INCL (RegSet, i); RETURN END;
  487.     IF i = D0 THEN EXIT ELSE DEC (i) END
  488.   END; (* LOOP *)
  489.   i := A3;
  490.   LOOP
  491.     IF ~(i IN RegSet) THEN x.a0 := i; INCL (RegSet, i); EXIT END;
  492.     IF i = A0 THEN x.a0 := A0; OCS.Mark (215); EXIT ELSE DEC (i) END
  493.   END; (* LOOP *)
  494.   (*;OCM.TraceOut (mname, pname);*)
  495. END GetAnyReg;
  496.  
  497. (*------------------------------------*)
  498. PROCEDURE ReserveReg * (reg : INTEGER);
  499.  
  500.   (* CONST pname = "ReserveReg"; *)
  501.  
  502. BEGIN (* ReserveReg *)
  503.   (*OCM.TraceIn (mname, pname);*)
  504.   IF ~(reg IN RegSet) THEN
  505.     INCL (RegSet, reg)
  506.   ELSE
  507.     OCS.Mark (215)
  508.   END; (* ELSE *)
  509.   (*;OCM.TraceOut (mname, pname);*)
  510. END ReserveReg;
  511.  
  512. (*------------------------------------*)
  513. PROCEDURE UnReserveReg * (reg : INTEGER);
  514.  
  515.   (* CONST pname = "UnReserveReg"; *)
  516.  
  517. BEGIN (* UnReserveReg *)
  518.   (*OCM.TraceIn (mname, pname);*)
  519.   IF (reg IN RegSet) THEN
  520.     EXCL (RegSet, reg)
  521.   ELSE
  522.     OCS.Mark (951)
  523.   END; (* ELSE *)
  524.   (*;OCM.TraceOut (mname, pname);*)
  525. END UnReserveReg;
  526.  
  527. (*------------------------------------*)
  528. PROCEDURE FreeRegs * (r : SET);
  529.  
  530.   (* CONST pname = "FreeRegs"; *)
  531.  
  532. BEGIN (* FreeRegs *)
  533.   (*OCM.TraceIn (mname, pname);*)
  534.   RegSet := r
  535.   (*;OCM.TraceOut (mname, pname);*)
  536. END FreeRegs;
  537.  
  538. (*------------------------------------*)
  539. PROCEDURE FreeReg * (VAR x : OCT.Item);
  540.  
  541.   (* CONST pname = "FreeReg"; *)
  542.  
  543.   VAR R : SET;
  544.  
  545. BEGIN (* FreeReg *)
  546.   (*OCM.TraceIn (mname, pname);*)
  547.   IF x.mode IN {Reg, RegI, RegX, Push, Pop} THEN
  548.     IF x.a0 IN RegSet THEN EXCL (RegSet, x.a0) ELSE OCS.Mark (951) END;
  549.     IF x.mode = RegX THEN
  550.       IF x.a2 IN RegSet THEN EXCL (RegSet, x.a2) ELSE OCS.Mark (951) END
  551.     END
  552.   ELSIF x.mode IN {VarX, IndX} THEN
  553.     IF x.a2 IN RegSet THEN EXCL (RegSet, x.a2) ELSE OCS.Mark (951) END
  554.   ELSIF x.mode = RList THEN
  555.     R := SYS.VAL (SET, x.a0);
  556.     IF (R * RegSet) = R THEN RegSet := RegSet - R ELSE OCS.Mark (951) END
  557.   ELSE OCS.Mark (216)
  558.   END;
  559.   x.mode := Undef
  560.   (*;OCM.TraceOut (mname, pname);*)
  561. END FreeReg;
  562.  
  563. (*------------------------------------*)
  564. PROCEDURE PutWord * (w : INTEGER);
  565.  
  566. BEGIN (* PutWord *)
  567.   IF codex >= CodeLength THEN OCS.Mark (231); codex := 0 END;
  568.   code [codex] := w; INC (codex); INC (pc, 2)
  569. END PutWord;
  570.  
  571. (*------------------------------------*)
  572. PROCEDURE PatchWord * (loc, w : INTEGER);
  573.  
  574.   (* CONST pname = "PatchWord"; *)
  575.  
  576. BEGIN (* PatchWord *)
  577.   (*OCM.TraceIn (mname, pname);*)
  578.   IF loc >= pc THEN OCS.Mark (961); loc := 0 END;
  579.   loc := loc DIV 2; code [loc] := SYS.LOR (code [loc], w)
  580.   (*;OCM.TraceOut (mname, pname);*)
  581. END PatchWord;
  582.  
  583. (*------------------------------------*)
  584. PROCEDURE PutLong * (l : LONGINT);
  585.  
  586. BEGIN (* PutLong *)
  587.   IF codex >= CodeLength - 1 THEN OCS.Mark (231); codex := 0 END;
  588.   code [codex] := SHORT (l DIV 10000H); INC (codex);
  589.   code [codex] := SHORT (l MOD 10000H); INC (codex);
  590.   INC (pc, 4)
  591. END PutLong;
  592.  
  593. (*------------------------------------*)
  594. PROCEDURE FindRef (label : OCT.Label; size : LONGINT) : Ref;
  595.  
  596.   (* CONST pname = "FindRef"; *)
  597.  
  598.   VAR ref : Ref;
  599.  
  600. BEGIN (* FindRef *)
  601.   (*OCM.TraceIn (mname, pname);*)
  602.   ref := CurrCodeHunk.refs;
  603.   WHILE (ref # NIL) & ((ref.label^ # label^) OR (ref.size # size)) DO
  604.     ref := ref.next
  605.   END; (* WHILE *)
  606.   (*;OCM.TraceOut (mname, pname);*)
  607.   RETURN ref
  608. END FindRef;
  609.  
  610. (*------------------------------------*)
  611. PROCEDURE MakeRef (ref : Ref; label : OCT.Label; size : INTEGER);
  612.  
  613.   (* CONST pname = "MakeRef"; *)
  614.  
  615.   VAR offset : Offset;
  616.  
  617. BEGIN (* MakeRef *)
  618.   (*OCM.TraceIn (mname, pname);*)
  619.   IF ref = NIL THEN
  620.     NEW (ref);
  621.     ref.next := CurrCodeHunk.refs; CurrCodeHunk.refs := ref;
  622.     ref.size := size; ref.label := label; ref.count := 0;
  623.     ref.offsets := NIL;
  624.   END;
  625.  
  626.   NEW (offset);
  627.   offset.next := ref.offsets; ref.offsets := offset; INC (ref.count);
  628.   offset.n := pc - (CurrCodeHunk.start * 2);
  629.   (*;OCM.TraceOut (mname, pname);*)
  630. END MakeRef;
  631.  
  632. (*------------------------------------*)
  633. PROCEDURE PutWordRef * (offset : INTEGER; label : OCT.Label);
  634.  
  635.   (* CONST pname = "PutWordRef"; *)
  636.  
  637. BEGIN (* PutWordRef *)
  638.   (*OCM.TraceIn (mname, pname);*)
  639.   IF label # NIL THEN
  640.     MakeRef (FindRef (label, 2), label, 2); PutWord (offset)
  641.   ELSE
  642.     OCS.Mark (964)
  643.   END
  644.   (*;OCM.TraceOut (mname, pname);*)
  645. END PutWordRef;
  646.  
  647. (*------------------------------------*)
  648. PROCEDURE PutLongRef * (offset : LONGINT; label : OCT.Label);
  649.  
  650.   (* CONST pname = "PutLongRef"; *)
  651.  
  652. BEGIN (* PutLongRef *)
  653.   (*OCM.TraceIn (mname, pname);*)
  654.   IF label # NIL THEN
  655.     MakeRef (FindRef (label, 4), label, 4); PutLong (offset)
  656.   ELSE
  657.     OCS.Mark (964)
  658.   END
  659.   (*;OCM.TraceOut (mname, pname);*)
  660. END PutLongRef;
  661.  
  662. (*------------------------------------*)
  663. PROCEDURE PutArg (VAR arg : Arg);
  664.  
  665.   (* CONST pname = "PutArg"; *)
  666.  
  667. BEGIN (* PutArg *)
  668.   (*OCM.TraceIn (mname, pname);*)
  669.   CASE arg.form OF
  670.     none : |
  671.     word : PutWord (SHORT (arg.data)) |
  672.     long : PutLong (arg.data) |
  673.     wordRef :
  674.       MakeRef (FindRef (arg.label, 2), arg.label, 2);
  675.       PutWord (SHORT (arg.data))
  676.     |
  677.     longRef :
  678.       MakeRef (FindRef (arg.label, 4), arg.label, 4);
  679.       PutLong (arg.data)
  680.     |
  681.   ELSE
  682.     OCS.Mark (1008); OCS.Mark (arg.form)
  683.   END; (* CASE arg.form *)
  684.   (*;OCM.TraceOut (mname, pname);*)
  685. END PutArg;
  686.  
  687. (*------------------------------------*)
  688. PROCEDURE Argument
  689.   ( VAR op : INTEGER; size : LONGINT; ea05 : BOOLEAN;
  690.     VAR item : OCT.Item; VAR arg : Arg );
  691.  
  692.   (* CONST pname = "Argument"; *)
  693.  
  694.   VAR
  695.     form, mode, itemMode, reg, op2 : INTEGER; regItem : OCT.Item;
  696.     data : LONGINT; label : OCT.Label;
  697.  
  698.   (*------------------------------------*)
  699.   PROCEDURE downlevel ();
  700.  
  701.     (* CONST pname = "downlevel"; *)
  702.  
  703.     VAR diff, op : INTEGER;
  704.  
  705.   BEGIN (* downlevel *)
  706.     (*OCM.TraceIn (mname, pname);*)
  707.     diff := level - item.lev;
  708.     GetAReg (regItem); reg := SHORT (regItem.a0-8);
  709.  
  710.     op := 206DH + SYS.LSH (reg, 9);          (* MOVEA.L 8(A5), An *)
  711.     PutWord (op); PutWord (8);
  712.  
  713.     op := 2068H + SYS.LSH (reg, 9) + reg;    (* MOVEA.L 8(An), An *)
  714.     WHILE diff > 1 DO
  715.       PutWord (op); PutWord (8);
  716.       DEC (diff)
  717.     END; (* WHILE *)
  718.  
  719.     mode := ARDisp; form := word; data := item.a0
  720.     (*;OCM.TraceOut (mname, pname);*)
  721.   END downlevel;
  722.  
  723. BEGIN (* Argument *)
  724.   (*OCM.TraceIn (mname, pname);*)
  725.   form := none;
  726.   CASE item.mode OF
  727.     Var, VarX, Ind, IndX :
  728.       itemMode := item.mode;
  729.       IF item.lev = 0 THEN             (* Global variable of local module *)
  730.         IF
  731.           OCS.pragma [OCS.longVars] OR (item.a0 > 32767) OR (A4 IN RegSet)
  732.         THEN
  733.           mode := Mode7; reg := AbsL; form := longRef;
  734.           label := OCT.VarLabel; data := item.a0
  735.         ELSIF item.a0 = 0 THEN
  736.           mode := ARInd; reg := BP; form := none
  737.         ELSE
  738.           mode := ARDisp; reg := BP; form := word; data := item.a0
  739.         END
  740.       ELSIF item.lev < 0 THEN       (* Global variable of imported module *)
  741.         mode := Mode7; reg := AbsL; form := longRef;
  742.         label := OCT.GlbMod [-item.lev-1].varLab; data := item.a0
  743.       ELSIF item.lev = level THEN          (* Local variable in procedure *)
  744.         IF item.a0 = 0 THEN
  745.           mode := ARInd; reg := FP; form := none
  746.         ELSE
  747.           mode := ARDisp; reg := FP; form := word; data := item.a0
  748.         END
  749.       ELSE                       (* Local variable in surrounding context *)
  750.         downlevel ();
  751.         IF itemMode = Var THEN
  752.           item.mode := RegI; item.a1 := item.a0; item.a0 := reg + 8;
  753.           Argument (op, size, ea05, item, arg);
  754.           RETURN
  755.         END; (* IF *)
  756.       END; (* ELSE *)
  757.  
  758.       arg.form := form; arg.data := data; arg.label := label;
  759.       IF itemMode = VarX THEN
  760.         GetAReg (regItem);
  761.         op2 :=
  762.           LEA + SYS.LSH (mode, 3) + reg
  763.           + SYS.LSH (SHORT (regItem.a0)-8, 9);          (* LEA <item>, An *)
  764.         PutWord (op2); PutArg (arg);
  765.         item.mode := RegX; item.a0 := regItem.a0; item.a1 := 0;
  766.         Argument (op, size, ea05, item, arg);
  767.         RETURN
  768.       ELSIF itemMode # Var THEN
  769.         GetAReg (regItem);
  770.         op2 :=
  771.           2040H + SYS.LSH (mode, 3) + reg
  772.           + SYS.LSH (SHORT (regItem.a0)-8, 9);
  773.         PutWord (op2); PutArg (arg);               (* MOVEA.L, <item>, An *)
  774.         reg := SHORT (regItem.a0) - 8;
  775.         IF itemMode = IndX THEN
  776.           IF item.a1 # 0 THEN
  777.             arg.form := word; arg.data := item.a1;
  778.             op2 := LEA + SYS.LSH (mode, 3) + reg + SYS.LSH (reg, 9);
  779.             PutWord (op2); PutArg (arg);                 (* LEA d(An), An *)
  780.           END; (* IF *)
  781.           item.mode := RegX; item.a0 := regItem.a0; item.a1 := 0;
  782.           Argument (op, size, ea05, item, arg);
  783.           RETURN
  784.         ELSE
  785.           item.mode := RegI; item.a0 := regItem.a0;
  786.           Argument (op, size, ea05, item, arg);
  787.           RETURN
  788.         END
  789.       END
  790.     |
  791.     RegI :
  792.       IF ~(item.a0 IN AdrRegs) THEN
  793.         OCS.Mark (215);
  794.         OCS.Mark (op); OCS.Mark (SHORT (size)); OCS.Mark (SHORT (item.a0));
  795.         item.a0 := A0
  796.       END;
  797.       reg := SHORT (item.a0) - 8;
  798.       IF item.a1 = 0 THEN mode := ARInd; form := none
  799.       ELSIF (item.a1 < -32768) OR (item.a1 > 32767) THEN
  800.         GetAnyReg (regItem);
  801.         IF regItem.a0 < A0 THEN                     (* MOVE.L #offset, Dn *)
  802.           op2 := 203CH + SYS.LSH (SHORT (regItem.a0), 9)
  803.         ELSE                                       (* MOVEA.L #offset, An *)
  804.           op2 := 207CH + SYS.LSH (SHORT (regItem.a0) - 8, 9)
  805.         END; (* ELSE *)
  806.         PutWord (op2); PutLong (item.a1);
  807.         item.mode := RegX; item.a1 := 0; item.a2 := SHORT(regItem.a0);
  808.         item.wordIndex := FALSE;
  809.         Argument (op, size, ea05, item, arg);
  810.         RETURN
  811.       ELSE
  812.         mode := ARDisp; form := word; data := item.a1
  813.       END
  814.     |
  815.     RegX :
  816.       IF ~(item.a0 IN AdrRegs) THEN OCS.Mark (215); item.a0 := A0 END;
  817.       mode := ARDisX; reg := SHORT (item.a0) - 8;
  818.       IF (item.a1 < -128) OR (item.a1 > 127) THEN
  819.         IF item.a2 < A0 THEN                        (* ADDI.z #offset, Rn *)
  820.           IF item.wordIndex THEN op2 := 0640H + item.a2
  821.           ELSE op2 := 0680H + item.a2
  822.           END
  823.         ELSE                                        (* ADDA.Z #offset, Rn *)
  824.           IF item.wordIndex THEN op2 := -2F04H + SYS.LSH (item.a2 - 8, 9)
  825.           ELSE op2 := -2E04H + SYS.LSH (item.a2 - 8, 9)
  826.           END
  827.         END; (* ELSE *)
  828.         PutWord (op2);
  829.         IF item.wordIndex THEN PutWord (SHORT (item.a1))
  830.         ELSE PutLong (item.a1)
  831.         END;
  832.         item.a1 := 0
  833.       END; (* IF *)
  834.       form := word;
  835.       data := SYS.AND (item.a1, 0FFH);                    (* Displacement *)
  836.       data := SYS.LOR (data, SYS.LSH (LONG (item.a2) MOD 8, 12));
  837.                                                             (* Index reg. *)
  838.       IF item.a2 >= A0 THEN data := SYS.LOR (data, -8000H)
  839.       END;                                                  (* Addr. Reg. *)
  840.       IF ~item.wordIndex THEN data := SYS.LOR (data, 800H)   (* Long reg. *)
  841.       END;
  842.     |
  843.     Lab, LabI :
  844.       mode := Mode7;
  845.       IF item.mode = Lab THEN reg := AbsL ELSE reg := Imm END;
  846.       IF item.a1 = W THEN form := wordRef
  847.       ELSIF item.a1 = L THEN form := longRef
  848.       ELSE OCS.Mark (957); form := longRef
  849.       END;
  850.       data := item.a0; label := item.label
  851.     |
  852.     Abs :
  853.       mode := Mode7;
  854.       IF (-32768 <= item.a0) & (item.a0 <= 32767) THEN
  855.         reg := AbsW; form := word
  856.       ELSE
  857.         reg := AbsL; form := long
  858.       END;
  859.       data := item.a0
  860.     |
  861.     Con :
  862.       IF item.typ = OCT.stringtyp THEN
  863.         IF item.a0 < 0 THEN OCS.Mark (962) END;
  864.         mode := Mode7; reg := AbsL; form := longRef; data := item.a0;
  865.         label := item.label
  866.       ELSE
  867.         mode := Mode7; reg := Imm;
  868.         IF size < L THEN form := word ELSE form := long END;
  869.         data := item.a0
  870.       END
  871.     |
  872.     Push, Pop :
  873.       IF ~(item.a0 IN AdrRegs) THEN OCS.Mark (215); item.a0 := A0 END;
  874.       IF item.mode = Push THEN mode := ARPre ELSE mode := ARPost END;
  875.       reg := SHORT (item.a0) - 8; form := none
  876.     |
  877.     Reg :
  878.       IF item.a0 IN DataRegs THEN
  879.         mode := DReg; reg := SHORT (item.a0); form := none
  880.       ELSE
  881.         mode := ARDir; reg := SHORT (item.a0) - 8; form := none
  882.       END
  883.     |
  884.     XProc, LProc :
  885.       mode := Mode7; data := 0; label := item.obj.label;
  886.       IF item.lev < 0 THEN reg := AbsL; form := longRef (* Imported proc. *)
  887.       ELSE reg := AbsW; form := wordRef
  888.       END
  889.     |
  890.     M2Proc, CProc, AProc :
  891.       mode := Mode7; data := 0; label := item.obj.label;
  892.       reg := AbsL; form := longRef
  893.     |
  894.     RList :
  895.       arg.form := word; arg.data := item.a0;
  896.       RETURN
  897.     |
  898.   ELSE
  899.     form := none; OCS.Mark (126);
  900.     RETURN
  901.   END; (* CASE item.mode *)
  902.  
  903.   arg.form := form; arg.data := data; arg.label := label;
  904.   IF ea05 THEN op := op + SYS.LSH (mode, 3) + reg
  905.   ELSE op := op + SYS.LSH (mode, 6) + SYS.LSH (reg, 9)
  906.   END
  907.   (*;OCM.TraceOut (mname, pname);*)
  908. END Argument;
  909.  
  910. (*------------------------------------*)
  911. PROCEDURE PutF1 * (op : INTEGER; size : LONGINT; VAR item : OCT.Item);
  912. (*
  913.   Instruction format #1: xxxxxxxxsseeeeee
  914.  
  915.   Instructions: CLR, NEG, NOT, TST
  916. *)
  917.  
  918.   (* CONST pname = "PutF1"; *)
  919.  
  920.   VAR arg : Arg;
  921.  
  922. BEGIN (* PutF1 *)
  923.   (* OCM.TraceIn (mname, pname); *)
  924.   op := op + SYS.LSH ((SHORT (size) DIV 2), 6);
  925.   Argument (op, size, TRUE, item, arg);
  926.   PutWord (op); PutArg (arg)
  927.   (* ;OCM.TraceOut (mname, pname); *)
  928. END PutF1;
  929.  
  930. (*------------------------------------*)
  931. PROCEDURE PutF2 * (op : INTEGER; VAR src : OCT.Item; reg : LONGINT);
  932. (*
  933.   Instruction format #2: xxxxrrrxxxeeeeee
  934.  
  935.   Instructions: LEA, DIVS, MULS, CHK
  936. *)
  937.  
  938.   (* CONST pname = "PutF2"; *)
  939.  
  940.   VAR arg : Arg;
  941.  
  942. BEGIN (* PutF2 *)
  943.   (* OCM.TraceIn (mname, pname); *)
  944.   op := op + SYS.LSH (SHORT (reg) MOD 8, 9);
  945.   Argument (op, W, TRUE, src, arg);
  946.   PutWord (op); PutArg (arg)
  947.   (* ;OCM.TraceOut (mname, pname); *)
  948. END PutF2;
  949.  
  950. (*------------------------------------*)
  951. PROCEDURE PutF3 * (op : INTEGER; VAR item : OCT.Item);
  952.  
  953. (*
  954.   Instruction format #3: xxxxxxxxxxeeeeee
  955.  
  956.   Instructions: PEA, JSR, JMP, Scc
  957. *)
  958.  
  959.   (* CONST pname = "PutF3"; *)
  960.  
  961.   VAR arg : Arg;
  962.  
  963. BEGIN (* PutF3 *)
  964.   (* OCM.TraceIn (mname, pname); *)
  965.   Argument (op, W, TRUE, item, arg);
  966.   PutWord (op); PutArg (arg)
  967.   (* ;OCM.TraceOut (mname, pname); *)
  968. END PutF3;
  969.  
  970. (*------------------------------------*)
  971. PROCEDURE Bit * (op : INTEGER; VAR src, dst : OCT.Item);
  972.  
  973. (*
  974.   Instruction format #2: xxxxrrrxxxeeeeee
  975.   Instruction format #3: xxxxxxxxxxeeeeee
  976.  
  977.   Instructions: BTST, BCLR, BSET
  978. *)
  979.  
  980.   (* CONST pname = "Bit"; *)
  981.  
  982.   VAR arg : Arg;
  983.  
  984. BEGIN (* Bit *)
  985.   (* OCM.TraceIn (mname, pname); *)
  986.   IF src.mode = Reg THEN
  987.     op := SYS.LOR (op, SYS.LOR (100H, SYS.LSH (SHORT (src.a0), 9)))
  988.   ELSE
  989.     op := SYS.LOR (op, 800H)
  990.   END;
  991.   Argument (op, W, TRUE, dst, arg);
  992.   PutWord (op); IF src.mode = Con THEN PutWord (SHORT (src.a0)) END;
  993.   PutArg (arg)
  994.   (* ;OCM.TraceOut (mname, pname); *)
  995. END Bit;
  996.  
  997. (*------------------------------------*)
  998. PROCEDURE Move * (size : LONGINT; VAR src, dst : OCT.Item);
  999.  
  1000.   (* CONST pname = "Move"; *)
  1001.  
  1002.   VAR arg1, arg2 : Arg; op, reg : INTEGER; rlist1, rlist2 : SYS.WORDSET;
  1003.  
  1004. BEGIN (* Move *)
  1005.   (* OCM.TraceIn (mname, pname); *)
  1006.   IF (src.mode = Reg) & (dst.mode = Reg) & (src.a0 = dst.a0) THEN
  1007.   (* ;OCM.TraceOut (mname, pname); *)
  1008.     RETURN
  1009.   END;
  1010.   IF src.mode = RList THEN                       (* MOVEM Registers to EA *)
  1011.     IF size = L THEN op := 48C0H ELSE op := 4880H END;
  1012.     Argument (op, size, TRUE, dst, arg1);
  1013.     IF dst.mode = Push THEN
  1014.       (* Reverse the register list first *)
  1015.       reg := 0;
  1016.       rlist1 := SYS.VAL (SYS.WORDSET, SHORT (src.a0)); rlist2 := {};
  1017.       WHILE reg <= A7 DO
  1018.         IF reg IN rlist1 THEN INCL (rlist2, 15 - reg) END;
  1019.         INC (reg)
  1020.       END;
  1021.       src.a0 := SYS.VAL (LONGINT, LONG (rlist2))
  1022.     END;
  1023.     PutWord (op); PutWord (SHORT (src.a0)); PutArg (arg1)
  1024.   ELSIF dst.mode = RList THEN                    (* MOVEM EA to Registers *)
  1025.     IF size = L THEN op := 4CC0H ELSE op := 4C80H END;
  1026.     Argument (op, size, TRUE, src, arg1);
  1027.     PutWord (op); PutWord (SHORT (dst.a0)); PutArg (arg1)
  1028.   ELSIF (dst.mode = Reg) & (dst.a0 IN AdrRegs) THEN
  1029.     IF (src.mode = Con) & (src.a0 = 0) THEN        (* SUBA.Z <dst>, <dst> *)
  1030.       reg := SHORT (dst.a0) - 8; op := -6F38H;
  1031.       IF size = L THEN op := SYS.LOR (op, 100H)
  1032.       ELSIF size = B THEN OCS.Mark (957)
  1033.       END;
  1034.       op := SYS.LOR (op, SYS.LOR (SYS.LSH (reg, 9), reg));
  1035.       PutWord (op)
  1036.     ELSE                                          (* MOVEA.Z <src>, <dst> *)
  1037.       IF size = L THEN
  1038.         op := SYS.LOR (2040H, SYS.LSH (SHORT (dst.a0) MOD 8, 9))
  1039.       ELSIF size = W THEN
  1040.         op := SYS.LOR (3040H, SYS.LSH (SHORT (dst.a0) MOD 8, 9))
  1041.       ELSE
  1042.         OCS.Mark (957); op := 3040H
  1043.       END;
  1044.       Argument (op, size, TRUE, src, arg1); PutWord (op); PutArg (arg1)
  1045.     END
  1046.   ELSIF
  1047.     (dst.mode = Reg) & (dst.a0 IN DataRegs) & (src.mode = Con)
  1048.     & (src.a0 >= -128) & (src.a0 <= 127)
  1049.   THEN                                             (* MOVEQ #<src>, <dst> *)
  1050.     op := SYS.LOR (7000H, SYS.LSH (SHORT (dst.a0), 9));
  1051.     op := SYS.LOR (op, SYS.AND (SHORT (src.a0), 0FFH));
  1052.     PutWord (op)
  1053.   ELSIF (src.mode = Con) & (src.a0 = 0) THEN               (* CLR.z <dst> *)
  1054.     PutF1 (CLR, size, dst)
  1055.   ELSE                                             (* MOVE.z <src>, <dst> *)
  1056.     IF size = L THEN op := 2000H
  1057.     ELSIF size = W THEN op := 3000H
  1058.     ELSIF size = B THEN op := 1000H
  1059.     ELSE
  1060.       OCS.Mark (957); op := 1000H
  1061.     END;
  1062.     Argument (op, size, TRUE, src, arg1);
  1063.     Argument (op, size, FALSE, dst, arg2);
  1064.     PutWord (op); PutArg (arg1); PutArg (arg2)
  1065.   END
  1066.   (* ;OCM.TraceOut (mname, pname); *)
  1067. END Move;
  1068.  
  1069. (*------------------------------------*)
  1070. PROCEDURE PutF7 * (op : INTEGER; size, src : LONGINT; VAR dst : OCT.Item);
  1071. (*
  1072.   Instruction format #7: xxxxdddxsseeeeee
  1073.  
  1074.   Instructions: ADDQ, SUBQ
  1075. *)
  1076.  
  1077.   (* CONST pname = "PutF7"; *)
  1078.  
  1079.   VAR arg : Arg;
  1080.  
  1081. BEGIN (* PutF7 *)
  1082.   (* OCM.TraceIn (mname, pname); *)
  1083.   IF (src > 0) & (src <= 8) THEN
  1084.     op := SYS.LOR (op, SYS.LSH ((SHORT (size) DIV 2), 6));
  1085.     op := SYS.LOR (op, SYS.LSH (SHORT (src) MOD 8, 9));
  1086.     Argument (op, size, TRUE, dst, arg); PutWord (op); PutArg (arg)
  1087.   ELSE
  1088.     OCS.Mark (957)
  1089.   END; (* ELSE *)
  1090.   (* ;OCM.TraceOut (mname, pname); *)
  1091. END PutF7;
  1092.  
  1093. (*------------------------------------*)
  1094. PROCEDURE PutF6 * (op : INTEGER; size : LONGINT; VAR src, dst : OCT.Item);
  1095. (*
  1096.   Instruction format #6: xxxxxxxxsseeeeee
  1097.  
  1098.   Instructions: ORI, SUBI, CMPI, EORI, ANDI, ADDI
  1099.   Instructions: ADDQ, SUBQ
  1100. *)
  1101.  
  1102.   (* CONST pname = "PutF6"; *)
  1103.  
  1104.   VAR arg : Arg;
  1105.  
  1106. BEGIN (* PutF6 *)
  1107.   (* OCM.TraceIn (mname, pname); *)
  1108.   IF ((op = ADDI) OR (op = SUBI)) & (src.a0 > 0) & (src.a0 < 9) THEN
  1109.     IF op = ADDI THEN op := ADDQ ELSE op := SUBQ END;
  1110.     PutF7 (op, size, src.a0, dst)
  1111.   ELSE
  1112.     op := SYS.LOR (op, SYS.LSH ((SHORT (size) DIV 2), 6));
  1113.     Argument (op, size, TRUE, dst, arg); PutWord (op);
  1114.     IF src.mode = LabI THEN PutLongRef (src.a0, src.label)
  1115.     ELSIF size = L THEN PutLong (src.a0)
  1116.     ELSE PutWord (SHORT (src.a0))
  1117.     END;
  1118.     PutArg (arg)
  1119.   END
  1120.   (* ;OCM.TraceOut (mname, pname); *)
  1121. END PutF6;
  1122.  
  1123. (*------------------------------------*)
  1124. PROCEDURE PutF5 * (op : INTEGER; size : LONGINT; VAR src, dst : OCT.Item);
  1125. (*
  1126.   Instruction format #5: xxxxrrrmmmeeeeee
  1127.  
  1128.   Instructions: OR, SUB, SUBA, CMP, CMPA, EOR, AND, ADD, ADDA, ORI,
  1129.   SUBI, CMPI, EORI, ANDI, ADDI, ADDQ, SUBQ
  1130. *)
  1131.  
  1132.   (* CONST pname = "PutF5"; *)
  1133.  
  1134.   VAR arg : Arg;
  1135.  
  1136. BEGIN (* PutF5 *)
  1137.   (* OCM.TraceIn (mname, pname); *)
  1138.   IF (dst.mode = Reg) & (dst.a0 IN AdrRegs) THEN
  1139.     IF size = L THEN op := SYS.LOR (op, 1C0H)
  1140.     ELSIF size = W THEN op := SYS.LOR (op, 0C0H)
  1141.     ELSE OCS.Mark (957)
  1142.     END;
  1143.     op := SYS.LOR (op, SYS.LSH (SHORT (dst.a0) - 8, 9));
  1144.     Argument (op, size, TRUE, src, arg)
  1145.   ELSIF (src.mode = Con) OR (src.mode = LabI) THEN
  1146.     IF op = iOR THEN op := ORI
  1147.     ELSIF op = SUB THEN op := SUBI
  1148.     ELSIF op = CMP THEN op := CMPI
  1149.     ELSIF op = EOR THEN op := EORI
  1150.     ELSIF op = AND THEN op := ANDI
  1151.     ELSIF op = ADD THEN op := ADDI
  1152.     ELSE OCS.Mark (956)
  1153.     END;
  1154.     PutF6 (op, size, src, dst);
  1155.     RETURN
  1156.   ELSIF (op # EOR) & (dst.mode = Reg) & (dst.a0 IN DataRegs) THEN
  1157.     op := SYS.LOR (op, SYS.LSH (SHORT (size) DIV 2, 6));
  1158.     op := SYS.LOR (op, SYS.LSH (SHORT (dst.a0), 9));
  1159.     Argument (op, size, TRUE, src, arg)
  1160.   ELSE
  1161.     op := SYS.LOR (op, SYS.LSH (SHORT (size) DIV 2, 6));
  1162.     op := SYS.LOR (SYS.LOR (op, 100H), SYS.LSH (SHORT (src.a0), 9));
  1163.     Argument (op, size, TRUE, dst, arg)
  1164.   END;
  1165.   PutWord (op); PutArg (arg)
  1166.   (* ;OCM.TraceOut (mname, pname); *)
  1167. END PutF5;
  1168.  
  1169. (*------------------------------------*)
  1170. PROCEDURE Shift * (op : INTEGER; size : LONGINT; VAR count, reg : OCT.Item);
  1171.  
  1172. (*
  1173.   Instruction format #5: xxxxrrrxssxxxrrr
  1174.  
  1175.   Instructions: ASL, ASR, LSL, LSR, ROL, ROR
  1176. *)
  1177.  
  1178.   (* CONST pname = "Shift"; *)
  1179.  
  1180.   VAR arg : Arg;
  1181.  
  1182. BEGIN (* Shift *)
  1183.   (* OCM.TraceIn (mname, pname); *)
  1184.   IF (reg.mode = Reg) & (reg.a0 IN DataRegs) THEN
  1185.     op := SYS.LOR (op, SYS.LSH ((SHORT (size) DIV 2), 6));
  1186.     op := SYS.LOR (op, SHORT (reg.a0));
  1187.     IF (count.mode = Reg) & (count.a0 IN DataRegs) THEN
  1188.       op := SYS.LOR (op, 20H);
  1189.       op := SYS.LOR (op, SYS.LSH (SHORT (count.a0), 9))
  1190.     ELSIF count.mode = Con THEN
  1191.       IF (count.a0 > 0) & (count.a0 <= 8) THEN
  1192.         op := SYS.LOR (op, SYS.LSH (SHORT (count.a0) MOD 8, 9))
  1193.       ELSE OCS.Mark (957)
  1194.       END;
  1195.     ELSE OCS.Mark (956)
  1196.     END;
  1197.     PutWord (op)
  1198.   ELSE OCS.Mark (956)
  1199.   END;
  1200.   (* ;OCM.TraceOut (mname, pname); *)
  1201. END Shift;
  1202.  
  1203. (*------------------------------------*)
  1204. PROCEDURE SaveRegisters0 (regs : SET);
  1205.  
  1206.   (* CONST pname = "SaveRegisters0"; *)
  1207.  
  1208.   VAR numRegs, reg, lastReg, op : INTEGER; rlist : SYS.WORDSET;
  1209.  
  1210. BEGIN (* SaveRegisters0 *)
  1211.   (* OCM.TraceIn (mname, pname); *)
  1212.   IF regs # {} THEN
  1213.     numRegs := 0; reg := 0;
  1214.     WHILE reg <= A7 DO
  1215.       IF reg IN regs THEN lastReg := reg; INC (numRegs) END;
  1216.       INC (reg)
  1217.     END;
  1218.     IF numRegs = 1 THEN
  1219.       IF lastReg IN DataRegs THEN                     (* MOVE.L Dn, -(A7) *)
  1220.         op := SYS.LOR (2F00H, lastReg)
  1221.       ELSE                                            (* MOVE.L An, -(A7) *)
  1222.         op := SYS.LOR (2F08H, lastReg - 8)
  1223.       END;
  1224.       PutWord (op)
  1225.     ELSE                                         (* MOVEM.L <regs>, -(A7) *)
  1226.       (* Reverse the register list first *)
  1227.       reg := 0; rlist := {};
  1228.       WHILE reg <= lastReg DO
  1229.         IF reg IN regs THEN INCL (rlist, 15 - reg) END;
  1230.         INC (reg)
  1231.       END;
  1232.       PutWord (48E7H); PutWord (SYS.VAL (INTEGER, rlist))
  1233.     END
  1234.   END
  1235.   (* ;OCM.TraceOut (mname, pname); *)
  1236. END SaveRegisters0;
  1237.  
  1238. (*------------------------------------*)
  1239. PROCEDURE SaveRegisters *
  1240.   ( VAR regs : SET;
  1241.     VAR x    : OCT.Item;
  1242.     mask     : SET );
  1243.  
  1244.   (* CONST pname = "SaveRegisters"; *)
  1245.  
  1246.   VAR temp : SET;
  1247.  
  1248. BEGIN (* SaveRegisters *)
  1249.   (* OCM.TraceIn (mname, pname); *)
  1250.   (* Temporarily reserve A4 and/or A5 if in mask *)
  1251.   RegSet := RegSet + (mask * {A4,A5});
  1252.   temp := RegSet; RegSet := RegSet * mask;
  1253.   IF x.mode IN {Reg, RegI, RegX} THEN EXCL (RegSet, x.a0) END;
  1254.   IF x.mode IN {VarX, IndX, RegX} THEN EXCL (RegSet, x.a2) END;
  1255.   SaveRegisters0 (RegSet);
  1256.   regs := RegSet; RegSet := temp - RegSet;
  1257.   (* ;OCM.TraceOut (mname, pname); *)
  1258. END SaveRegisters;
  1259.  
  1260. (*------------------------------------*)
  1261. PROCEDURE LoadRegParams1 * (VAR regs : SET; VAR x : OCT.Item);
  1262.  
  1263.   (* CONST pname = "LoadRegParams1"; *)
  1264.  
  1265.   VAR d0 : OCT.Item; inD0 : BOOLEAN;
  1266.  
  1267. BEGIN (* LoadRegParams1 *)
  1268.   (* OCM.TraceIn (mname, pname); *)
  1269.   inD0 := (x.mode = Reg) & (x.a0 = D0);
  1270.   regs := RegSet * ScratchRegs; IF inD0 THEN EXCL (regs, D0) END;
  1271.   SaveRegisters0 (regs); RegSet := RegSet - regs;
  1272.   IF ~inD0 THEN
  1273.     d0.mode := Reg; d0.a0 := D0; Move (x.typ^.size, x, d0)
  1274.   END; (* IF *)
  1275.   (* ;OCM.TraceOut (mname, pname); *)
  1276. END LoadRegParams1;
  1277.  
  1278. (*------------------------------------*)
  1279. PROCEDURE LoadRegParams2 * (VAR regs : SET; VAR x, y : OCT.Item);
  1280.  
  1281.   (* CONST pname = "LoadRegParams2"; *)
  1282.  
  1283.   VAR d0, d1, t : OCT.Item;
  1284.  
  1285. BEGIN (* LoadRegParams2 *)
  1286.   (* OCM.TraceIn (mname, pname); *)
  1287.   regs := RegSet * ScratchRegs;
  1288.   IF (x.mode = Reg) & (x.a0 IN {D0, D1}) THEN EXCL (regs, x.a0) END;
  1289.   IF (y.mode = Reg) & (y.a0 IN {D0, D1}) THEN EXCL (regs, y.a0) END;
  1290.   SaveRegisters0 (regs); RegSet := RegSet - regs;
  1291.   d0.mode := Reg; d0.a0 := D0; d1.mode := Reg; d1.a0 := D1;
  1292.   IF (y.mode = Reg) & (y.a0 = D0) THEN
  1293.     IF (x.mode = Reg) & (x.a0 = D1) THEN
  1294.       GetDReg (t); Move (x.typ^.size, x, t); x.a0 := t.a0;
  1295.       EXCL (RegSet, D1)
  1296.     END; (* IF *)
  1297.     Move (y.typ^.size, y, d1); y.a0 := D1;
  1298.     EXCL (RegSet, D0); INCL (RegSet, D1)
  1299.   END; (* IF *)
  1300.   IF ~((x.mode = Reg) & (x.a0 = D0)) THEN Move (x.typ^.size, x, d0) END;
  1301.   IF ~((y.mode = Reg) & (y.a0 = D1)) THEN Move (y.typ^.size, y, d1) END
  1302.   (* ;OCM.TraceOut (mname, pname); *)
  1303. END LoadRegParams2;
  1304.  
  1305. (*------------------------------------*)
  1306. PROCEDURE CallKernel * ( proc : INTEGER );
  1307. BEGIN (* CallKernel *)
  1308.   PutWord (4EB9H); PutLongRef (0, kernelLab [proc])
  1309. END CallKernel;
  1310.  
  1311. (*------------------------------------*)
  1312. PROCEDURE RestoreRegisters * (regs : SET; VAR x : OCT.Item);
  1313.  
  1314.   (* CONST pname = "RestoreRegisters"; *)
  1315.  
  1316.   VAR
  1317.     numRegs, op, reg, lastReg : INTEGER; y : OCT.Item; rlist : SET;
  1318.     restyp : OCT.Struct;
  1319.  
  1320. BEGIN (* RestoreRegisters *)
  1321.   (* OCM.TraceIn (mname, pname); *)
  1322.   RegSet := RegSet + regs;
  1323.   IF x.mode IN {XProc, LProc, TProc, M2Proc, CProc, AProc} THEN
  1324.     restyp := x.typ
  1325.   ELSIF (x.mode IN {Var..RegX}) & (x.typ.form = ProcTyp) THEN
  1326.     restyp := x.typ.BaseTyp
  1327.   ELSE
  1328.     restyp := NIL
  1329.   END;
  1330.   IF
  1331.     (restyp # NIL) & (restyp.form = Pointer) & (restyp.size > OCM.PtrSize)
  1332.   THEN (* PROCEDURE return type is POINTER TO ARRAY OF ... *)
  1333.     reg := 0; rlist := {};
  1334.     WHILE (reg * 4) < restyp.size DO INCL (rlist, reg); INC (reg) END;
  1335.     IF (rlist * RegSet) # {} THEN OCS.Mark (967) END;
  1336.     RegSet := RegSet + rlist;
  1337.     x.mode := RList; x.a0 := SYS.VAL (LONGINT, rlist)
  1338.   ELSE
  1339.     y := x; x.mode := Reg; x.a0 := D0;
  1340.     IF (D0 IN regs) OR (y.mode = Reg) THEN
  1341.       IF (y.mode # Reg) OR ~(y.a0 IN DataRegs) THEN
  1342.         GetDReg (y)
  1343.       END;
  1344.       IF y.a0 # 0 THEN Move (L, x, y); x.a0 := y.a0 END;
  1345.     ELSE
  1346.       INCL (RegSet, D0);
  1347.     END
  1348.   END;
  1349.   IF regs # {} THEN
  1350.     numRegs := 0; reg := 0;
  1351.     WHILE reg <= A7 DO
  1352.       IF reg IN regs THEN lastReg := reg; INC (numRegs) END;
  1353.       INC (reg)
  1354.     END; (* WHILE *)
  1355.     IF numRegs = 1 THEN
  1356.       IF lastReg IN DataRegs THEN                     (* MOVE.L (A7)+, Dn *)
  1357.         op := SYS.LOR (201FH, SYS.LSH (lastReg, 9))
  1358.       ELSE                                           (* MOVEA.L (A7)+, An *)
  1359.         op := SYS.LOR (205FH, SYS.LSH (lastReg - 8, 9))
  1360.       END;
  1361.       PutWord (op)
  1362.     ELSE                                         (* MOVEM.L (A7)+, <regs> *)
  1363.       PutWord (4CDFH); PutWord (SYS.VAL (INTEGER, SHORT (regs)))
  1364.     END
  1365.   END; (* IF *)
  1366.   RegSet := RegSet - {A4,A5} (* Mask out system registers *)
  1367.   (* ;OCM.TraceOut (mname, pname); *)
  1368. END RestoreRegisters;
  1369.  
  1370. (*------------------------------------*)
  1371. PROCEDURE fixup * (loc : LONGINT); (* enter pc at loc *)
  1372.  
  1373. BEGIN (* fixup *)
  1374.   code [loc DIV 2] := pc - SHORT (loc)
  1375. END fixup;
  1376.  
  1377. (*------------------------------------*)
  1378. PROCEDURE FixLink * (L : LONGINT);
  1379.  
  1380.   (* CONST pname = "FixLink"; *)
  1381.  
  1382.   VAR L1 : LONGINT;
  1383.  
  1384. BEGIN (* FixLink *)
  1385.   (* OCM.TraceIn (mname, pname); *)
  1386.   WHILE L # 0 DO
  1387.     L1 := code [L DIV 2]; fixup (L); L := L1
  1388.   END; (* WHILE *)
  1389.   (* ;OCM.TraceOut (mname, pname); *)
  1390. END FixLink;
  1391.  
  1392. (*------------------------------------*)
  1393. PROCEDURE FixupWith * (L, val : LONGINT);
  1394.  
  1395.   VAR x : LONGINT;
  1396.  
  1397. BEGIN (* FixupWith *)
  1398.   code [L DIV 2] := SHORT (val)
  1399. END FixupWith;
  1400.  
  1401. (*------------------------------------*)
  1402. PROCEDURE FixLinkWith * (L, val : LONGINT);
  1403.  
  1404.   (* CONST pname = "FixLinkWith"; *)
  1405.  
  1406.   VAR L1 : LONGINT;
  1407.  
  1408. BEGIN (* FixLinkWith *)
  1409.   (* OCM.TraceIn (mname, pname); *)
  1410.   WHILE L # 0 DO
  1411.     L1 := code [L DIV 2];
  1412.     FixupWith (L, val - L); L := L1
  1413.   END; (* WHILE *)
  1414.   (* ;OCM.TraceOut (mname, pname); *)
  1415. END FixLinkWith;
  1416.  
  1417. (*------------------------------------*)
  1418. PROCEDURE MergedLinks * (L0, L1 : LONGINT): LONGINT;
  1419.  
  1420.   (* CONST pname = "MergedLinks"; *)
  1421.  
  1422.   VAR L2, L3 : LONGINT;
  1423.  
  1424. BEGIN (* MergedLinks *)
  1425.   (* OCM.TraceIn (mname, pname); *)
  1426.   (* merge chains of the two operands of AND and OR *)
  1427.   IF L0 # 0 THEN
  1428.     L2 := L0;
  1429.     LOOP
  1430.       L3 := code [L2 DIV 2];
  1431.       IF L3 = 0 THEN EXIT END;
  1432.       L2 := L3
  1433.     END; (* LOOP *)
  1434.     code [L2 DIV 2] := SHORT (L1);
  1435.     RETURN L0
  1436.   ELSE
  1437.     RETURN L1
  1438.   END; (* ELSE *)
  1439.   (* ;OCM.TraceOut (mname, pname); *)
  1440. END MergedLinks;
  1441.  
  1442. (*------------------------------------*)
  1443. PROCEDURE invertedCC * (cc : LONGINT) : INTEGER;
  1444.  
  1445. BEGIN (* invertedCC *)
  1446.   IF ODD (cc) THEN RETURN SHORT (cc - 1)
  1447.   ELSE RETURN SHORT (cc + 1)
  1448.   END
  1449. END invertedCC;
  1450.  
  1451. (*------------------------------------*)
  1452. PROCEDURE Trap * (n : INTEGER);
  1453.  
  1454.   (* CONST pname = "Trap"; *)
  1455.  
  1456. BEGIN (* Trap *)
  1457.   (* OCM.TraceIn (mname, pname); *)
  1458.   IF n = OverflowCheck THEN
  1459.     PutWord (TRAPV);                             (*    TRAPV            *)
  1460.     PutWord (06008H);                            (*    BRA.S 1$         *)
  1461.   ELSE
  1462.     PutWord (TRAP + n)                           (*    TRAP  #n         *)
  1463.   END;
  1464.   PutLongRef (0, OCT.ConstLabel);                (*    DC.L  ModuleName *)
  1465.   PutWord (OCS.line);                            (*    DC.W  line       *)
  1466.   PutWord (OCS.col);                             (*    DC.W  col        *)
  1467.                                                  (* 1$                  *)
  1468.   (* ;OCM.TraceOut (mname, pname); *)
  1469. END Trap;
  1470.  
  1471. (*------------------------------------*)
  1472. PROCEDURE TrapCC * (n, cc : INTEGER);
  1473.  
  1474.   (* CONST pname = "TrapCC"; *)
  1475.  
  1476. BEGIN (* TrapCC *)
  1477.   (* OCM.TraceIn (mname, pname); *)
  1478.   IF cc # T THEN
  1479.     (* Branch over the following TRAP instruction (10 bytes) *)
  1480.     PutWord (Bcc + (invertedCC (cc) * 100H) + 10)
  1481.   END;
  1482.   Trap (n)
  1483.   (* ;OCM.TraceOut (mname, pname); *)
  1484. END TrapCC;
  1485.  
  1486. (*------------------------------------*)
  1487. PROCEDURE TrapLink * ( n, cc, L : INTEGER );
  1488.  
  1489.   (* CONST pname = "TrapLink"; *)
  1490.  
  1491. BEGIN (* TrapLink *)
  1492.   (* OCM.TraceIn (mname, pname); *)
  1493.   IF cc # T THEN
  1494.     (* Branch over the following TRAP instruction (10 bytes) *)
  1495.     PutWord (Bcc + (invertedCC (cc) * 100H) + 10)(*    Bcc   2$         *)
  1496.   END;
  1497.   PatchWord (L, pc - L - 2); PutWord (TRAP + n); (* 1$ TRAP  #n         *)
  1498.   PutLongRef (0, OCT.ConstLabel);                (*    DC.L  ModuleName *)
  1499.   PutWord (OCS.line);                            (*    DC.W  line       *)
  1500.   PutWord (OCS.col);                             (*    DC.W  col        *)
  1501.   (* ;OCM.TraceOut (mname, pname); *)            (* 2$                  *)
  1502. END TrapLink;
  1503.  
  1504. (*------------------------------------*)
  1505. PROCEDURE TypeTrap * ( L : INTEGER );
  1506.  
  1507.   (* CONST pname = "TypeTrap"; *)
  1508.  
  1509. BEGIN (* TypeTrap *)
  1510.   (* OCM.TraceIn (mname, pname); *)
  1511.   PutWord (600AH);                               (*    BRA.S 1$         *)
  1512.   FixLink (L); PutWord (TRAP + TypeCheck);       (* L: TRAP  #TypeCheck *)
  1513.   PutLongRef (0, OCT.ConstLabel);                (*    DC.L  ModuleName *)
  1514.   PutWord (OCS.line);                            (*    DC.W  line       *)
  1515.   PutWord (OCS.col);                             (*    DC.W  col        *)
  1516.                                                  (* 1$                  *)
  1517.   (* ;OCM.TraceOut (mname, pname); *)
  1518. END TypeTrap;
  1519.  
  1520. (*------------------------------------*)
  1521. PROCEDURE PutCHK* ( VAR bound : OCT.Item; reg : LONGINT );
  1522. BEGIN (* PutCHK *)
  1523.   PutF2 (CHK, bound, reg);
  1524.   PutWord (06008H);                              (*    BRA.S 1$         *)
  1525.   PutLongRef (0, OCT.ConstLabel);                (*    DC.L  ModuleName *)
  1526.   PutWord (OCS.line);                            (*    DC.W  line       *)
  1527.   PutWord (OCS.col);                             (*    DC.W  col        *)
  1528.                                                  (* 1$                  *)
  1529. END PutCHK;
  1530.  
  1531. (*------------------------------------*)
  1532. PROCEDURE GlobalPtrs * () : BOOLEAN;
  1533.  
  1534.   (* CONST pname = "GlobalPtrs"; *)
  1535.  
  1536.   VAR obj : OCT.Object;
  1537.  
  1538.   (*------------------------------------*)
  1539.   PROCEDURE FindPtrs (typ : OCT.Struct);
  1540.  
  1541.     (* CONST pname = "FindPtrs"; *)
  1542.  
  1543.     VAR btyp : OCT.Struct; fld : OCT.Object; i, n : LONGINT;
  1544.  
  1545.   BEGIN (* FindPtrs *)
  1546.     (* OCM.TraceIn (mname, pname); *)
  1547.     IF
  1548.       ((typ.form = Pointer) & (typ.sysflg = OberonFlag))
  1549.       OR (typ.form = PtrTyp)
  1550.     THEN
  1551.       INC (numPtrs)
  1552.     ELSIF (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  1553.       btyp := typ.BaseTyp; IF btyp # NIL THEN FindPtrs (btyp) END;
  1554.       fld := typ.link;
  1555.       WHILE fld # NIL DO
  1556.         IF fld.mode = Fld THEN
  1557.           IF fld.name < 0 THEN INC (numPtrs) (* Hidden pointer field *)
  1558.           ELSE FindPtrs (fld.typ)
  1559.           END;
  1560.         END;
  1561.         fld := fld.left
  1562.       END
  1563.     ELSIF typ.form = Array THEN
  1564.       btyp := typ.BaseTyp; n := typ.n;
  1565.       WHILE btyp.form = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END;
  1566.       IF btyp.form IN {Pointer, PtrTyp, Record} THEN
  1567.         i := 0; WHILE i < n DO FindPtrs (btyp); INC (i) END
  1568.       END
  1569.     END
  1570.     (* ;OCM.TraceOut (mname, pname); *)
  1571.   END FindPtrs;
  1572.  
  1573. BEGIN (* GlobalPtrs *)
  1574.   (* OCM.TraceIn (mname, pname); *)
  1575.   numPtrs := 0; obj := OCT.topScope.right;
  1576.   WHILE obj # NIL DO
  1577.     IF obj.mode = Var THEN FindPtrs (obj.typ) END;
  1578.     obj := obj.link
  1579.   END;
  1580.   (* ;OCM.TraceOut (mname, pname); *)
  1581.   RETURN (numPtrs # 0)
  1582. END GlobalPtrs;
  1583.  
  1584. (*------------------------------------*)
  1585. PROCEDURE NumProcs (typ : OCT.Struct) : LONGINT;
  1586.  
  1587.   (* CONST pname = "NumProcs"; *)
  1588.  
  1589.   VAR n : LONGINT; obj : OCT.Object;
  1590.  
  1591. BEGIN (* NumProcs *)
  1592.   (* OCM.TraceIn (mname, pname); *)
  1593.   n := 0;
  1594.   REPEAT
  1595.     obj := typ.link;
  1596.     WHILE obj # NIL DO
  1597.       IF (obj.mode = TProc) & (obj.a0 > n) THEN n := obj.a0 END;
  1598.       obj := obj.left
  1599.     END;
  1600.     typ := typ.BaseTyp
  1601.   UNTIL typ = NIL;
  1602.   (* ;OCM.TraceOut (mname, pname); *)
  1603.   RETURN n
  1604. END NumProcs;
  1605.  
  1606. (*------------------------------------*)
  1607. PROCEDURE ProcLab (typ : OCT.Struct; pno : LONGINT) : OCT.Label;
  1608.  
  1609.   (* CONST pname = "ProcLab"; *)
  1610.  
  1611.   VAR obj : OCT.Object;
  1612.  
  1613. BEGIN (* ProcLab *)
  1614.   (* OCM.TraceIn (mname, pname); *)
  1615.   LOOP
  1616.     obj := typ.link;
  1617.     WHILE obj # NIL DO
  1618.       IF (obj.mode = TProc) & (obj.a0 = pno) THEN
  1619.         (* OCM.TraceOut (mname, pname); *)
  1620.         RETURN obj.label
  1621.       END;
  1622.       obj := obj.left
  1623.     END;
  1624.     typ := typ.BaseTyp;
  1625.     IF typ = NIL THEN HALT (929) END
  1626.   END;
  1627. END ProcLab;
  1628.  
  1629.  
  1630. (*------------------------------------*)
  1631. PROCEDURE AllocSlots*;
  1632.  
  1633.   VAR
  1634.     slot, nextSlot : LONGINT; obj : OCT.Object; typ : OCT.Struct;
  1635.     i, pos1, pos2, offset : INTEGER;
  1636.  
  1637.   PROCEDURE FindSlot ( typ : OCT.Struct; name : LONGINT ) : LONGINT;
  1638.     VAR obj : OCT.Object;
  1639.   BEGIN (* FindSlot *)
  1640.     LOOP
  1641.       IF typ = NIL THEN RETURN -1 END;
  1642.       obj := typ.link;
  1643.       WHILE obj # NIL DO
  1644.         IF (obj.mode = TProc) & (obj.name = name) THEN RETURN obj.a0 END;
  1645.         obj := obj.left
  1646.       END;
  1647.       typ := typ.BaseTyp
  1648.     END
  1649.   END FindSlot;
  1650.  
  1651. BEGIN (* AllocSlots *)
  1652.   FOR i := 0 TO typex - 1 DO
  1653.     typ := type [i];
  1654.     IF (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  1655.       nextSlot := OCT.NextProc (typ);
  1656.       obj := typ.link;
  1657.       WHILE obj # NIL DO
  1658.         IF (obj.mode = TProc) & (obj.a0 < 0) THEN
  1659.           slot := FindSlot (typ.BaseTyp, obj.name);
  1660.           IF slot < 0 THEN slot := nextSlot; INC (nextSlot) END;
  1661.           obj.a0 := slot; offset := SHORT (slot * (-4));
  1662.           pos1 := obj.a2;
  1663.           WHILE pos1 # 1 DO
  1664.             pos2 := code [pos1 DIV 2]; code [pos1 DIV 2] := offset;
  1665.             pos1 := pos2
  1666.           END; (* WHILE *)
  1667.         END; (* IF *)
  1668.         obj := obj.left
  1669.       END; (* WHILE *)
  1670.     END; (* IF *)
  1671.   END (* FOR *)
  1672. END AllocSlots;
  1673.  
  1674.  
  1675. (*------------------------------------*)
  1676. PROCEDURE OutCode * (FName : ARRAY OF CHAR; key, datasize : LONGINT);
  1677.  
  1678.   (* CONST pname = "OutCode"; *)
  1679.  
  1680.   VAR
  1681.     ObjFile : Files.File;
  1682.     out : Files.Rider;
  1683.     blockType, res, N : LONGINT;
  1684.     codeHunk : CodeHunk;
  1685.  
  1686.   (* ---------------------------------- *)
  1687.   PROCEDURE OutName (type : INTEGER; name : ARRAY OF CHAR);
  1688.  
  1689.     (* CONST pname = "OutName"; *)
  1690.  
  1691.     VAR len, char, pad : INTEGER;
  1692.  
  1693.   <*$CopyArrays-*>
  1694.   BEGIN (* OutName *)
  1695.     (* OCM.TraceIn (mname, pname); *)
  1696.     len := SHORT (SYS.STRLEN (name));
  1697.     pad := (((len + 3) DIV 4) * 4) - len;
  1698.     N := SYS.LSH (LONG (type), 24) + ((len + 3) DIV 4);
  1699.     Files.WriteBytes (out, N, 4);
  1700.     char := 0;
  1701.     WHILE char < len DO
  1702.       Files.Write (out, name [char]);
  1703.       INC (char);
  1704.     END; (* WHILE *)
  1705.     WHILE pad > 0 DO Files.Write (out, 0X); DEC (pad) END;
  1706.     (* ;OCM.TraceOut (mname, pname); *)
  1707.   END OutName;
  1708.  
  1709.   (* ---------------------------------- *)
  1710.   PROCEDURE OutHunkUnit ();
  1711.  
  1712.     (* CONST pname = "OutHunkUnit"; *)
  1713.  
  1714.   BEGIN (* OutHunkUnit *)
  1715.     (* OCM.TraceIn (mname, pname); *)
  1716.     blockType := hunkUnit;
  1717.     Files.WriteBytes (out, blockType, 4);
  1718.     OutName (0, OCT.ModuleName);
  1719.     (* ;OCM.TraceOut (mname, pname); *)
  1720.   END OutHunkUnit;
  1721.  
  1722.   (*------------------------------------*)
  1723.   PROCEDURE OutHunkName ();
  1724.  
  1725.     (* CONST pname = "OutHunkName"; *)
  1726.  
  1727.   BEGIN (* OutHunkName *)
  1728.     (* OCM.TraceIn (mname, pname); *)
  1729.     blockType := hunkName;
  1730.     Files.WriteBytes (out, blockType, 4);
  1731.     OutName (0, OCT.ModuleName);
  1732.     (* ;OCM.TraceOut (mname, pname); *)
  1733.   END OutHunkName;
  1734.  
  1735.   (*------------------------------------*)
  1736.   PROCEDURE OutDef0 (label : ARRAY OF CHAR; offset : LONGINT);
  1737.  
  1738.     (* CONST pname = "OutDef0"; *)
  1739.  
  1740.   <*$CopyArrays-*>
  1741.   BEGIN (* OutDef0 *)
  1742.     (* OCM.TraceIn (mname, pname); *)
  1743.     OutName (extDef, label);
  1744.     Files.WriteBytes (out, offset, 4)
  1745.     (* ;OCM.TraceOut (mname, pname); *)
  1746.   END OutDef0;
  1747.  
  1748.   (*------------------------------------*)
  1749.   PROCEDURE OutDef (def : Def);
  1750.  
  1751.     (* CONST pname = "OutDef"; *)
  1752.  
  1753.   BEGIN (* OutDef *)
  1754.     (* OCM.TraceIn (mname, pname); *)
  1755.     OutDef0 (def.object.label^, def.offset)
  1756.     (* ;OCM.TraceOut (mname, pname); *)
  1757.   END OutDef;
  1758.  
  1759.   (*------------------------------------*)
  1760.   PROCEDURE OutRef (ref : Ref);
  1761.  
  1762.     (* CONST pname = "OutRef"; *)
  1763.  
  1764.     VAR type : INTEGER; offset : Offset;
  1765.  
  1766.   BEGIN (* OutRef *)
  1767.     (* OCM.TraceIn (mname, pname); *)
  1768.     IF ref.size = 4 THEN type := extRef32
  1769.     ELSIF ref.size = 2 THEN type := extRef16
  1770.     (*ELSIF ref.size = 1 THEN type := extRef8*)
  1771.     ELSE OCS.Mark (959)
  1772.     END;
  1773.     OutName (type, ref.label^);
  1774.     Files.WriteBytes (out, ref.count, 4);
  1775.     offset := ref.offsets;
  1776.     WHILE offset # NIL DO
  1777.       Files.WriteBytes (out, offset.n, 4);
  1778.       offset := offset.next
  1779.     END
  1780.   (* ;OCM.TraceOut (mname, pname); *)
  1781.   END OutRef;
  1782.  
  1783.   (*------------------------------------*)
  1784.   PROCEDURE OutCodeHunk (codeHunk : CodeHunk);
  1785.  
  1786.     (* CONST pname = "OutCodeHunk"; *)
  1787.  
  1788.     (*------------------------------------*)
  1789.     PROCEDURE OutHunkCode ();
  1790.  
  1791.     (* CONST pname = "OutHunkCode"; *)
  1792.  
  1793.       VAR pos, len, pad : INTEGER;
  1794.  
  1795.     BEGIN (* OutHunkCode *)
  1796.       (* OCM.TraceIn (mname, pname); *)
  1797.       blockType := hunkCode;
  1798.       Files.WriteBytes (out, blockType, 4);
  1799.  
  1800.       N := (codeHunk.length + 1) DIV 2;
  1801.       Files.WriteBytes (out, N, 4);
  1802.  
  1803.       pos := codeHunk.start; len := codeHunk.length;
  1804.       WHILE len > 0 DO
  1805.         Files.WriteBytes (out, code [pos], 2);
  1806.         INC (pos); DEC (len);
  1807.       END; (* WHILE *)
  1808.  
  1809.       IF ODD (codeHunk.length) THEN
  1810.         pad := 04E71H; (* Output a NOP, purely for the benefit of ninfo *)
  1811.         Files.WriteBytes (out, pad, 2);
  1812.       END; (* IF *)
  1813.       (* ;OCM.TraceOut (mname, pname); *)
  1814.     END OutHunkCode;
  1815.  
  1816.     (*------------------------------------*)
  1817.     PROCEDURE OutHunkExt ();
  1818.  
  1819.       (* CONST pname = "OutHunkExt"; *)
  1820.  
  1821.       VAR ref : Ref; def : Def;
  1822.  
  1823.     BEGIN (* OutHunkExt *)
  1824.       (* OCM.TraceIn (mname, pname); *)
  1825.       blockType := hunkExt; Files.WriteBytes (out, blockType, 4);
  1826.       IF codeHunk = InitCodeHunk THEN OutDef0 (OCT.InitLabel^, 0) END;
  1827.       def := codeHunk.defs;
  1828.       WHILE def # NIL DO OutDef (def); def := def.next END;
  1829.       ref := codeHunk.refs;
  1830.       WHILE ref # NIL DO OutRef (ref); ref := ref.next END;
  1831.       N := 0; Files.WriteBytes (out, N, 4)
  1832.       (* ;OCM.TraceOut (mname, pname); *)
  1833.     END OutHunkExt;
  1834.  
  1835.     (*------------------------------------*)
  1836.     PROCEDURE OutHunkSymbol ();
  1837.  
  1838.       (* CONST pname = "OutHunkSymbol"; *)
  1839.  
  1840.       VAR
  1841.         def : Def; obj : OCT.Object;
  1842.         name, symbol : ARRAY 256 OF CHAR;
  1843.  
  1844.     BEGIN (* OutHunkSymbol *)
  1845.       (* OCM.TraceIn (mname, pname); *)
  1846.       IF OCM.Debug & ((codeHunk = InitCodeHunk) OR (codeHunk.defs # NIL)) THEN
  1847.         blockType := hunkSymbol; Files.WriteBytes (out, blockType, 4);
  1848.         IF codeHunk = InitCodeHunk THEN
  1849.           COPY (OCT.ModuleName, symbol); Str.Append ("_INIT-CODE", symbol);
  1850.           OutName (extSymb, symbol);
  1851.           N := 0; Files.WriteBytes (out, N, 4);
  1852.         END;
  1853.         def := codeHunk.defs;
  1854.         WHILE def # NIL DO
  1855.           obj := def.object;
  1856.           IF obj.mode = TProc THEN
  1857.             COPY (OCT.ModuleName, symbol); Str.Append ("_", symbol);
  1858.             OCT.GetName (obj.link.typ.strobj.name, name);
  1859.             Str.Append (name, symbol); Str.Append ("_", symbol);
  1860.             OCT.GetName (obj.name, name); Str.Append (name, symbol);
  1861.             OutName (extSymb, symbol)
  1862.           ELSIF obj.a0 = 0 THEN
  1863.             OutName (extSymb, obj.label^)
  1864.           ELSE
  1865.             COPY (obj.label^, symbol); Str.Append ("_", symbol);
  1866.             OCT.GetName (obj.name, name); Str.Append (name, symbol);
  1867.             OutName (extSymb, symbol)
  1868.           END;
  1869.           Files.WriteBytes (out, def.offset, 4);
  1870.           def := def.next
  1871.         END;
  1872.         N := 0; Files.WriteBytes (out, N, 4)
  1873.       END;
  1874.       (* OCM.TraceOut (mname, pname); *)
  1875.     END OutHunkSymbol;
  1876.  
  1877.   BEGIN (* OutCodeHunk *)
  1878.     (* OCM.TraceIn (mname, pname); *)
  1879.     OutHunkUnit ();
  1880.     OutHunkName ();
  1881.     OutHunkCode ();
  1882.     OutHunkExt ();
  1883.     OutHunkSymbol ();
  1884.     blockType := hunkEnd;
  1885.     Files.WriteBytes (out, blockType, 4);
  1886.     (* ;OCM.TraceOut (mname, pname); *)
  1887.   END OutCodeHunk;
  1888.  
  1889.   (*------------------------------------*)
  1890.   PROCEDURE OutConstants ();
  1891.  
  1892.     (* CONST pname = "OutConstants"; *)
  1893.  
  1894.     (*------------------------------------*)
  1895.     PROCEDURE OutHunkData ();
  1896.  
  1897.     (* CONST pname = "OutHunkData"; *)
  1898.  
  1899.       VAR pos, len , pad : INTEGER;
  1900.  
  1901.     BEGIN (* OutHunkData *)
  1902.       (* OCM.TraceIn (mname, pname); *)
  1903.       blockType := hunkData;
  1904.       Files.WriteBytes (out, blockType, 4);
  1905.  
  1906.       N := (conx + 3) DIV 4;
  1907.       Files.WriteBytes (out, N, 4);
  1908.  
  1909.       pos := 0; len := conx;
  1910.       WHILE pos < len DO
  1911.         Files.Write (out, constant [pos]);
  1912.         INC (pos);
  1913.       END; (* WHILE *)
  1914.  
  1915.       pad := (((len + 3) DIV 4) * 4) - len;
  1916.       WHILE pad > 0 DO
  1917.         Files.Write (out, 0X);
  1918.         DEC (pad);
  1919.       END; (* WHILE *)
  1920.       (* ;OCM.TraceOut (mname, pname); *)
  1921.     END OutHunkData;
  1922.  
  1923.     (*------------------------------------*)
  1924.     PROCEDURE OutHunkExt ();
  1925.  
  1926.     (* CONST pname = "OutHunkExt"; *)
  1927.  
  1928.       VAR ref : Ref;
  1929.  
  1930.     BEGIN (* OutHunkExt *)
  1931.       (* OCM.TraceIn (mname, pname); *)
  1932.       blockType := hunkExt;
  1933.       Files.WriteBytes (out, blockType, 4);
  1934.       OutDef0 (OCT.ConstLabel^, 0);
  1935.       N := 0;
  1936.       Files.WriteBytes (out, N, 4);
  1937.       (* ;OCM.TraceOut (mname, pname); *)
  1938.     END OutHunkExt;
  1939.  
  1940.     (*------------------------------------*)
  1941.     PROCEDURE OutHunkSymbol ();
  1942.  
  1943.       (* CONST pname = "OutHunkSymbol"; *)
  1944.  
  1945.     BEGIN (* OutHunkSymbol *)
  1946.       (* OCM.TraceIn (mname, pname); *)
  1947.       IF OCM.Debug THEN
  1948.         blockType := hunkSymbol;
  1949.         Files.WriteBytes (out, blockType, 4);
  1950.         OutName (extSymb, OCT.ConstLabel^);
  1951.         N := 0; Files.WriteBytes (out, N, 4);
  1952.         Files.WriteBytes (out, N, 4);
  1953.       END;
  1954.       (* ;OCM.TraceOut (mname, pname); *)
  1955.     END OutHunkSymbol;
  1956.  
  1957.   BEGIN (* OutConstants *)
  1958.     (* OCM.TraceIn (mname, pname); *)
  1959.     IF conx > 0 THEN
  1960.       OutHunkUnit ();
  1961.       OutHunkName ();
  1962.       OutHunkData ();
  1963.       OutHunkExt ();
  1964.       OutHunkSymbol ();
  1965.       blockType := hunkEnd;
  1966.       Files.WriteBytes (out, blockType, 4);
  1967.     END; (* IF *)
  1968.     (* ;OCM.TraceOut (mname, pname); *)
  1969.   END OutConstants;
  1970.  
  1971.   (*------------------------------------*)
  1972.   PROCEDURE FindPtrs
  1973.     ( typ : OCT.Struct; adr : LONGINT; VAR offset : LONGINT );
  1974.  
  1975.     (* CONST pname = "FindPtrs"; *)
  1976.  
  1977.     VAR btyp : OCT.Struct; fld : OCT.Object; i, n, s : LONGINT;
  1978.  
  1979.   BEGIN (* FindPtrs *)
  1980.     (* OCM.TraceIn (mname, pname); *)
  1981.     IF
  1982.       ((typ.form = Pointer) & (typ.sysflg = OberonFlag))
  1983.       OR (typ.form = PtrTyp)
  1984.     THEN
  1985.       Files.WriteBytes (out, adr, 4); DEC (offset, 4); INC (dataCount)
  1986.     ELSIF (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  1987.       btyp := typ.BaseTyp;
  1988.       IF btyp # NIL THEN FindPtrs (btyp, adr, offset) END;
  1989.       fld := typ.link;
  1990.       WHILE fld # NIL DO
  1991.         IF fld.mode = Fld THEN
  1992.           IF fld.name < 0 THEN (* Hidden pointer field *)
  1993.             n := fld.a0 + adr; Files.WriteBytes (out, n, 4);
  1994.             DEC (offset, 4); INC (dataCount)
  1995.           ELSE
  1996.             FindPtrs (fld.typ, fld.a0 + adr, offset)
  1997.           END
  1998.         END;
  1999.         fld := fld.left
  2000.       END;
  2001.     ELSIF typ.form = Array THEN
  2002.       btyp := typ.BaseTyp; n := typ.n;
  2003.       WHILE btyp.form = Array DO
  2004.         n := btyp.n * n; btyp := btyp.BaseTyp
  2005.       END;
  2006.       IF (btyp.form IN {Pointer, PtrTyp, Record}) THEN
  2007.         i := 0; s := btyp.size;
  2008.         WHILE i < n DO
  2009.           FindPtrs (btyp, i * s + adr, offset); INC (i)
  2010.         END
  2011.       END
  2012.     END
  2013.     (* ;OCM.TraceOut (mname, pname); *)
  2014.   END FindPtrs;
  2015.  
  2016.   (*------------------------------------*)
  2017.   PROCEDURE OutTypeDescs ();
  2018.  
  2019.     (* CONST pname = "OutTypeDescs"; *)
  2020.  
  2021.     VAR i : INTEGER; numProcs : LONGINT;
  2022.  
  2023.     (*------------------------------------*)
  2024.     PROCEDURE OutHunkData (typ : OCT.Struct);
  2025.  
  2026.     (* CONST pname = "OutHunkData"; *)
  2027.  
  2028.       VAR
  2029.         pos1, pos2, N, i, nameLen : LONGINT;
  2030.         name, objName : ARRAY 256 OF CHAR;
  2031.         ch : CHAR;
  2032.  
  2033.     BEGIN (* OutHunkData *)
  2034.       (* OCM.TraceIn (mname, pname); *)
  2035.       blockType := hunkData; Files.WriteBytes (out, blockType, 4);
  2036.       pos1 := Files.Pos (out);
  2037.       N := 0; Files.WriteBytes (out, N, 4);
  2038.       numProcs := NumProcs (typ); INC (dataCount, SHORT(numProcs));
  2039.       i := numProcs;
  2040.       WHILE i > 0 DO Files.WriteBytes (out, N, 4); DEC (i) END;
  2041.       N := typ.size; Files.WriteBytes (out, N, 4);
  2042.       i := 0; N := 0;
  2043.       WHILE i < 8 DO Files.WriteBytes (out, N, 4); INC (i) END;
  2044.       INC (dataCount, 9);
  2045.       N := -36; FindPtrs (typ, 0, N); Files.WriteBytes (out, N, 4);
  2046.       IF typ.strobj # NIL THEN
  2047.         COPY (OCT.ModuleName, name); nameLen := SYS.STRLEN (name);
  2048.         name [nameLen] := "."; INC (nameLen);
  2049.         OCT.GetName (typ.strobj.name, objName);
  2050.         i := 0;
  2051.         REPEAT
  2052.           ch := objName [i]; name [nameLen] := ch;
  2053.           INC (i); INC (nameLen)
  2054.         UNTIL ch = 0X
  2055.       ELSE
  2056.         name := ""; nameLen := 1
  2057.       END;
  2058.       FOR i := 0 TO nameLen - 1 DO
  2059.         Files.Write (out, name [i]);
  2060.       END;
  2061.       WHILE (nameLen MOD 4) # 0 DO
  2062.         Files.Write (out, 0X); INC (nameLen)
  2063.       END;
  2064.       INC (dataCount, SHORT (nameLen DIV 4));
  2065.       pos2 := Files.Pos (out);
  2066.       Files.Set (out, ObjFile, pos1);
  2067.       N := ((-N + nameLen) DIV 4) + numProcs + 1;
  2068.       Files.WriteBytes (out, N, 4);
  2069.       Files.Set (out, ObjFile, pos2);
  2070.       (* ;OCM.TraceOut (mname, pname); *)
  2071.     END OutHunkData;
  2072.  
  2073.     (*------------------------------------*)
  2074.     PROCEDURE OutHunkExt (typ : OCT.Struct);
  2075.  
  2076.     (* CONST pname = "OutHunkExt"; *)
  2077.  
  2078.       VAR N, i : LONGINT; lab : OCT.Label;
  2079.  
  2080.     BEGIN (* OutHunkExt *)
  2081.       (* OCM.TraceIn (mname, pname); *)
  2082.       N := hunkExt; Files.WriteBytes (out, N, 4);
  2083.       i := numProcs;
  2084.       WHILE i > 0 DO
  2085.         lab := ProcLab (typ, i); OutName (extRef32, lab^);
  2086.         N := 1; Files.WriteBytes (out, N, 4);
  2087.         N := (numProcs - i) * 4; Files.WriteBytes (out, N, 4);
  2088.         DEC (i)
  2089.       END;
  2090.       OutDef0 (typ.label^, numProcs * 4);
  2091.       IF typ.form = Record THEN
  2092.         WHILE (typ # NIL) & (typ.n >= 0) DO
  2093.           OutName (extRef32, typ.label^);
  2094.           N := 1; Files.WriteBytes (out, N, 4);
  2095.           N := (numProcs + typ.n + 1) * 4; Files.WriteBytes (out, N, 4);
  2096.           typ := typ.BaseTyp
  2097.         END;
  2098.       END;
  2099.       N := 0; Files.WriteBytes (out, N, 4)
  2100.       (* ;OCM.TraceOut (mname, pname); *)
  2101.     END OutHunkExt;
  2102.  
  2103.     (*------------------------------------*)
  2104.     PROCEDURE OutHunkSymbol (typ : OCT.Struct);
  2105.  
  2106.     (* CONST pname = "OutHunkSymbol"; *)
  2107.  
  2108.       VAR N, i : LONGINT; name, symbol : ARRAY 256 OF CHAR;
  2109.  
  2110.     BEGIN (* OutHunkSymbol *)
  2111.       (* OCM.TraceIn (mname, pname); *)
  2112.       IF OCM.Debug THEN
  2113.         N := hunkSymbol; Files.WriteBytes (out, N, 4);
  2114.         IF (typ.form = Record) & (typ.strobj # NIL) THEN
  2115.           COPY (OCT.ModuleName, symbol); Str.Append ("_", symbol);
  2116.           OCT.GetName (typ.strobj.name, name); Str.Append (name, symbol);
  2117.           OutName (extSymb, symbol)
  2118.         ELSE
  2119.           OutName (extSymb, typ.label^)
  2120.         END;
  2121.         N := numProcs * 4; Files.WriteBytes (out, N, 4);
  2122.         N := 0; Files.WriteBytes (out, N, 4)
  2123.       END;
  2124.       (* ;OCM.TraceOut (mname, pname); *)
  2125.     END OutHunkSymbol;
  2126.  
  2127.   BEGIN (* OutTypeDescs *)
  2128.     (* OCM.TraceIn (mname, pname); *)
  2129.     dataCount := 0;
  2130.     IF typex > 0 THEN
  2131.       i := 0;
  2132.       WHILE i < typex DO
  2133.         OutHunkUnit ();
  2134.         OutHunkName ();
  2135.         OutHunkData (type [i]);
  2136.         OutHunkExt (type [i]);
  2137.         OutHunkSymbol (type [i]);
  2138.         blockType := hunkEnd;
  2139.         Files.WriteBytes (out, blockType, 4);
  2140.         INC (i)
  2141.       END
  2142.     END
  2143.     (* ;OCM.TraceOut (mname, pname); *)
  2144.   END OutTypeDescs;
  2145.  
  2146.   (*------------------------------------*)
  2147.   PROCEDURE OutGC ();
  2148.  
  2149.     (* CONST pname = "OutGC"; *)
  2150.  
  2151.     VAR i : INTEGER;
  2152.  
  2153.     (*------------------------------------*)
  2154.     PROCEDURE OutHunkData ();
  2155.  
  2156.     (* CONST pname = "OutHunkData"; *)
  2157.  
  2158.       VAR i, N : LONGINT; obj : OCT.Object;
  2159.  
  2160.     BEGIN (* OutHunkData *)
  2161.       (* OCM.TraceIn (mname, pname); *)
  2162.       N := hunkData; Files.WriteBytes (out, N, 4);
  2163.       N := numPtrs + 3; Files.WriteBytes (out, N, 4);
  2164.       N := 0; Files.WriteBytes (out, N, 4); Files.WriteBytes (out, N, 4);
  2165.       N := -8; obj := OCT.topScope.right;
  2166.       WHILE obj # NIL DO
  2167.         IF obj.mode = Var THEN FindPtrs (obj.typ, obj.a0, N) END;
  2168.         obj := obj.link
  2169.       END;
  2170.       Files.WriteBytes (out, N, 4);
  2171.       (* ;OCM.TraceOut (mname, pname); *)
  2172.     END OutHunkData;
  2173.  
  2174.     (*------------------------------------*)
  2175.     PROCEDURE OutHunkExt ();
  2176.  
  2177.     (* CONST pname = "OutHunkExt"; *)
  2178.  
  2179.       VAR N : LONGINT;
  2180.  
  2181.     BEGIN (* OutHunkExt *)
  2182.       (* OCM.TraceIn (mname, pname); *)
  2183.       N := hunkExt; Files.WriteBytes (out, N, 4);
  2184.       OutDef0 (OCT.GCLabel^, 0);
  2185.       OutName (extRef32, OCT.VarLabel^);
  2186.       N := 1; Files.WriteBytes (out, N, 4);
  2187.       N := 4; Files.WriteBytes (out, N, 4);
  2188.       N := 0; Files.WriteBytes (out, N, 4)
  2189.       (* ;OCM.TraceOut (mname, pname); *)
  2190.     END OutHunkExt;
  2191.  
  2192.     (*------------------------------------*)
  2193.     PROCEDURE OutHunkSymbol ();
  2194.  
  2195.       (* CONST pname = "OutHunkSymbol"; *)
  2196.  
  2197.     BEGIN (* OutHunkSymbol *)
  2198.       (* OCM.TraceIn (mname, pname); *)
  2199.       IF OCM.Debug THEN
  2200.         blockType := hunkSymbol; Files.WriteBytes (out, blockType, 4);
  2201.         OutName (extSymb, OCT.GCLabel^);
  2202.         N := 0; Files.WriteBytes (out, N, 4);
  2203.         Files.WriteBytes (out, N, 4);
  2204.       END;
  2205.       (* ;OCM.TraceOut (mname, pname); *)
  2206.     END OutHunkSymbol;
  2207.  
  2208.   BEGIN (* OutGC *)
  2209.     (* OCM.TraceIn (mname, pname); *)
  2210.     IF numPtrs > 0 THEN
  2211.       OutHunkUnit ();
  2212.       OutHunkName ();
  2213.       OutHunkData ();
  2214.       OutHunkExt ();
  2215.       OutHunkSymbol ();
  2216.       blockType := hunkEnd;
  2217.       Files.WriteBytes (out, blockType, 4);
  2218.     END
  2219.     (* ;OCM.TraceOut (mname, pname); *)
  2220.   END OutGC;
  2221.  
  2222.   (*------------------------------------*)
  2223.   PROCEDURE OutVars ();
  2224.  
  2225.     (* CONST pname = "OutVars"; *)
  2226.  
  2227.   BEGIN (* OutVars *)
  2228.     (* OCM.TraceIn (mname, pname); *)
  2229.     OutHunkUnit ();
  2230.     OutHunkName ();
  2231.  
  2232.     blockType := hunkBSS;
  2233.     Files.WriteBytes (out, blockType, 4);
  2234.  
  2235.     N := (datasize + 3) DIV 4;
  2236.     Files.WriteBytes (out, N, 4);
  2237.  
  2238.     blockType := hunkExt;
  2239.     Files.WriteBytes (out, blockType, 4);
  2240.     OutDef0 (OCT.VarLabel^, 0);
  2241.     N := 0; Files.WriteBytes (out, N, 4);
  2242.  
  2243.     IF OCM.Debug THEN
  2244.       blockType := hunkSymbol; Files.WriteBytes (out, blockType, 4);
  2245.       OutName (extSymb, OCT.VarLabel^);
  2246.       N := 0; Files.WriteBytes (out, N, 4);
  2247.       Files.WriteBytes (out, N, 4);
  2248.     END;
  2249.  
  2250.     blockType := hunkEnd;
  2251.     Files.WriteBytes (out, blockType, 4);
  2252.     (* ;OCM.TraceOut (mname, pname); *)
  2253.   END OutVars;
  2254.  
  2255. <*$CopyArrays-*>
  2256. BEGIN (* OutCode *)
  2257.   (* OCM.TraceIn (mname, pname); *)
  2258.   IF OCM.Force OR ~OCS.scanerr THEN
  2259.     ObjFile := Files.New (FName);
  2260.     IF ObjFile # NIL THEN
  2261.       Files.Set (out, ObjFile, 0);
  2262.  
  2263.       codeHunk := FirstCodeHunk;
  2264.       WHILE codeHunk # NIL DO
  2265.         OutCodeHunk (codeHunk);
  2266.         codeHunk := codeHunk.next;
  2267.       END; (* WHILE *)
  2268.       OutConstants ();
  2269.       OutTypeDescs ();
  2270.       OutGC ();
  2271.       OutVars ();
  2272.  
  2273.       Files.Set (out, NIL, 0); Files.Register (ObjFile);
  2274.       OCM.MakeIcon (FName, OCM.iconObj)
  2275.     ELSE
  2276.       OCS.Mark (153)
  2277.     END
  2278.   END;
  2279.   (* ;OCM.TraceOut (mname, pname); *)
  2280. END OutCode;
  2281.  
  2282. (*------------------------------------*)
  2283. PROCEDURE DataSize * () : LONGINT;
  2284.  
  2285.   (* CONST pname = "DataSize"; *)
  2286.  
  2287.   VAR size : LONGINT;
  2288.  
  2289. BEGIN (* DataSize *)
  2290.   (* OCM.TraceIn (mname, pname); *)
  2291.   size := dataCount * 4 + conx;
  2292.   (* ;OCM.TraceOut (mname, pname); *)
  2293.   RETURN size;
  2294. END DataSize;
  2295.  
  2296. BEGIN (* OCC *)
  2297.   FirstCodeHunk := NIL; CurrCodeHunk := NIL; InitCodeHunk := NIL;
  2298.   Prologue := NIL; NEW (wasderef);
  2299.  
  2300.   FOR i := 0 TO (numKProcs - 1) DO NEW (kernelLab [i], 20) END;
  2301.   COPY ("Kernel_Halt", kernelLab [kHalt]^);
  2302.   COPY ("Kernel_NewRecord", kernelLab [kNewRecord]^);
  2303.   COPY ("Kernel_NewArray", kernelLab [kNewArray]^);
  2304.   COPY ("Kernel_NewSysBlk", kernelLab [kNewSysBlk]^);
  2305.   COPY ("Kernel_Dispose", kernelLab [kDispose]^);
  2306.   COPY ("Kernel_InitGC", kernelLab [kInitGC]^);
  2307.   COPY ("Kernel_Move", kernelLab [kMove]^);
  2308.   COPY ("Kernel_StackChk", kernelLab [kStackChk]^);
  2309.   COPY ("Kernel_Mul32", kernelLab [kMul32]^);
  2310.   COPY ("Kernel_Div32", kernelLab [kDiv32]^);
  2311.   COPY ("Kernel_SPFix", kernelLab [kSPFix]^);
  2312.   COPY ("Kernel_SPFlt", kernelLab [kSPFlt]^);
  2313.   COPY ("Kernel_SPCmp", kernelLab [kSPCmp]^);
  2314.   COPY ("Kernel_SPTst", kernelLab [kSPTst]^);
  2315.   COPY ("Kernel_SPNeg", kernelLab [kSPNeg]^);
  2316.   COPY ("Kernel_SPAdd", kernelLab [kSPAdd]^);
  2317.   COPY ("Kernel_SPSub", kernelLab [kSPSub]^);
  2318.   COPY ("Kernel_SPMul", kernelLab [kSPMul]^);
  2319.   COPY ("Kernel_SPDiv", kernelLab [kSPDiv]^);
  2320.   COPY ("Kernel_SPAbs", kernelLab [kSPAbs]^);
  2321.   COPY ("Kernel_END", kernelLab [kEnd]^);
  2322. END OCC.
  2323.  
  2324. (*************************************************************************
  2325.  
  2326.   $Log: OCC.mod $
  2327.   Revision 5.11  1995/01/26  00:17:17  fjc
  2328.   - Release 1.5
  2329.  
  2330.   Revision 5.10  1995/01/09  13:54:08  fjc
  2331.   - Added call to OCM.MakeIcon().
  2332.  
  2333.   Revision 5.9  1995/01/05  11:32:29  fjc
  2334.   - Changed to force output of object files if OCM.Force is TRUE.
  2335.  
  2336.   Revision 5.8  1995/01/03  21:16:57  fjc
  2337.   - Changed OCG to OCM.
  2338.  
  2339.   Revision 5.7  1994/12/16  17:15:03  fjc
  2340.   - Changed to accomodate renaming OCT.Symbol to OCT.Label.
  2341.   - Added AllocSlots() to fix a serious bug that caused the
  2342.     wrong slots to be allocated for type-bound procedures.
  2343.   - Symbols output in object file are now different to the
  2344.     corresponding linker labels in some cases.
  2345.  
  2346.   Revision 5.6  1994/11/13  11:23:46  fjc
  2347.   - Added kSPAbs.
  2348.  
  2349.   Revision 5.5  1994/10/23  15:51:42  fjc
  2350.   - Added kernelLab array and CallKernel().
  2351.   - Fixed bug that made SYSTEM.PTR variables untraced.
  2352.  
  2353.   Revision 5.4  1994/09/25  17:43:15  fjc
  2354.   - Changed to reflect new object modes and system flags.
  2355.  
  2356.   Revision 5.3  1994/09/15  10:24:29  fjc
  2357.   - Replaced switches with pragmas.
  2358.  
  2359.   Revision 5.2  1994/09/08  10:47:13  fjc
  2360.   - Changed to use pragmas/options.
  2361.  
  2362.   Revision 5.1  1994/09/03  19:29:08  fjc
  2363.   - Bumped version number
  2364.  
  2365. *************************************************************************)
  2366.