home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 2 / goldfish_vol2_cd1.bin / files / dev / obero / oberon-a / source / oc / oce.mod < prev    next >
Text File  |  1994-08-08  |  51KB  |  1,582 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: OCE.mod $
  4.   Description: Code selection for expressions
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 4.8 $
  8.       $Author: fjc $
  9.         $Date: 1994/08/03 11:42:47 $
  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 OCE;
  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 OCG, OCS, OCT, OCC, OCI, SYS := SYSTEM;
  29.  
  30.  
  31. (* --- Local declarations ----------------------------------------------- *)
  32.  
  33. CONST
  34.  
  35.   (* Symbols *)
  36.  
  37.   null = OCS.null; times = OCS.times; slash = OCS.slash; div   = OCS.div;
  38.   mod  = OCS.mod;  and   = OCS.and;   plus  = OCS.plus;  minus = OCS.minus;
  39.   or   = OCS.or;   eql   = OCS.eql;   neq   = OCS.neq;   lss   = OCS.lss;
  40.   leq  = OCS.leq;  gtr   = OCS.gtr;   geq   = OCS.geq;   not   = OCS.not;
  41.  
  42.   (* object modes *)
  43.   Var = OCG.Var; VarX = OCG.VarX; VarR = OCG.VarR; Ind = OCG.Ind;
  44.   IndX = OCG.IndX; IndR = OCG.IndR; RegI = OCG.RegI; RegX = OCG.RegX;
  45.   Lab = OCG.Lab; LabI = OCG.LabI; Con = OCG.Con; Push = OCG.Push;
  46.   Pop = OCG.Pop; Coc = OCG.Coc; Reg = OCG.Reg; Fld = OCG.Fld;
  47.   Typ = OCG.Typ; Abs = OCG.Abs; XProc = OCG.XProc; RList = OCG.RList;
  48.  
  49.   (* structure forms *)
  50.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  51.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  52.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  53.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  54.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  55.   Record = OCT.Record; PtrTyp = OCT.PtrTyp; CPtrTyp = OCT.CPtrTyp;
  56.   BPtrTyp = OCT.BPtrTyp; BPointer = OCT.BPointer; CPointer = OCT.CPointer;
  57.   BSet = OCT.BSet; WSet = OCT.WSet; Word = OCT.Word;
  58.   Longword = OCT.Longword; TagTyp = OCT.TagTyp;
  59.  
  60.   intSet   = {SInt, Int, LInt};
  61.   realSet  = {Real, LReal};
  62.   setSet   = {BSet, WSet, Set};
  63.   ptrSet   = {Pointer, CPointer, BPointer, PtrTyp, CPtrTyp, BPtrTyp};
  64.   uptrSet  = {CPointer, BPointer, CPtrTyp, BPtrTyp};
  65.   allSet   = {0 .. 31};
  66.   adrSet   = {LInt, Pointer, PtrTyp, CPointer, CPtrTyp, Longword};
  67.  
  68.   (* CPU Registers *)
  69.  
  70.   D0 = 0; D1 = 1; D7 = 7; A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  71.   A6 = 14; A7 = 15; BP = A4; FP = A5; SP = A7;
  72.   DataRegs = {D0 .. D7};
  73.   AdrRegs = {A0 .. A7};
  74.  
  75.   (* Data sizes *)
  76.  
  77.   B = 1; W = 2; L = 4;
  78.  
  79.   (* mathffp.library function offsets *)
  80.  
  81.   SPFix = -30; SPFlt = -36; SPCmp = -42; SPTst = -48; SPAbs = -54;
  82.   SPNeg = -60; SPAdd = -66; SPSub = -72; SPMul = -78; SPDiv = -84;
  83.   SPFloor = -90; SPCeil = -96;
  84.  
  85. VAR
  86.   log : LONGINT; (* side effect of mant () *)
  87.  
  88. (* CONST mname = "OCE"; *)
  89.  
  90. (* --- Procedure declarations ------------------------------------------- *)
  91.  
  92. PROCEDURE^ Op *
  93.   (op : INTEGER; VAR lhs, rhs : OCT.Item; freeRegs : BOOLEAN);
  94.  
  95. (*------------------------------------*)
  96. PROCEDURE mant (x : LONGINT) : LONGINT; (* x DIV 2 ^ log *)
  97.  
  98. BEGIN (* mant *)
  99.   log := 0;
  100.   IF x > 0 THEN WHILE ~ODD (x) DO x := x DIV 2; INC (log) END END;
  101.   RETURN x
  102. END mant;
  103.  
  104. (*------------------------------------*)
  105. PROCEDURE MultiplyInts (
  106.   VAR lhs, rhs : OCT.Item; size : LONGINT; freeRegs : BOOLEAN);
  107.  
  108.   (* CONST pname = "MultiplyInts"; *)
  109.  
  110.   VAR mul : OCT.Item; R : SET;
  111.  
  112. BEGIN (* MultiplyInts *)
  113.   (* OCG.TraceIn (mname, pname); *)
  114.   IF (lhs.mode = Con) & (mant (lhs.a0) = 1) THEN
  115.     IF log = 1 THEN
  116.       OCI.Load (rhs); OCC.PutF5 (OCC.ADD, size, rhs, rhs)
  117.     ELSIF log # 0 THEN
  118.       lhs.a0 := log; lhs.typ := OCT.sinttyp;
  119.       IF log > 8 THEN OCI.Load (lhs) END;
  120.       OCI.Load (rhs); OCC.Shift (OCC.ASL, size, lhs, rhs);
  121.       IF log > 8 THEN OCC.FreeReg (lhs) END;
  122.     END;
  123.     lhs := rhs; rhs.mode := Undef
  124.   ELSIF (rhs.mode = Con) & (mant (rhs.a0) = 1) THEN
  125.     IF log = 1 THEN
  126.       OCI.Load (lhs); OCC.PutF5 (OCC.ADD, size, lhs, lhs)
  127.     ELSIF log # 0 THEN
  128.       rhs.a0 := log; rhs.typ := OCT.sinttyp;
  129.       IF log > 8 THEN OCI.Load (rhs) END;
  130.       OCI.Load (lhs); OCC.Shift (OCC.ASL, size, rhs, lhs)
  131.     END
  132.   ELSE
  133.     IF size = OCG.LIntSize THEN
  134.       mul.mode := Lab; mul.a0 := 0; mul.a1 := 4;
  135.       mul.symbol := OCT.OberonSysMUL;
  136.       OCC.LoadRegParams2 (R, lhs, rhs);
  137.       OCC.PutF3 (OCC.JSR, mul);
  138.       OCC.RestoreRegisters (R, lhs);
  139.     ELSE
  140.       OCI.Load (lhs); OCC.PutF2 (OCC.MULS, rhs, lhs.a0)
  141.     END
  142.   END;
  143.   IF freeRegs THEN OCI.Unload (rhs) END
  144.   (* ;OCG.TraceOut (mname, pname); *)
  145. END MultiplyInts;
  146.  
  147. (*------------------------------------*)
  148. PROCEDURE DivideInts (
  149.   VAR lhs, rhs : OCT.Item; size : LONGINT; freeRegs : BOOLEAN);
  150.  
  151.   (* CONST pname = "DivideInts"; *)
  152.  
  153.   VAR div : OCT.Item; R : SET;
  154.  
  155. BEGIN (* DivideInts *)
  156.   (* OCG.TraceIn (mname, pname); *)
  157.   IF (rhs.mode = Con) & (mant (rhs.a0) = 1) THEN
  158.     rhs.a0 := log; rhs.typ := OCT.sinttyp;
  159.     IF log > 8 THEN OCI.Load (rhs) END;
  160.     OCI.Load (lhs);
  161.     OCC.Shift (OCC.ASR, size, rhs, lhs);
  162.   ELSE
  163.     IF size = OCG.LIntSize THEN
  164.       div.mode := Lab; div.a0 := 0; div.a1 := 4;
  165.       div.symbol := OCT.OberonSysDIV;
  166.       OCC.LoadRegParams2 (R, lhs, rhs);
  167.       OCC.PutF3 (OCC.JSR, div);
  168.       OCC.RestoreRegisters (R, lhs);
  169.     ELSE
  170.       OCI.Load (lhs);
  171.       IF lhs.typ^.form = OCT.SInt THEN OCI.EXT (W, lhs.a0) END;
  172.       OCI.EXT (L, lhs.a0);
  173.       IF rhs.typ^.form = OCT.SInt THEN
  174.         OCI.Load (rhs); OCI.EXT (W, rhs.a0)
  175.       END;
  176.       OCC.PutF2 (OCC.DIVS, rhs, lhs.a0);
  177.       (*IF OCS.overflowCheck THEN OCC.OutOp0 (TRAPV) END;*)
  178.     END
  179.   END;
  180.   IF freeRegs THEN OCI.Unload (rhs) END;
  181.   (* ;OCG.TraceOut (mname, pname); *)
  182. END DivideInts;
  183.  
  184. (*------------------------------------*)
  185. PROCEDURE ModulusInts (
  186.   VAR lhs, rhs : OCT.Item; size : LONGINT; freeRegs : BOOLEAN);
  187.  
  188.   (* CONST pname = "ModulusInts"; *)
  189.  
  190.   VAR mod : OCT.Item; R : SET;
  191.  
  192. BEGIN (* ModulusInts *)
  193.   (* OCG.TraceIn (mname, pname); *)
  194.   IF (rhs.mode = Con) & (mant (rhs.a0) = 1) THEN
  195.     rhs.a0 := ASH (1, log) - 1; OCI.Load (lhs);
  196.     OCC.PutF6 (OCC.ANDI, size, rhs, lhs)
  197.   ELSE
  198.     IF size = OCG.LIntSize THEN
  199.       mod.mode := Lab; mod.a0 := 0; mod.a1 := 4;
  200.       mod.symbol := OCT.OberonSysMOD;
  201.       OCC.LoadRegParams2 (R, lhs, rhs);
  202.       OCC.PutF3 (OCC.JSR, mod);
  203.       OCC.RestoreRegisters (R, lhs)
  204.     ELSE
  205.       OCI.Load (lhs);
  206.       IF lhs.typ^.form = OCT.SInt THEN OCI.EXT (W, lhs.a0) END;
  207.       OCI.EXT (L, lhs.a0);
  208.       IF rhs.typ^.form = OCT.SInt THEN
  209.         OCI.Load (rhs); OCI.EXT (L, rhs.a0)
  210.       END;
  211.       OCC.PutF2 (OCC.DIVS, rhs, lhs.a0);
  212.       OCC.PutWord (OCC.SWAP + SHORT (lhs.a0))
  213.     END
  214.   END;
  215.   IF freeRegs THEN OCI.Unload (rhs) END
  216.   (* ;OCG.TraceOut (mname, pname); *)
  217. END ModulusInts;
  218.  
  219. (*------------------------------------*)
  220. PROCEDURE ConvertInts * (VAR x : OCT.Item; typ : OCT.Struct);
  221.  
  222.   (* CONST pname = "ConvertInts"; *)
  223.  
  224. BEGIN (* ConvertInts *)
  225.   (* OCG.TraceIn (mname, pname); *)
  226.   IF x.mode # Con THEN
  227.     OCI.Load (x);
  228.     IF (typ.form = LInt) & (x.typ.form = SInt) THEN OCI.EXT (W, x.a0) END;
  229.     OCI.EXT (typ.size, x.a0)
  230.   END;
  231.   x.typ := typ
  232.   (* ;OCG.TraceOut (mname, pname); *)
  233. END ConvertInts;
  234.  
  235.  
  236. (*------------------------------------*)
  237. PROCEDURE RealMath (op : INTEGER; VAR lhs, rhs : OCT.Item);
  238.  
  239.   (* CONST pname = "RealMath"; *)
  240.  
  241.   VAR base, br : OCT.Item; R : SET;
  242.  
  243. BEGIN (* RealMath *)
  244.   (* OCG.TraceIn (mname, pname); *)
  245.   base.mode := Lab; base.a0 := OCT.mathBase; base.a1 := 4;
  246.   base.symbol := OCT.OberonSysVAR; br.mode := Reg; br.a0 := A6;
  247.   OCC.LoadRegParams2 (R, lhs, rhs);
  248.   OCC.Move (L, base, br); br.mode := RegI;
  249.   CASE op OF
  250.     times : br.a1 := SPMul | slash : br.a1 := SPDiv |
  251.     plus  : br.a1 := SPAdd | minus : br.a1 := SPSub
  252.   ELSE
  253.     OCS.Mark (1009); OCS.Mark (op)
  254.   END;
  255.   OCC.PutF3 (OCC.JSR, br); OCC.RestoreRegisters (R, lhs)
  256.   (* ;OCG.TraceOut (mname, pname); *)
  257. END RealMath;
  258.  
  259. (*------------------------------------*)
  260. PROCEDURE CmpReals (VAR lhs, rhs : OCT.Item);
  261.  
  262.   (* CONST pname = "CmpReals"; *)
  263.  
  264.   VAR base, br : OCT.Item; R : SET; op : INTEGER;
  265.  
  266. BEGIN (* CmpReals *)
  267.   (* OCG.TraceIn (mname, pname); *)
  268.   base.mode := Lab; base.a0 := OCT.mathBase; base.a1 := 4;
  269.   base.symbol := OCT.OberonSysVAR;
  270.   br.mode := Reg; br.a0 := A6;
  271.   (*IF (rhs.mode = Con) & (rhs.a0 = 0) THEN
  272.     OCC.LoadRegParams1 (R, lhs); op := SPTst
  273.   ELSE*)
  274.     OCC.LoadRegParams2 (R, lhs, rhs); op := SPCmp;
  275.   (*END;*)
  276.   OCC.Move (L, base, br); br.mode := RegI; br.a1 := op;
  277.   OCC.PutF3 (OCC.JSR, br);
  278.   OCC.RestoreRegisters (R, lhs)
  279.   (* ;OCG.TraceOut (mname, pname); *)
  280. END CmpReals;
  281.  
  282. (*------------------------------------*)
  283. PROCEDURE ConvertReals (VAR x : OCT.Item; typ : OCT.Struct);
  284.  
  285.   (* CONST pname = "ConvertReals"; *)
  286.  
  287.   VAR r0, base, br : OCT.Item; R : SET; f : INTEGER;
  288.  
  289. BEGIN (* ConvertReals *)
  290.   (* OCG.TraceIn (mname, pname); *)
  291.   f := x.typ.form;
  292.   IF f IN intSet THEN
  293.     IF x.mode = Con THEN x.typ := OCT.linttyp; f := LInt END;
  294.     r0.mode := Reg; r0.a0 := D0; br.mode := Reg; br.a0 := A6;
  295.     base.mode := Lab; base.a0 := OCT.mathBase; base.a1 := 4;
  296.     base.symbol := OCT.OberonSysVAR;
  297.     OCC.LoadRegParams1 (R, x);
  298.     IF f = SInt THEN OCI.EXT (W, r0.a0); f := Int END;
  299.     IF f = Int THEN OCI.EXT (L, r0.a0) END;
  300.     OCC.Move (L, base, br);
  301.     br.mode := RegI; br.a1 := SPFlt; OCC.PutF3 (OCC.JSR, br);
  302.     OCC.RestoreRegisters (R, x)
  303.   END;
  304.   x.typ := typ
  305.   (* ;OCG.TraceOut (mname, pname); *)
  306. END ConvertReals;
  307.  
  308. (*------------------------------------*)
  309. PROCEDURE NegReal (VAR x : OCT.Item);
  310.  
  311.   (* CONST pname = "NegReal"; *)
  312.  
  313.   VAR base, br : OCT.Item; R : SET;
  314.  
  315. BEGIN (* NegReal *)
  316.   (* OCG.TraceIn (mname, pname); *)
  317.   br.mode := Reg; br.a0 := A6;
  318.   base.mode := Lab; base.a0 := OCT.mathBase; base.a1 := 4;
  319.   base.symbol := OCT.OberonSysVAR;
  320.   OCC.LoadRegParams1 (R, x);
  321.   OCC.Move (L, base, br);
  322.   br.mode := RegI; br.a1 := SPNeg;
  323.   OCC.PutF3 (OCC.JSR, br);
  324.   OCC.RestoreRegisters (R, x)
  325.   (* ;OCG.TraceOut (mname, pname); *)
  326. END NegReal;
  327.  
  328. (*------------------------------------*)
  329. PROCEDURE loadB (VAR x : OCT.Item); (* Coc-Mode *)
  330.  
  331.   (* CONST pname = "loadB"; *)
  332.  
  333.   VAR op, L0 : INTEGER;
  334.  
  335. BEGIN (* loadB *)
  336.   (* OCG.TraceIn (mname, pname); *)
  337.   IF ((x.a1 = 0) & (x.a2 = 0)) OR (x.a0 IN {OCC.T, OCC.F}) THEN
  338.     op := OCC.Scc + (SHORT (x.a0) * 100H);
  339.     OCC.GetDReg (x); OCC.PutF3 (op, x)                       (*    Scc Dn *)
  340.   ELSE
  341.     op := OCC.Bcc + (OCC.invertedCC (x.a0) * 100H);
  342.     OCC.PutWord (op); OCC.PutWord (x.a2);                    (*    Bcc 1$ *)
  343.     L0 := OCC.pc - 2; OCC.FixLink (x.a1);
  344.     OCC.GetDReg (x); OCC.PutF3 (OCC.ST, x);                  (*    ST  Dn *)
  345.     OCC.PutWord (6002H);                                     (*    BRA 2$ *)
  346.     OCC.FixLink (L0); OCC.PutF3 (OCC.SF, x);                 (* 1$ SF  Dn *)
  347.   END                                                        (* 2$        *)
  348.   (* ;OCG.TraceOut (mname, pname); *)
  349. END loadB;
  350.  
  351. (*------------------------------------*)
  352. PROCEDURE setCC * (VAR x: OCT.Item; cc : LONGINT);
  353.  
  354. BEGIN (* setCC *)
  355.   x.typ := OCT.booltyp; x.mode := Coc; x.a0 := cc; x.a1 := 0; x.a2 := 0
  356. END setCC;
  357.  
  358. (*------------------------------------*)
  359. PROCEDURE cmp (VAR lhs, rhs : OCT.Item; freeX : BOOLEAN);
  360.  
  361.   (* CONST pname = "cmp"; *)
  362.  
  363.   VAR size : LONGINT;
  364.  
  365. BEGIN (* cmp *)
  366.   (* OCG.TraceIn (mname, pname); *)
  367.   size := lhs.typ.size; IF size > L THEN size := L END;
  368.   IF rhs.mode = Con THEN
  369.     IF lhs.mode = Con THEN OCI.Load (lhs)
  370.     ELSIF lhs.mode = Coc THEN loadB (lhs)
  371.     END;
  372.     IF rhs.a0 = 0 THEN OCC.PutF1 (OCC.TST, size, lhs)
  373.     ELSE OCC.PutF6 (OCC.CMPI, size, rhs, lhs)
  374.     END
  375.   ELSE
  376.     IF lhs.mode = Coc THEN loadB (lhs)
  377.     ELSE OCI.Load (lhs)
  378.     END;
  379.     OCC.PutF5 (OCC.CMP, size, rhs, lhs);
  380.   END;
  381.   IF freeX THEN OCI.Unload (lhs) END
  382.   (* ;OCG.TraceOut (mname, pname); *)
  383. END cmp;
  384.  
  385. (*------------------------------------*)
  386. PROCEDURE test (VAR x : OCT.Item);
  387.  
  388.   (* CONST pname = "test"; *)
  389.  
  390. BEGIN (* test *)
  391.   (* OCG.TraceIn (mname, pname); *)
  392.   OCC.PutF1 (OCC.TST, x.typ.size, x); OCI.Unload (x); setCC (x, OCC.NE)
  393.   (* ;OCG.TraceOut (mname, pname); *)
  394. END test;
  395.  
  396. (*------------------------------------*)
  397. PROCEDURE SetIntType * (VAR x : OCT.Item);
  398.  
  399.   (* CONST pname = "SetIntType"; *)
  400.  
  401.   VAR v : LONGINT;
  402.  
  403. BEGIN (* SetIntType *)
  404.   (* OCG.TraceIn (mname, pname); *)
  405.   v := x.a0;
  406.   IF (LONG (OCG.MinSInt) <= v) & (v <= LONG (OCG.MaxSInt)) THEN
  407.     x.typ := OCT.sinttyp
  408.   ELSIF (LONG (OCG.MinInt) <= v) & (v <= LONG (OCG.MaxInt)) THEN
  409.     x.typ := OCT.inttyp
  410.   ELSE
  411.     x.typ := OCT.linttyp
  412.   END;
  413.   (* ;OCG.TraceOut (mname, pname); *)
  414. END SetIntType;
  415.  
  416. (*------------------------------------*)
  417. PROCEDURE SetSetType (VAR x : OCT.Item);
  418.  
  419.   (* CONST pname = "SetSetType"; *)
  420.  
  421.   VAR s : SET;
  422.  
  423. BEGIN (* SetSetType *)
  424.   (* OCG.TraceIn (mname, pname); *)
  425.   s := SYS.VAL (SET, x.a0);
  426.   IF (s - {OCG.MinSet .. OCG.MaxBSet}) = {} THEN
  427.     x.typ := OCT.bsettyp
  428.   ELSIF (s - {OCG.MinSet .. OCG.MaxWSet}) = {} THEN
  429.     x.typ := OCT.wsettyp
  430.   ELSE
  431.     x.typ := OCT.settyp
  432.   END
  433.   (* ;OCG.TraceOut (mname, pname); *)
  434. END SetSetType;
  435.  
  436. (*------------------------------------*)
  437. PROCEDURE AssReal * (VAR x : OCT.Item; y : REAL);
  438.  
  439. BEGIN (* AssReal *)
  440.   SYS.PUT (SYS.ADR (x.a0), y)
  441. END AssReal;
  442.  
  443. (*------------------------------------*)
  444. PROCEDURE AssLReal * (VAR x : OCT.Item; y : LONGREAL);
  445.  
  446. BEGIN (* AssLReal *)
  447.   SYS.PUT (SYS.ADR (x.a0), y)
  448. END AssLReal;
  449.  
  450. (*------------------------------------*)
  451. PROCEDURE TrapLink (n, cc, L : INTEGER);
  452.  
  453.   (* CONST pname = "TrapLink"; *)
  454.  
  455. BEGIN (* TrapLink *)
  456.   (* OCG.TraceIn (mname, pname); *)
  457.   OCC.TrapCC (n, cc); OCC.FixupWith (L, OCC.pc - 2 - L)
  458.   (* ;OCG.TraceOut (mname, pname); *)
  459. END TrapLink;
  460.  
  461. (*------------------------------------*)
  462. PROCEDURE Index * (VAR x, y : OCT.Item);
  463.  
  464.   (* CONST pname = "Index"; *)
  465.  
  466.   VAR
  467.     f, m, n, r, L0 : INTEGER; i : LONGINT;
  468.     eltyp : OCT.Struct; br, y1, z  : OCT.Item;
  469.     desc : OCT.Desc; wordSize, calcSize : BOOLEAN;
  470.  
  471. BEGIN (* Index *)
  472.   (* OCG.TraceIn (mname, pname); *)
  473.   f := y.typ.form;
  474.   IF ~(f IN intSet) THEN OCS.Mark (80); y.typ := OCT.inttyp END;
  475.   IF x.typ = NIL THEN OCS.Mark (80); HALT (80) END;
  476.   IF x.typ.form = Array THEN
  477.     eltyp := x.typ.BaseTyp; n := x.typ.n;
  478.     wordSize := (x.typ.size <= 32767);
  479.     IF eltyp = NIL THEN OCS.Mark (81); HALT (81) END;
  480.     IF y.mode = Con THEN
  481.       IF (0 <= y.a0) & (y.a0 < n) THEN i := y.a0 * eltyp.size
  482.       ELSE OCS.Mark (81); i := 0
  483.       END;
  484.       IF x.mode = Var  THEN
  485.         INC (x.a0, i)
  486.       ELSIF (x.mode = Ind) OR (x.mode = RegI) THEN
  487.         INC (x.a1, i); x.obj := NIL
  488.       ELSE
  489.         OCI.LoadAdr (x); x.a1 := i
  490.       END
  491.     ELSE
  492.       OCI.Load (y);
  493.       IF f = SInt THEN OCI.EXT (W, y.a0); y.typ := OCT.inttyp; f := Int END;
  494.  
  495.       IF OCS.indexCheck THEN (* z = bound descr *)
  496.         z.mode := Con; z.a0 := n - 1;
  497.         IF f = Int THEN z.typ := OCT.inttyp; OCC.PutF2 (OCC.CHK, z, y.a0)
  498.         ELSE
  499.           OCC.PutF1 (OCC.TST, L, y);              (*    TST.L Dy          *)
  500.           L0 := OCC.pc; OCC.PutWord (6B00H);      (*    BMI.S 1$          *)
  501.           z.typ := OCT.linttyp; cmp (y, z, FALSE);(*    CMP.L #z,Dy       *)
  502.           OCC.PutWord (6F02H);                    (*    BLE.S 2$          *)
  503.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  504.           OCC.PutWord (OCC.TRAP + OCC.IndexCheck);(* 1$ TRAP  #IndexCheck *)
  505.         END                                       (* 2$                   *)
  506.       END;
  507.  
  508.       m := x.mode;
  509.       IF m = Var THEN
  510.         x.mode := VarX; x.wordIndex := wordSize; x.a1 := 0;
  511.         x.a2 := SHORT (y.a0); calcSize := eltyp.size > 1
  512.       ELSIF m = Ind THEN
  513.         x.mode := IndX; x.wordIndex := wordSize; x.a2 := SHORT (y.a0);
  514.         calcSize := eltyp.size > 1;
  515.       ELSIF m = RegI THEN
  516.         x.mode := RegX; x.wordIndex := wordSize; x.a2 := SHORT (y.a0);
  517.         calcSize := eltyp.size > 1;
  518.       ELSIF m IN {VarX, IndX, RegX} THEN
  519.         IF eltyp.size > 1 THEN
  520.           z.mode := Con; z.a0 := eltyp.size;
  521.           IF x.wordIndex THEN z.typ := OCT.inttyp
  522.           ELSE z.typ := OCT.linttyp
  523.           END;
  524.           Op (times, y, z, FALSE)
  525.         END;
  526.         z := y; y.mode := Reg; y.a0 := x.a2;
  527.         IF x.wordIndex THEN y.typ := OCT.inttyp
  528.         ELSE y.typ := OCT.linttyp
  529.         END;
  530.         Op (plus, y, z, TRUE);
  531.         calcSize := FALSE;
  532.       ELSE OCS.Mark (322)
  533.       END;
  534.       IF calcSize THEN
  535.         z.mode := Con; z.a0 := eltyp.size;
  536.         IF x.wordIndex THEN z.typ := OCT.inttyp
  537.         ELSE z.typ := OCT.linttyp
  538.         END;
  539.         Op (times, y, z, FALSE)
  540.       END
  541.     END; (* ELSE *)
  542.     x.typ := eltyp
  543.   ELSIF x.typ.form = DynArr THEN
  544.     IF f # LInt THEN ConvertInts (y, OCT.linttyp)
  545.     ELSIF y.mode # Con THEN OCI.Load (y)
  546.     END;
  547.  
  548.     IF OCS.indexCheck THEN
  549.       IF (y.mode = Con) & (y.a0 < 0) THEN OCS.Mark (81)
  550.       ELSE
  551.         (* z = bound descr *)
  552.         OCI.DescItem (z, x.desc, x.typ.adr);
  553.         IF y.mode # Con THEN
  554.           OCC.PutF1 (OCC.TST, L, y);              (*    TST.L y           *)
  555.           L0 := OCC.pc; OCC.PutWord (6B00H);      (*    BMI.S 1$          *)
  556.           cmp (y, z, FALSE);                      (*    CMP.L z,Dy        *)
  557.           OCC.PutWord (6D02H);                    (*    BLT.S 2$          *)
  558.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  559.           OCC.PutWord (OCC.TRAP + OCC.IndexCheck);(* 1$ TRAP  #IndexCheck *)
  560.                                                   (* 2$                   *)
  561.         ELSE
  562.           cmp (z, y, FALSE);                      (*    CMP.L y,z         *)
  563.           OCC.PutWord (6E02H);                    (*    BGT.S 1$          *)
  564.           OCC.PutWord (OCC.TRAP + OCC.IndexCheck);(*    TRAP  #IndexCheck *)
  565.         END;                                      (* 1$                   *)
  566.         OCI.UpdateDesc (z, x.typ.adr)
  567.       END (* ELSE *)
  568.     END; (* IF *)
  569.  
  570.     IF x.mode = Var THEN (* Value parameter *)
  571.       IF y.mode = Con THEN x.mode := Ind; x.a1 := y.a0
  572.       ELSE
  573.         x.mode := IndX; x.a1 := 0; x.a2 := SHORT (y.a0);
  574.         x.wordIndex := FALSE
  575.       END
  576.     ELSIF x.mode = Ind THEN (* Variable parameter, or dereferenced ptr *)
  577.       IF y.mode = Con THEN x.a1 := y.a0
  578.       ELSE x.mode := IndX; x.a2 := SHORT (y.a0); x.wordIndex := FALSE
  579.       END
  580.     ELSIF x.mode = RegI THEN (* Dereferenced ptr *)
  581.       IF y.mode = Con THEN x.a1 := y.a0
  582.       ELSE x.mode := RegX; x.a2 := SHORT (y.a0); x.wordIndex := FALSE
  583.       END
  584.     ELSIF x.mode IN {IndX, RegX} THEN (* Indexed open array *)
  585.       IF ~OCS.indexCheck THEN (* z = bound descr *)
  586.         OCI.DescItem (z, x.desc, x.typ.adr);
  587.       END;
  588.       y1.mode := Reg; y1.a0 := x.a2; y1.typ := OCT.linttyp;
  589.       Op (times, y1, z, FALSE); Op (plus, y1, y, TRUE); y := y1;
  590.       OCI.UpdateDesc (z, x.typ.adr)
  591.     ELSE OCS.Mark (322)
  592.     END;
  593.  
  594.     x.typ := x.typ.BaseTyp;
  595.     IF x.typ # NIL THEN
  596.       IF (x.typ.form # DynArr) THEN
  597.         IF x.typ.size > 1 THEN
  598.           z.mode := Con; z.a0 := x.typ.size; SetIntType (z);
  599.           Op (times, y, z, FALSE)
  600.         END;
  601.         IF y.mode = Con THEN x.a1 := y.a0 END
  602.       ELSIF (y.mode = Con) & (y.a0 # 0) THEN
  603.         OCI.Load (y); x.a1 := 0; x.a2 := SHORT (y.a0); x.wordIndex := FALSE;
  604.         IF x.mode = Ind THEN x.mode := IndX
  605.         ELSIF x.mode = RegI THEN x.mode := RegX
  606.         ELSE OCS.Mark (322)
  607.         END
  608.       END
  609.     END
  610.   ELSE
  611.     OCS.Mark (82)
  612.   END
  613.   (* ;OCG.TraceOut (mname, pname); *)
  614. END Index;
  615.  
  616. (*------------------------------------*)
  617. PROCEDURE Field * (VAR x : OCT.Item; y : OCT.Object);
  618.  
  619.   (* CONST pname = "Field"; *)
  620.  
  621.   VAR b : BOOLEAN;
  622.  
  623. BEGIN (* Field *)
  624.   (* OCG.TraceIn (mname, pname); *)
  625.   IF x.mode = Var THEN INC (x.a0, y.a0)
  626.   ELSIF (x.mode = Ind)  OR (x.mode = RegI) THEN INC (x.a1, y.a0)
  627.   ELSE OCI.LoadAdr (x); x.mode := RegI; x.a1 := y.a0
  628.   END;
  629.   x.typ := y.typ; x.obj := NIL;
  630.   (*
  631.   x.rdOnly := x.rdOnly OR (y.visible = OCT.RdOnly)
  632.   *)
  633.   IF x.lev < 0 THEN
  634.     b := (y.visible = OCT.RdOnly); x.rdOnly := x.rdOnly OR b
  635.   END
  636.   (* ;OCG.TraceOut (mname, pname); *)
  637. END Field;
  638.  
  639. (*------------------------------------*)
  640. PROCEDURE DeRef * (VAR x : OCT.Item);
  641.  
  642.   (* CONST pname = "DeRef"; *)
  643.  
  644.   VAR y, z : OCT.Item; f : INTEGER; desc : OCT.Desc; freeY : BOOLEAN;
  645.  
  646. BEGIN (* DeRef *)
  647.   (* OCG.TraceIn (mname, pname); *)
  648.   f := x.typ.form;
  649.   IF (x.mode <= RegX) & (f IN {Pointer, CPointer, BPointer}) THEN
  650.     IF f = BPointer THEN
  651.       y := x; OCC.GetDReg (z);
  652.       OCC.Move (L, y, z); OCI.Unload (y);         (*    MOVE.L  x,Dm      *)
  653.       IF OCS.nilCheck THEN
  654.         OCC.PutWord (6602H);                      (*    BNE     1$        *)
  655.         OCC.PutWord (OCC.TRAP + OCC.NilCheck)     (*    TRAP    #NilCheck *)
  656.       END;                                        (* 1$                   *)
  657.       OCC.PutF5 (OCC.ADD, L, z, z);               (*    ADD.L   Dm, Dm    *)
  658.       OCC.PutF5 (OCC.ADD, L, z, z);               (*    ADD.L   Dm, Dm    *)
  659.       OCC.GetAReg (x); OCC.Move (L, z, x);        (*    MOVEA.L Dm,An     *)
  660.       OCI.Unload (z); x.mode := RegI
  661.     ELSE
  662.       OCI.UnloadDesc (x); y.mode := Undef;
  663.       IF
  664.         (f = Pointer) & (x.typ.BaseTyp # NIL)
  665.         & (x.typ.BaseTyp.form = DynArr)
  666.       THEN
  667.         desc := x.desc; IF desc = NIL THEN desc := OCT.AllocDesc() END;
  668.         desc.lev := x.lev; desc.mode := x.mode; desc.a0 := x.a0;
  669.         desc.a1 := x.a1; desc.a2 := x.a2; x.desc := desc;
  670.         freeY := ~(desc.mode IN {VarX, IndX, RegI, RegX})
  671.       ELSE
  672.         freeY := TRUE
  673.       END;
  674.       IF x.mode = Var THEN
  675.         IF OCS.nilCheck THEN
  676.           y := x;
  677.           OCC.PutF1 (OCC.TST, L, y);                (*    TST.L x         *)
  678.           OCC.PutWord (6602H);                      (*    BNE   1$        *)
  679.           OCC.PutWord (OCC.TRAP + OCC.NilCheck);    (*    TRAP  #NilCheck *)
  680.           IF freeY THEN OCI.Unload (y) END;         (* 1$                 *)
  681.         END;
  682.         x.mode := Ind
  683.       ELSE
  684.         y := x; y.typ := OCT.ptrtyp; OCC.GetAReg (x);
  685.         IF OCS.nilCheck THEN
  686.           OCI.Load (y);                           (*    MOVE.L  x,Dn      *)
  687.           OCC.PutWord (6602H);                    (*    BNE     1$        *)
  688.           OCC.PutWord (OCC.TRAP + OCC.NilCheck);  (*    TRAP    #NilCheck *)
  689.         END;                                      (* 1$                   *)
  690.         OCC.Move (L, y, x);                       (*    MOVEA.L x, An     *)
  691.         IF freeY THEN OCI.Unload (y) END; x.mode := RegI
  692.       END
  693.     END;
  694.     x.a2 := f; x.typ := x.typ.BaseTyp; x.obj := OCC.wasderef;
  695.     x.rdOnly := FALSE
  696.   ELSE
  697.     OCS.Mark (84)
  698.   END;
  699.   x.a1 := 0
  700.   (* ;OCG.TraceOut (mname, pname); *)
  701. END DeRef;
  702.  
  703. (*------------------------------------*)
  704. PROCEDURE TypTest * (VAR x, y : OCT.Item; test : BOOLEAN);
  705.  
  706.   (* CONST pname = "TypTest"; *)
  707.  
  708.   (*------------------------------------*)
  709.   PROCEDURE GTT (t0, t1 : OCT.Struct; varpar : BOOLEAN);
  710.  
  711.     (* CONST pname = "GTT"; *)
  712.  
  713.     VAR t : OCT.Struct; xt, tdes, p : OCT.Item; R : SET;
  714.  
  715.   BEGIN (* GTT *)
  716.     (* OCG.TraceIn (mname, pname); *)
  717.     IF t0 # t1 THEN
  718.       t := t1;
  719.       (*IF t0.form = Record THEN*)
  720.         REPEAT t := t.BaseTyp UNTIL (t = NIL) OR (t = t0);
  721.       (*END;*)
  722.       IF t # NIL THEN
  723.         x.typ := y.typ;
  724.         IF OCS.typeCheck OR test THEN
  725.           R := OCC.RegSet; xt := x;
  726.           IF varpar THEN
  727.             xt.mode := Ind; xt.a0 := x.a0 + 4
  728.           ELSE
  729.             p := xt; p.typ := OCT.ptrtyp; OCC.GetAReg (xt);
  730.             IF OCS.nilCheck THEN
  731.               OCI.Load (p);                       (*    MOVE.L  p,Dn      *)
  732.               OCC.PutWord (6602H);                (*    BNE     1$        *)
  733.               OCC.PutWord (OCC.TRAP + OCC.NilCheck);
  734.                                                   (*    TRAP    #NilCheck *)
  735.             END;                                  (* 1$                   *)
  736.             OCC.Move (L, p, xt);                  (*    MOVE.L  p,An      *)
  737.             p := xt; p.mode := RegI; p.a1 := -4;
  738.             OCC.Move (L, p, xt); xt.mode := RegI; (*    MOVE.L -4(An),An  *)
  739.           END;
  740.           xt.a1 := t1.n * 4;
  741.           (*
  742.           IF xt.a1 = 0 THEN
  743.             IF xt.mode = Ind THEN xt.mode := Var
  744.             ELSE xt.mode := Reg
  745.             END
  746.           END;
  747.           *)
  748.           tdes.mode := LabI; tdes.a0 := 0; tdes.a1 := 4;
  749.           tdes.symbol := t1.symbol;
  750.           OCC.PutF5 (OCC.CMP, L, tdes, xt);       (*    CMP.L  #tdes,<xt> *)
  751.           IF ~test THEN
  752.             OCC.PutWord (6702H);                  (*    BEQ.S  1$         *)
  753.             OCC.PutWord (OCC.TRAP + OCC.TypeCheck)(*    TRAP   #TypeCheck *)
  754.           ELSE                                    (* 1$                   *)
  755.             setCC (x, OCC.EQ)
  756.           END;
  757.           OCC.FreeRegs (R)
  758.         END
  759.       ELSE OCS.Mark (85); IF test THEN x.typ := OCT.booltyp END
  760.       END
  761.     ELSIF test THEN setCC (x, OCC.T)
  762.     END
  763.     (* ;OCG.TraceOut (mname, pname); *)
  764.   END GTT;
  765.  
  766. BEGIN (* TypTest *)
  767.   (* OCG.TraceIn (mname, pname); *)
  768.   IF x.typ.form = Pointer THEN
  769.     IF y.typ.form = Pointer THEN
  770.       GTT (x.typ.BaseTyp, y.typ.BaseTyp, FALSE)
  771.     ELSE OCS.Mark (86)
  772.     END
  773.   (*
  774.   ELSIF x.typ.form = PtrTyp THEN
  775.     IF y.typ.form = Pointer THEN
  776.       GTT (x.typ, y.typ.BaseTyp, FALSE)
  777.     ELSE OCS.Mark (86)
  778.     END
  779.   *)
  780.   ELSIF
  781.     (x.typ.form = Record) & (x.mode = Ind) & (x.obj # NIL)
  782.     & (x.obj # OCC.wasderef) & (y.typ.form = Record)
  783.   THEN GTT (x.typ, y.typ, TRUE)
  784.   ELSE OCS.Mark (87)
  785.   END
  786.   (* ;OCG.TraceOut (mname, pname); *)
  787. END TypTest;
  788.  
  789. (*------------------------------------*)
  790. PROCEDURE In * (VAR lhs, rhs : OCT.Item);
  791.  
  792.   (* CONST pname = "In"; *)
  793.  
  794.   VAR f, g, L0 : INTEGER; bnd, br : OCT.Item;
  795.  
  796. BEGIN (* In *)
  797.   (* OCG.TraceIn (mname, pname); *)
  798.   f := lhs.typ.form; g := rhs.typ.form;
  799.   IF (f IN intSet) & (g IN setSet) THEN
  800.     IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  801.       IF (lhs.a0 >= 0) & (lhs.a0 < 32) THEN
  802.         IF lhs.a0 IN SYS.VAL (SET, rhs.a0) THEN setCC (lhs, OCC.T)
  803.         ELSE setCC (lhs, OCC.F)
  804.         END
  805.       ELSE
  806.         OCS.Mark (91); setCC (lhs, OCC.F)
  807.       END
  808.     ELSIF lhs.mode = Con THEN
  809.       IF
  810.         (lhs.a0 < 0)
  811.         OR ((g = BSet) & (lhs.a0 > 7))
  812.         OR ((g = WSet) & (lhs.a0 > 15))
  813.         OR ((g = Set) & (lhs.a0 > 31))
  814.       THEN
  815.         OCS.Mark (91); setCC (lhs, OCC.F)
  816.       ELSE
  817.         OCI.Load (rhs); OCC.Bit (OCC.BTST, lhs, rhs);
  818.         OCI.Unload (rhs); setCC (lhs, OCC.NE)
  819.       END; (* ELSE *)
  820.     ELSE
  821.       IF rhs.mode = Con THEN rhs.typ := OCT.settyp; g := Set END;
  822.       OCI.Load (lhs);
  823.  
  824.       IF OCS.rangeCheck THEN
  825.         IF lhs.typ.form = SInt THEN OCI.EXT (W, lhs.a0) END;
  826.         bnd.mode := Con;
  827.         IF g = BSet THEN bnd.a0 := 7
  828.         ELSIF g = WSet THEN bnd.a0 := 15
  829.         ELSE bnd.a0 := 31
  830.         END;
  831.         IF lhs.typ.form = LInt THEN
  832.           bnd.typ := OCT.linttyp;
  833.           OCC.PutF1 (OCC.TST, L, lhs);            (*    TST.L <lhs>       *)
  834.           L0 := OCC.pc; OCC.PutWord (6B00H);      (*    BMI.S 1$          *)
  835.           cmp (lhs, bnd, FALSE);                  (*    CMP   #<bnd>,<lhs>*)
  836.           OCC.PutWord (6F02H);                    (*    BLE.S 2$          *)
  837.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  838.           OCC.PutWord (OCC.TRAP + OCC.IndexCheck);(* 1$ TRAP  #IndexCheck *)
  839.         ELSE                                      (* 2$                   *)
  840.           bnd.typ := OCT.inttyp; OCC.PutF2 (OCC.CHK, bnd, lhs.a0)
  841.         END
  842.       END;
  843.  
  844.       OCI.Load (rhs); OCC.Bit (OCC.BTST, lhs, rhs);
  845.       OCI.Unload (lhs); OCI.Unload (rhs); setCC (lhs, OCC.NE)
  846.     END
  847.   ELSE OCS.Mark (92); setCC (lhs, OCC.F)
  848.   END
  849.   (* ;OCG.TraceOut (mname, pname); *)
  850. END In;
  851.  
  852. (*------------------------------------*)
  853. PROCEDURE Set0 * (VAR x, y : OCT.Item);
  854.  
  855.   (* CONST pname = "Set0"; *)
  856.  
  857.   VAR one : LONGINT;
  858.  
  859. BEGIN (* Set0 *)
  860.   (* OCG.TraceIn (mname, pname); *)
  861.   x.mode := Reg; x.a0 := D0; x.typ := OCT.settyp;
  862.   IF y.typ.form IN intSet THEN
  863.     IF y.mode = Con THEN
  864.       x.mode := Con;
  865.       IF (0 <= y.a0) & (y.a0 < 32) THEN
  866.         one := 1; x.a0 := SYS.LSH (one, y.a0); SetSetType (x)
  867.       ELSE
  868.         OCS.Mark (202)
  869.       END
  870.     ELSE
  871.       x.mode := Con; x.a0 := 1; OCI.Load (x); OCI.Load (y);
  872.       OCC.Shift (OCC.LSL, L, y, x); OCI.Unload (y)
  873.     END
  874.   ELSE OCS.Mark (93)
  875.   END
  876.   (* ;OCG.TraceOut (mname, pname); *)
  877. END Set0;
  878.  
  879. (*------------------------------------*)
  880. PROCEDURE Set1 * (VAR x, y, z : OCT.Item);
  881.  
  882.   (* CONST pname = "Set1"; *)
  883.  
  884.   VAR s : LONGINT;
  885.  
  886. BEGIN (* Set1 *)
  887.   (* OCG.TraceIn (mname, pname); *)
  888.   x.mode := Reg; x.a0 := D0; x.typ := OCT.settyp;
  889.   IF
  890.     (y.typ.form IN intSet) & (z.typ.form IN intSet)
  891.   THEN
  892.     IF y.mode = Con THEN
  893.       IF (0 <= y.a0) & (y.a0 < 32) THEN
  894.         y.typ := OCT.settyp; s := -1; y.a0 := SYS.LSH (s, y.a0);
  895.         IF z.mode = Con THEN
  896.           x.mode := Con;
  897.           IF (y.a0 <= z.a0) & (z.a0 < 32) THEN
  898.             s := -2; x.a0 := y.a0 - SYS.LSH (s, z.a0); SetSetType (x)
  899.           ELSE
  900.             OCS.Mark (202); x.a0 := 0
  901.           END
  902.         ELSIF y.a0 = -1 THEN
  903.           x.mode := Con; x.a0 := -2; OCI.Load (x); OCI.Load (z);
  904.           OCC.Shift (OCC.LSL, L, z, x); OCC.PutF1 (OCC.NOT, L, x);
  905.           OCC.FreeReg (z)
  906.         ELSE
  907.           x := y; y.mode := Con; y.a0 := -2; OCI.Load (y); OCI.Load (z);
  908.           OCC.Shift (OCC.LSL, L, z, y); OCC.FreeReg (z);
  909.           OCC.PutF1 (OCC.NOT, L, y); OCI.Load (x);
  910.           OCC.PutF5 (OCC.AND, L, y, x); OCC.FreeReg (y)
  911.         END
  912.       ELSE
  913.         OCS.Mark (202)
  914.       END
  915.     ELSE
  916.       x.mode := Con; x.a0 := -1; OCI.Load (x); OCI.Load (y);
  917.       OCC.Shift (OCC.LSL, L, y, x); OCC.FreeReg (y);
  918.       y.mode := Con; y.typ := NIL;
  919.       IF z.mode = Con THEN
  920.         IF (0 <= z.a0) & (z.a0 < 32) THEN
  921.           s := -2;
  922.           y.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, SYS.LSH(s, z.a0)));
  923.           OCC.PutF6 (OCC.ANDI, L, y, x)
  924.         ELSE
  925.           OCS.Mark (202)
  926.         END
  927.       ELSE
  928.         y.a0 := -2; OCI.Load (y); OCI.Load (z);
  929.         OCC.Shift (OCC.LSL, L, z, y); OCC.FreeReg (z);
  930.         OCC.PutF1 (OCC.NOT, L, y); OCC.PutF5 (OCC.AND, L, y, x);
  931.         OCC.FreeReg (y)
  932.       END
  933.     END (* ELSE *)
  934.   ELSE
  935.     OCS.Mark (93)
  936.   END
  937.   (* ;OCG.TraceOut (mname, pname); *)
  938. END Set1;
  939.  
  940. (*------------------------------------*)
  941. PROCEDURE MOp * (op : INTEGER; VAR x : OCT.Item);
  942.  
  943.   (* CONST pname = "MOp"; *)
  944.  
  945.   VAR f, opcode : INTEGER; a : LONGINT; y : OCT.Item; freeY : BOOLEAN;
  946.  
  947. BEGIN (* MOp *)
  948.   (* OCG.TraceIn (mname, pname); *)
  949.   f := x.typ.form;
  950.   CASE op OF
  951.     and :
  952.       IF (x.typ.form = Bool) & (x.mode = Con) THEN
  953.         IF x.a0 = 0 THEN setCC (x, OCC.F) ELSE setCC (x, OCC.T) END
  954.       END;
  955.       IF x.mode = Coc THEN
  956.         IF x.a0 # OCC.T THEN
  957.           IF x.a0 = OCC.F THEN opcode := OCC.BRA
  958.           ELSE opcode := OCC.Bcc + (OCC.invertedCC (x.a0) * 100H)
  959.           END;
  960.           OCC.PutWord (opcode); OCC.PutWord (x.a2); x.a2 := OCC.pc - 2
  961.         END;
  962.         OCC.FixLink (x.a1)
  963.       ELSIF x.typ.form = Bool THEN
  964.         test (x); OCC.PutWord (OCC.BEQ); OCC.PutWord (x.a2);
  965.         x.a2 := OCC.pc - 2; OCC.FixLink (x.a1)
  966.       ELSE
  967.         OCS.Mark (94); x.mode := Con; x.typ := OCT.booltyp; x.a0 := 0
  968.       END
  969.     |
  970.     plus :
  971.       IF ~(f IN intSet + realSet) THEN OCS.Mark (96) END
  972.     |
  973.     minus :
  974.       IF f IN intSet THEN
  975.         IF x.mode = Con THEN x.a0 := -x.a0; SetIntType (x)
  976.         ELSE OCI.Load (x); OCC.PutF1 (OCC.NEG, x.typ.size, x)
  977.         END
  978.       ELSIF f IN realSet THEN
  979.         NegReal (x)
  980.       ELSIF f IN setSet THEN
  981.         IF x.mode = Con THEN
  982.           x.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, x.a0))
  983.         ELSE
  984.           OCI.Load (x); OCC.PutF1 (OCC.NOT, x.typ.size, x)
  985.         END
  986.       ELSE
  987.         OCS.Mark (97)
  988.       END
  989.     |
  990.     or :
  991.       IF (x.typ.form = Bool) & (x.mode = Con) THEN
  992.         IF x.a0 = 0 THEN setCC (x, OCC.F) ELSE setCC (x, OCC.T) END
  993.       END; (* IF *)
  994.       IF x.mode = Coc THEN
  995.         IF x.a0 # OCC.F THEN
  996.           IF x.a0 = OCC.T THEN opcode := OCC.BRA
  997.           ELSE opcode := OCC.Bcc + (SHORT (x.a0) * 100H)
  998.           END;
  999.           OCC.PutWord (opcode); OCC.PutWord (SHORT (x.a1));
  1000.           x.a1 := OCC.pc - 2
  1001.         END;
  1002.         OCC.FixLink (x.a2)
  1003.       ELSIF x.typ.form = Bool THEN
  1004.         test (x); OCC.PutWord (OCC.BNE); OCC.PutWord (SHORT (x.a1));
  1005.         x.a1 := OCC.pc - 2; OCC.FixLink (x.a2)
  1006.       ELSE
  1007.         OCS.Mark (94); x.mode := Con; x.typ := OCT.booltyp; x.a0 := 1
  1008.       END
  1009.     |
  1010.     eql .. geq : (* relations *)
  1011.       IF x.mode = Coc THEN loadB (x) END
  1012.     |
  1013.     not :
  1014.       IF x.typ.form = Bool THEN
  1015.         IF x.mode = Con THEN
  1016.           IF x.a0 = 0 THEN x.a0 := 1 ELSE x.a0 := 0 END
  1017.         ELSIF x.mode = Coc THEN
  1018.           x.a0 := OCC.invertedCC (x.a0); a := x.a1; x.a1 := x.a2;
  1019.           x.a2 := SHORT (a)
  1020.         ELSE
  1021.           y := x;
  1022.           OCC.PutF1 (OCC.TST, B, y); setCC (x, OCC.EQ);
  1023.         END
  1024.       ELSE
  1025.         OCS.Mark (98)
  1026.       END
  1027.     |
  1028.   ELSE
  1029.     OCS.Mark (1010); OCS.Mark (op)
  1030.   END; (* CASE op *)
  1031.   (* ;OCG.TraceOut (mname, pname); *)
  1032. END MOp;
  1033.  
  1034. (*------------------------------------*)
  1035. PROCEDURE CheckOverflow (op : INTEGER; VAR lhs, rhs : OCT.Item);
  1036.  
  1037.   (* CONST pname = "CheckOverflow"; *)
  1038.  
  1039.   CONST min = OCG.MinLInt; max = OCG.MaxLInt;
  1040.  
  1041. BEGIN (* CheckOverflow *)
  1042.   (* OCG.TraceIn (mname, pname); *)
  1043.   CASE op OF
  1044.     times :
  1045.       IF lhs.a0 < 0 THEN
  1046.         IF (rhs.a0 < 0) & (lhs.a0 < max DIV rhs.a0) THEN
  1047.           OCS.Mark (109); rhs.a0 := -1
  1048.         ELSIF (rhs.a0 > 0) & (lhs.a0 < min DIV rhs.a0) THEN
  1049.           OCS.Mark (109); rhs.a0 := 1
  1050.         END
  1051.       ELSE
  1052.         IF (rhs.a0 < 0) & (lhs.a0 > min DIV rhs.a0) THEN
  1053.           OCS.Mark (109); rhs.a0 := -1
  1054.         ELSIF (rhs.a0 > 0) & (lhs.a0 > max DIV rhs.a0) THEN
  1055.           OCS.Mark (109); rhs.a0 := 1
  1056.         END
  1057.       END
  1058.     |
  1059.     plus :
  1060.       IF lhs.a0 < 0 THEN
  1061.         IF (rhs.a0 < 0) & (lhs.a0 < min - rhs.a0) THEN
  1062.           OCS.Mark (109); rhs.a0 := 0
  1063.         END
  1064.       ELSE
  1065.         IF (rhs.a0 > 0) & (lhs.a0 > max - rhs.a0) THEN
  1066.           OCS.Mark (109); rhs.a0 := 0
  1067.         END
  1068.       END
  1069.     |
  1070.     minus :
  1071.       IF lhs.a0 < 0 THEN
  1072.         IF (rhs.a0 > 0) & (lhs.a0 < min + rhs.a0) THEN
  1073.           OCS.Mark (109); rhs.a0 := 0
  1074.         END
  1075.       ELSE
  1076.         IF (rhs.a0 < 0) & (lhs.a0 > max + rhs.a0) THEN
  1077.           OCS.Mark (109); rhs.a0 := 0
  1078.         END
  1079.       END
  1080.     |
  1081.   ELSE
  1082.     OCS.Mark (1011); OCS.Mark (op)
  1083.   END; (* CASE op *)
  1084.   (* ;OCG.TraceOut (mname, pname); *)
  1085. END CheckOverflow;
  1086.  
  1087. (*------------------------------------*)
  1088. PROCEDURE Op * (op : INTEGER; VAR lhs, rhs : OCT.Item; freeRegs : BOOLEAN);
  1089.  
  1090.   (* CONST pname = "Op"; *)
  1091.  
  1092.   CONST
  1093.     eqSet =
  1094.       { Undef, Char .. LInt, BSet .. Set,
  1095.         NilTyp, PtrTyp .. ProcTyp, TagTyp };
  1096.     nilSet =
  1097.       { Pointer, CPointer, BPointer, PtrTyp,
  1098.         CPtrTyp, BPtrTyp, ProcTyp, TagTyp };
  1099.  
  1100.   VAR f, g : INTEGER; p, q, r : OCT.Struct; size : LONGINT;
  1101.  
  1102.   (*------------------------------------*)
  1103.   PROCEDURE strings () : BOOLEAN;
  1104.  
  1105.   BEGIN (* strings *)
  1106.     RETURN
  1107.       ((((f = Array) OR (f = DynArr)) & (lhs.typ.BaseTyp.form = Char))
  1108.        OR (f = String))
  1109.       & ((((g = Array) OR (g = DynArr)) & (rhs.typ.BaseTyp.form = Char))
  1110.        OR (g = String))
  1111.   END strings;
  1112.  
  1113.   (*------------------------------------*)
  1114.   PROCEDURE CompStrings (cc : INTEGER; testNul : BOOLEAN);
  1115.  
  1116.     (* CONST pname = "CompStrings"; *)
  1117.  
  1118.     VAR br, len, ch : OCT.Item; L0, L1 : INTEGER; d : OCT.Desc;
  1119.  
  1120.   BEGIN (* CompStrings *)
  1121.     (* OCG.TraceIn (mname, pname); *)
  1122.     IF (g = String) & (rhs.a1 = 1) THEN
  1123.       IF (f = String) & (lhs.a1 <= 2) THEN OCC.AllocStringFromChar (lhs) END;
  1124.       IF cc = OCC.CS THEN setCC (lhs, OCC.F)
  1125.       ELSIF cc = OCC.CC THEN setCC (lhs, OCC.T)
  1126.       ELSE
  1127.         OCC.PutF1 (OCC.TST, B, lhs);               (*    TST.B   <lhs>    *)
  1128.         OCI.Unload (lhs); setCC (lhs, cc)
  1129.       END
  1130.     ELSIF (f = String) & (lhs.a1 = 1) THEN
  1131.       IF cc = OCC.CS THEN cc := OCC.HI
  1132.       ELSIF cc = OCC.HI THEN cc := OCC.CS
  1133.       ELSIF cc = OCC.CC THEN cc := OCC.LS
  1134.       ELSIF cc = OCC.LS THEN cc := OCC.CC
  1135.       END;
  1136.       IF cc = OCC.CS THEN setCC (lhs, OCC.F)
  1137.       ELSIF cc = OCC.CC THEN setCC (lhs, OCC.T)
  1138.       ELSE
  1139.         OCC.PutF1 (OCC.TST, B, rhs);               (*    TST.B   <rhs>    *)
  1140.         setCC (lhs, cc)
  1141.       END
  1142.     ELSE
  1143.       IF f = String THEN
  1144.         IF lhs.a1 = 2 THEN OCC.AllocStringFromChar (lhs) END;
  1145.         len.mode := Con; len.a0 := lhs.a1 - 1; len.typ := OCT.inttyp
  1146.       ELSIF f = DynArr THEN
  1147.         OCI.DescItem (len, lhs.desc, lhs.typ.adr)
  1148.       ELSE
  1149.         len.mode := Con; len.a0 := lhs.typ.n - 1; len.typ := OCT.inttyp
  1150.       END;
  1151.       IF (g = String) & (rhs.a1 = 2) THEN OCC.AllocStringFromChar (rhs) END;
  1152.       OCI.Load (len);                              (*    MOVE.Z  <len>,Dc *)
  1153.       OCI.LoadAdr (lhs); lhs.mode := Pop;          (*    LEA     <lhs>,Aa *)
  1154.       OCI.LoadAdr (rhs); rhs.mode := Pop;          (*    LEA     <rhs>,Ab *)
  1155.       OCC.GetDReg (ch); OCC.Move (B, lhs, ch);     (*    MOVE.B  (Aa)+,Dd *)
  1156.       OCC.PutF5 (OCC.CMP, B, rhs, ch);             (*    CMP.B   (Ab)+,Dd *)
  1157.       L0 := OCC.pc; OCC.PutWord (6600H);           (* 1$ BNE.S   2$       *)
  1158.       OCC.PutF1 (OCC.TST, B, ch);                  (*    TST.B   Dd       *)
  1159.       L1 := OCC.pc; OCC.PutWord (6700H);           (*    BEQ.S   2$       *)
  1160.       OCC.PutWord (OCC.DBF + SHORT (len.a0));
  1161.       OCC.PutWord (-12);                           (*    DBF.W   Dc,1$    *)
  1162.       IF testNul THEN
  1163.         lhs.mode := RegI; lhs.a1 := 0;
  1164.         OCC.PutF1 (OCC.TST, B, lhs);               (*    TST.B   (Aa)     *)
  1165.       END;                                         (* 2$                  *)
  1166.       OCC.PatchWord (L0, OCC.pc - L0 - 2);
  1167.       OCC.PatchWord (L1, OCC.pc - L1 - 2);
  1168.       OCI.Unload (lhs); OCI.Unload (len); OCI.Unload (ch);
  1169.       setCC (lhs, cc)
  1170.     END
  1171.     (* ;OCG.TraceOut (mname, pname); *)
  1172.   END CompStrings;
  1173.  
  1174.   (*------------------------------------*)
  1175.   PROCEDURE CompBool (cc : INTEGER);
  1176.  
  1177.     (* CONST pname = "CompBool"; *)
  1178.     VAR swap : OCT.Item; result : BOOLEAN;
  1179.  
  1180.   BEGIN (* CompBool *)
  1181.     (* OCG.TraceIn (mname, pname); *)
  1182.  
  1183.     IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1184.       IF cc = OCC.EQ THEN result := (lhs.a0 = rhs.a0)
  1185.       ELSE result := (lhs.a0 # rhs.a0)
  1186.       END;
  1187.       IF result THEN setCC (lhs, OCC.T)
  1188.       ELSE setCC (lhs, OCC.F)
  1189.       END;
  1190.     ELSE
  1191.       IF lhs.mode = Con THEN (* swap operands *)
  1192.         swap := rhs; rhs := lhs; lhs := swap
  1193.       END;
  1194.       IF rhs.mode = Coc THEN loadB (rhs)
  1195.       ELSIF (rhs.mode = Con) & (rhs.a0 # 0) THEN
  1196.         (* Comparing with TRUE.
  1197.         ** Invert the CC so that a TST can be used.
  1198.         *)
  1199.         cc := OCC.invertedCC (cc); rhs.a0 := 0
  1200.       END;
  1201.       cmp (lhs, rhs, freeRegs); setCC (lhs, cc)
  1202.     END; (* IF *)
  1203.  
  1204.     (* ;OCG.TraceOut (mname, pname); *)
  1205.   END CompBool;
  1206.  
  1207. BEGIN (* Op *)
  1208.   (* OCG.TraceIn (mname, pname); *)
  1209.   IF lhs.typ # rhs.typ THEN
  1210.     f := lhs.typ.form; g := rhs.typ.form;
  1211.     CASE f OF
  1212.       Undef :
  1213.       |
  1214.       SInt :
  1215.         IF g = Int THEN      ConvertInts (lhs, rhs.typ)
  1216.         ELSIF g = LInt THEN  ConvertInts (lhs, rhs.typ)
  1217.         ELSIF g = Real THEN  ConvertReals (lhs, rhs.typ)
  1218.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1219.         ELSE OCS.Mark (100)
  1220.         END
  1221.       |
  1222.       Int :
  1223.         IF g = SInt THEN    ConvertInts (rhs, lhs.typ)
  1224.         ELSIF g = LInt THEN ConvertInts (lhs, rhs.typ)
  1225.         ELSIF g = Real THEN  ConvertReals (lhs, rhs.typ)
  1226.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1227.         ELSE OCS.Mark (100)
  1228.         END
  1229.       |
  1230.       LInt :
  1231.         IF g = SInt THEN   ConvertInts (rhs, lhs.typ)
  1232.         ELSIF g = Int THEN ConvertInts (rhs, lhs.typ)
  1233.         ELSIF g = Real THEN  ConvertReals (lhs, rhs.typ)
  1234.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1235.         ELSE OCS.Mark (100)
  1236.         END
  1237.       |
  1238.       Real :
  1239.         IF g IN intSet THEN  ConvertReals (rhs, lhs.typ)
  1240.         ELSIF g = LReal THEN ConvertReals (lhs, rhs.typ)
  1241.         ELSE OCS.Mark (100)
  1242.         END
  1243.       |
  1244.       LReal :
  1245.         IF g IN intSet THEN ConvertReals (rhs, lhs.typ)
  1246.         ELSIF g = Real THEN ConvertReals (rhs, lhs.typ)
  1247.         ELSE OCS.Mark (100)
  1248.         END
  1249.       |
  1250.       BSet, WSet, Set :
  1251.         IF g IN setSet THEN
  1252.           IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1253.             IF g >= f THEN lhs.typ := rhs.typ
  1254.             ELSE rhs.typ := lhs.typ
  1255.             END
  1256.           ELSIF lhs.mode = Con THEN
  1257.             SetSetType (lhs);
  1258.             IF g >= lhs.typ.form THEN lhs.typ := rhs.typ
  1259.             ELSE OCS.Mark (100)
  1260.             END
  1261.           ELSIF rhs.mode = Con THEN
  1262.             SetSetType (rhs);
  1263.             IF f >= rhs.typ.form THEN rhs.typ := lhs.typ
  1264.             ELSE OCS.Mark (100)
  1265.             END
  1266.           ELSE OCS.Mark (100)
  1267.           END
  1268.         ELSE OCS.Mark (100)
  1269.         END
  1270.       |
  1271.       NilTyp :
  1272.         IF ~(g IN nilSet) THEN OCS.Mark (100) END
  1273.       |
  1274.       Pointer :
  1275.         IF g = Pointer THEN
  1276.           p := lhs.typ.BaseTyp; q := rhs.typ.BaseTyp;
  1277.           IF (p.form = Record) & (q.form = Record) THEN
  1278.             IF p.n < q.n THEN r := p; p := q; q := r END;
  1279.             WHILE (p # q) & (p # NIL) DO p := p.BaseTyp END;
  1280.             IF p = NIL THEN OCS.Mark (100) END
  1281.           ELSE
  1282.             OCS.Mark (100)
  1283.           END
  1284.         ELSIF g # NilTyp THEN
  1285.           OCS.Mark (100)
  1286.         END
  1287.       |
  1288.       CPointer :
  1289.         IF ~(g IN {CPtrTyp, NilTyp}) THEN OCS.Mark (100) END
  1290.       |
  1291.       CPtrTyp :
  1292.         IF ~(g IN {CPointer, CPtrTyp, NilTyp}) THEN OCS.Mark (100) END
  1293.       |
  1294.       PtrTyp, BPtrTyp, BPointer, ProcTyp, TagTyp :
  1295.         IF g # NilTyp THEN OCS.Mark (100) END
  1296.       |
  1297.       Char :
  1298.         IF (g = String) & (rhs.a1 <= 2) THEN
  1299.           rhs.a0 := rhs.a2; rhs.typ := OCT.chartyp; g := Char
  1300.         ELSE OCS.Mark (100)
  1301.         END
  1302.       |
  1303.       String :
  1304.         IF (g = Char) & (lhs.a1 <= 2) THEN
  1305.           lhs.a0 := lhs.a2; lhs.typ := OCT.chartyp; f := Char
  1306.         ELSIF (g = String) & (lhs.a1 <= 2) & (rhs.a1 <= 2) THEN
  1307.           lhs.a0 := lhs.a2; lhs.typ := OCT.chartyp; f := Char;
  1308.           rhs.a0 := rhs.a2; rhs.typ := OCT.chartyp; g := Char
  1309.         END
  1310.       |
  1311.       Byte, Bool, NoTyp, Record, Word, Longword :
  1312.         OCS.Mark (100);
  1313.       |
  1314.       Array, DynArr :
  1315.       |
  1316.     ELSE
  1317.       OCS.Mark (1012); OCS.Mark (f)
  1318.     END; (* CASE f *)
  1319.   END; (* IF *)
  1320.  
  1321.   f := lhs.typ.form; g := rhs.typ.form; size := lhs.typ.size;
  1322.   IF lhs.mode = RList THEN (* lhs is a function procedure result *)
  1323.     IF f # Pointer THEN OCS.Mark (956) END;
  1324.     OCC.FreeReg (lhs); lhs.mode := Reg; lhs.a0 := D0; OCC.ReserveReg (D0)
  1325.   END;
  1326.   IF rhs.mode = RList THEN (* rhs is a function procedure result *)
  1327.     IF f # Pointer THEN OCS.Mark (956) END;
  1328.     OCC.FreeReg (rhs); rhs.mode := Reg; rhs.a0 := D0; OCC.ReserveReg (D0)
  1329.   END;
  1330.  
  1331.   CASE op OF
  1332.     times :
  1333.       IF f IN intSet THEN
  1334.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1335.           CheckOverflow (times, lhs, rhs);
  1336.           lhs.a0 := lhs.a0 * rhs.a0; SetIntType (lhs)
  1337.         ELSE
  1338.           MultiplyInts (lhs, rhs, size, freeRegs)
  1339.         END
  1340.       ELSIF f IN realSet THEN
  1341.         RealMath (times, lhs, rhs)
  1342.       ELSIF f IN setSet THEN
  1343.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1344.           lhs.a0 :=
  1345.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) * SYS.VAL (SET, rhs.a0))
  1346.         ELSIF lhs.mode = Con THEN
  1347.           OCI.Load (rhs); OCC.PutF6 (OCC.ANDI, size, lhs, rhs); lhs := rhs;
  1348.           rhs.mode := Undef
  1349.         ELSE
  1350.           OCI.Load (lhs); OCC.PutF5 (OCC.AND, size, rhs, lhs)
  1351.         END
  1352.       ELSIF f # Undef THEN OCS.Mark (101)
  1353.       END
  1354.     |
  1355.     slash :
  1356.       IF f IN realSet THEN
  1357.         RealMath (slash, lhs, rhs)
  1358.       ELSIF f IN intSet THEN
  1359.         ConvertReals (lhs, OCT.realtyp); ConvertReals (rhs, OCT.realtyp);
  1360.         RealMath (slash, lhs, rhs)
  1361.       ELSIF f IN setSet THEN
  1362.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1363.           lhs.a0 :=
  1364.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) / SYS.VAL (SET, rhs.a0))
  1365.         ELSIF rhs.mode = Con THEN
  1366.           OCI.Load (lhs); OCC.PutF6 (OCC.EORI, size, rhs, lhs)
  1367.         ELSIF lhs.mode = Con THEN
  1368.           OCI.Load (rhs); OCC.PutF6 (OCC.EORI, size, lhs, rhs);
  1369.           lhs := rhs; rhs.mode := Undef
  1370.         ELSE
  1371.           OCI.Load (lhs); OCI.Load (rhs);
  1372.           OCC.PutF5 (OCC.EOR, size, rhs, lhs)
  1373.         END
  1374.       ELSIF f # Undef THEN OCS.Mark (102)
  1375.       END
  1376.     |
  1377.     div :
  1378.       IF f IN intSet THEN
  1379.         IF (rhs.mode = Con) & (rhs.a0 = 0) THEN
  1380.           OCS.Mark (205); rhs.a0 := 1
  1381.         END;
  1382.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1383.           lhs.a0 := lhs.a0 DIV rhs.a0; SetIntType (lhs);
  1384.         ELSE
  1385.           DivideInts (lhs, rhs, size, freeRegs);
  1386.         END
  1387.       ELSIF f # Undef THEN OCS.Mark (103)
  1388.       END
  1389.     |
  1390.     mod :
  1391.       IF f IN intSet THEN
  1392.         IF (rhs.mode = Con) & (rhs.a0 = 0) THEN
  1393.           OCS.Mark (205); rhs.a0 := 1
  1394.         END;
  1395.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1396.           lhs.a0 := lhs.a0 MOD rhs.a0; lhs.typ := rhs.typ
  1397.         ELSE
  1398.           ModulusInts (lhs, rhs, size, freeRegs)
  1399.         END
  1400.       ELSIF f # Undef THEN OCS.Mark (104)
  1401.       END
  1402.     |
  1403.     and :
  1404.       IF rhs.mode # Coc THEN
  1405.         IF rhs.mode = Con THEN
  1406.           IF rhs.a0 = 1 THEN setCC (rhs, OCC.T) ELSE setCC (rhs, OCC.F) END
  1407.         ELSIF rhs.mode <= Reg THEN test (rhs);
  1408.         ELSE OCS.Mark (94); setCC (rhs, OCC.EQ)
  1409.         END
  1410.       END;
  1411.       IF lhs.mode = Con THEN
  1412.         IF lhs.a0 = 0 THEN
  1413.           OCC.FixLink (rhs.a1); OCC.FixLink (rhs.a2); setCC (rhs, OCC.F)
  1414.         END;
  1415.         setCC (lhs, OCC.EQ)
  1416.       END;
  1417.       IF rhs.a2 # 0 THEN lhs.a2 := SHORT (OCC.MergedLinks (lhs.a2, rhs.a2))
  1418.       END;
  1419.       lhs.a0 := rhs.a0; lhs.a1 := rhs.a1
  1420.     |
  1421.     plus :
  1422.       IF f IN intSet THEN
  1423.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1424.           CheckOverflow (plus, lhs, rhs); INC (lhs.a0, rhs.a0);
  1425.           SetIntType (lhs)
  1426.         ELSE
  1427.           OCI.Load (lhs); OCC.PutF5 (OCC.ADD, size, rhs, lhs);
  1428.           IF OCS.overflowCheck THEN OCC.PutWord (OCC.TRAPV) END
  1429.         END
  1430.       ELSIF f IN realSet THEN
  1431.         RealMath (plus, lhs, rhs)
  1432.       ELSIF f IN setSet THEN
  1433.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1434.           lhs.a0 :=
  1435.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) + SYS.VAL (SET, rhs.a0))
  1436.         ELSIF lhs.mode = Con THEN
  1437.           OCI.Load (rhs); OCC.PutF6 (OCC.ORI, size, lhs, rhs); lhs := rhs;
  1438.           rhs.mode := Undef
  1439.         ELSE
  1440.           OCI.Load (lhs); OCC.PutF5 (OCC.iOR, size, rhs, lhs)
  1441.         END
  1442.       ELSIF f # Undef THEN OCS.Mark (105)
  1443.       END
  1444.     |
  1445.     minus :
  1446.       IF f IN intSet THEN
  1447.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1448.           CheckOverflow (minus, lhs, rhs); DEC (lhs.a0, rhs.a0);
  1449.           SetIntType (lhs)
  1450.         ELSE
  1451.           OCI.Load (lhs); OCC.PutF5 (OCC.SUB, size, rhs, lhs);
  1452.           IF OCS.overflowCheck THEN OCC.PutWord (OCC.TRAPV) END
  1453.         END
  1454.       ELSIF f IN realSet THEN
  1455.         RealMath (minus, lhs, rhs)
  1456.       ELSIF f IN setSet THEN
  1457.         IF (lhs.mode = Con) & (rhs.mode = Con) THEN
  1458.           lhs.a0 :=
  1459.             SYS.VAL (LONGINT, SYS.VAL (SET, lhs.a0) - SYS.VAL (SET, rhs.a0));
  1460.         ELSIF rhs.mode = Con THEN
  1461.           rhs.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, rhs.a0));
  1462.           OCI.Load (lhs); OCC.PutF6 (OCC.ANDI, size, rhs, lhs)
  1463.         ELSIF lhs.mode = Con THEN
  1464.           OCI.Load (rhs); OCC.PutF1 (OCC.NOT, size, rhs);
  1465.           IF ~(lhs.a0 = -1) THEN OCC.PutF6 (OCC.ANDI, size, lhs, rhs) END;
  1466.           lhs := rhs; rhs.mode := Undef
  1467.         ELSE
  1468.           OCI.Load (lhs); OCI.Load (rhs); OCC.PutF1 (OCC.NOT, size, rhs);
  1469.           OCC.PutF5 (OCC.AND, size, rhs, lhs)
  1470.         END
  1471.       ELSIF f # Undef THEN OCS.Mark (106)
  1472.       END
  1473.     |
  1474.     or :
  1475.       IF rhs.mode # Coc THEN
  1476.         IF rhs.mode = Con THEN
  1477.           IF rhs.a0 = 1 THEN setCC (rhs, OCC.T) ELSE setCC (rhs, OCC.F) END
  1478.         ELSIF rhs.mode <= Reg THEN test (rhs)
  1479.         ELSE OCS.Mark (95); setCC (rhs, OCC.EQ)
  1480.         END
  1481.       END;
  1482.       IF lhs.mode = Con THEN
  1483.         IF lhs.a0 = 1 THEN
  1484.           OCC.FixLink (rhs.a1); OCC.FixLink (rhs.a2); setCC (rhs, OCC.T)
  1485.         END;
  1486.         setCC (lhs, OCC.EQ)
  1487.       END;
  1488.       IF rhs.a1 # 0 THEN lhs.a1 := OCC.MergedLinks (lhs.a1, rhs.a1) END;
  1489.       lhs.a0 := rhs.a0; lhs.a2 := rhs.a2
  1490.     |
  1491.     eql :
  1492.       IF f IN eqSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.EQ)
  1493.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.EQ)
  1494.       ELSIF f = Bool THEN CompBool (OCC.EQ)
  1495.       ELSIF strings () THEN CompStrings (OCC.EQ, TRUE)
  1496.       ELSE OCS.Mark (107)
  1497.       END
  1498.     |
  1499.     neq :
  1500.       IF f IN eqSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.NE)
  1501.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.NE)
  1502.       ELSIF f = Bool THEN CompBool (OCC.NE)
  1503.       ELSIF strings () THEN CompStrings (OCC.NE, TRUE)
  1504.       ELSE OCS.Mark (107)
  1505.       END
  1506.     |
  1507.     lss :
  1508.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.LT)
  1509.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.CS)
  1510.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.LT)
  1511.       ELSIF strings () THEN CompStrings (OCC.CS, FALSE)
  1512.       ELSE OCS.Mark (108)
  1513.       END
  1514.     |
  1515.     leq :
  1516.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.LE)
  1517.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.LS)
  1518.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.LE)
  1519.       ELSIF strings () THEN CompStrings (OCC.LS, TRUE)
  1520.       ELSE OCS.Mark (108)
  1521.       END
  1522.     |
  1523.     gtr :
  1524.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.GT)
  1525.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.HI)
  1526.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.GT)
  1527.       ELSIF strings () THEN CompStrings (OCC.HI, TRUE)
  1528.       ELSE OCS.Mark (108)
  1529.       END
  1530.     |
  1531.     geq :
  1532.       IF f IN intSet THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.GE)
  1533.       ELSIF f = Char THEN cmp (lhs, rhs, freeRegs); setCC (lhs, OCC.CC)
  1534.       ELSIF f IN realSet THEN CmpReals (lhs, rhs); setCC (lhs, OCC.GE)
  1535.       ELSIF strings () THEN CompStrings (OCC.CC, FALSE)
  1536.       ELSE OCS.Mark (108)
  1537.       END
  1538.     |
  1539.   ELSE
  1540.     OCS.Mark (1013); OCS.Mark (op)
  1541.   END; (* CASE op *)
  1542.  
  1543.   IF freeRegs THEN OCI.Unload (rhs) END;
  1544.   (* ;OCG.TraceOut (mname, pname); *)
  1545. END Op;
  1546.  
  1547. END OCE.
  1548.  
  1549. (***************************************************************************
  1550.  
  1551.   $Log: OCE.mod $
  1552.   Revision 4.8  1994/08/03  11:42:47  fjc
  1553.   - Changed error numbers.
  1554.   - Fixed comparisons of BOOLEANS.
  1555.  
  1556.   Revision 4.7  1994/07/26  18:34:26  fjc
  1557.   *** empty log message ***
  1558.  
  1559.   Revision 4.6  1994/07/23  15:59:22  fjc
  1560.   - Implemented NIL checking.
  1561.  
  1562.   Revision 4.5  1994/07/22  14:08:56  fjc
  1563.   *** empty log message ***
  1564.  
  1565.   Revision 4.4  1994/07/10  13:11:46  fjc
  1566.   - Commented out trace code.
  1567.   - Fixed bug in DeRef() that allowed procedures to be
  1568.     dereferenced.
  1569.  
  1570.   Revision 4.3  1994/06/17  17:47:07  fjc
  1571.   - Implemented TagTyp
  1572.  
  1573.   Revision 4.2  1994/06/05  22:40:43  fjc
  1574.   - Fixed bug that failed to free registers when
  1575.     dereferencing BPointers.
  1576.  
  1577.   Revision 4.1  1994/06/01  09:33:44  fjc
  1578.   - Bumped version number
  1579.  
  1580. ***************************************************************************)
  1581.  
  1582.