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