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