home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 2 / goldfish_vol2_cd1.bin / files / dev / obero / oberon-a / source / oc / och.mod < prev    next >
Text File  |  1994-08-08  |  58KB  |  1,822 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: OCH.mod $
  4.   Description: Code selection for statements
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 4.11 $
  8.       $Author: fjc $
  9.         $Date: 1994/08/03 11:47:56 $
  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 OCH;
  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 SYS := SYSTEM, OCG, OCS, OCT, OCC, OCI, OCE;
  29.  
  30. (* --- Exported declarations -------------------------------------------- *)
  31.  
  32.  
  33. TYPE
  34.   LabelRange * = RECORD
  35.     low *, high * : LONGINT; label * : INTEGER
  36.   END; (* LabelRange *)
  37.  
  38.  
  39. (* --- Local declarations ----------------------------------------------- *)
  40.  
  41.  
  42. CONST
  43.  
  44.   (* Symbols *)
  45.  
  46.   null = OCS.null; times = OCS.times; slash = OCS.slash; div   = OCS.div;
  47.   mod  = OCS.mod;  and   = OCS.and;   plus  = OCS.plus;  minus = OCS.minus;
  48.   or   = OCS.or;   eql   = OCS.eql;   neq   = OCS.neq;   lss   = OCS.lss;
  49.   leq  = OCS.leq;  gtr   = OCS.gtr;   geq   = OCS.geq;   not   = OCS.not;
  50.  
  51.   (* object modes *)
  52.   Var = OCG.Var; VarX = OCG.VarX; VarR = OCG.VarR; Ind = OCG.Ind;
  53.   IndX = OCG.IndX; IndR = OCG.IndR; RegI = OCG.RegI; RegX = OCG.RegX;
  54.   Lab = OCG.Lab; LabI = OCG.LabI; Abs = OCG.Abs; Con = OCG.Con;
  55.   Push = OCG.Push; Pop = OCG.Pop; Coc = OCG.Coc; Reg = OCG.Reg;
  56.   Fld = OCG.Fld; LProc = OCG.LProc; XProc = OCG.XProc; TProc = OCG.TProc;
  57.   FProc = OCG.FProc; Mod = OCG.Mod; LibCall = OCG.LibCall;
  58.   RList = OCG.RList; VarArgMode = OCG.VarArg;
  59.  
  60.   regSet = {VarR, IndR, Reg};
  61.  
  62.   (* structure forms *)
  63.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  64.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  65.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  66.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  67.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  68.   Record = OCT.Record; BPointer = OCT.BPointer; CPointer = OCT.CPointer;
  69.   BSet = OCT.BSet; WSet = OCT.WSet; PtrTyp = OCT.PtrTyp;
  70.   CPtrTyp = OCT.CPtrTyp; BPtrTyp = OCT.BPtrTyp; Word = OCT.Word;
  71.   Longword = OCT.Longword; TagTyp = OCT.TagTyp;
  72.  
  73.   caseSet = {Char, SInt, Int, LInt};
  74.   ptrSet = {Pointer, CPointer, BPointer};
  75.   uptrSet = {CPointer, BPointer};
  76.   intSet = {SInt, Int, LInt};
  77.   byteSet = {Undef, Bool, Byte, Char, SInt, BSet};
  78.   wordSet = {Int, WSet, Word};
  79.   lwordSet =
  80.     { LInt, Real, LReal, Set, NilTyp, Pointer, ProcTyp, BPointer, CPointer,
  81.       PtrTyp, CPtrTyp, BPtrTyp, Longword };
  82.  
  83.   (* CPU Registers *)
  84.  
  85.   D0 = 0; D1 = 1; D2 = 2; D7 = 7;
  86.   A0 = 8; A1 = 9; A2 = 10; A3 = 11; A4 = 12; A5 = 13; A6 = 14; A7 = 15;
  87.   BP = A4; FP = A5; SP = A7;
  88.   DataRegs = {D0 .. D7};
  89.   AdrRegs = {A0 .. A7};
  90.  
  91.   (* Data sizes *)
  92.  
  93.   B = 1; W = 2; L = 4;
  94.  
  95. VAR
  96.   returnFound : BOOLEAN;
  97.  
  98. (* CONST mname = "OCH"; *)
  99.  
  100. (* --- Procedure declarations ------------------------------------------- *)
  101.  
  102.  
  103. (*------------------------------------*)
  104. PROCEDURE setCC (VAR x : OCT.Item; cc : LONGINT);
  105.  
  106. BEGIN (* setCC *)
  107.   x.typ := OCT.booltyp; x.mode := Coc; x.a0 := cc; x.a1 := 0; x.a2 := 0
  108. END setCC;
  109.  
  110. (*------------------------------------*)
  111. PROCEDURE FJ * (VAR loc : INTEGER);
  112.  
  113.   (* CONST pname = "FJ"; *)
  114.  
  115. BEGIN (* FJ *)
  116.   (* OCG.TraceIn (mname, pname); *)
  117.   OCC.PutWord (OCC.BRA); OCC.PutWord (loc); loc := OCC.pc - 2
  118.   (* ;OCG.TraceOut (mname, pname); *)
  119. END FJ;
  120.  
  121. (*------------------------------------*)
  122. PROCEDURE CFJ * (VAR x : OCT.Item; VAR loc : INTEGER);
  123.  
  124.   (* CONST pname = "CFJ"; *)
  125.  
  126.   VAR op : INTEGER;
  127.  
  128. BEGIN (* CFJ *)
  129.   (* OCG.TraceIn (mname, pname); *)
  130.   IF x.typ.form = Bool THEN
  131.     IF x.mode = Con THEN
  132.       IF x.a0 = 0 THEN setCC (x, OCC.F) ELSE setCC (x, OCC.T) END
  133.     ELSIF x.mode # Coc THEN
  134.       OCC.PutF1 (OCC.TST, B, x); OCI.Unload (x); setCC (x, OCC.NE)
  135.     END
  136.   ELSE
  137.     OCS.Mark (120); setCC (x, OCC.EQ)
  138.   END;
  139.   IF x.a0 # OCC.T THEN
  140.     IF x.a0 = OCC.F THEN op := OCC.BRA
  141.     ELSE op := OCC.Bcc + (OCC.invertedCC (x.a0) * 100H);
  142.     END;
  143.     OCC.PutWord (op); OCC.PutWord (x.a2); loc := OCC.pc - 2
  144.   ELSE
  145.     loc := x.a2
  146.   END;
  147.   OCC.FixLink (x.a1)
  148.   (* ;OCG.TraceOut (mname, pname); *)
  149. END CFJ;
  150.  
  151. (*------------------------------------*)
  152. PROCEDURE BJ * (loc : INTEGER);
  153.  
  154.   (* CONST pname = "BJ"; *)
  155.  
  156.   VAR dest : INTEGER;
  157.  
  158. BEGIN (* BJ *)
  159.   (* OCG.TraceIn (mname, pname); *)
  160.   dest := loc - OCC.pc - 2;
  161.   IF dest < -128 THEN OCC.PutWord (OCC.BRA); OCC.PutWord (dest)
  162.   ELSE OCC.PutWord (SYS.LOR (OCC.BRA, SYS.AND (dest, 0FFH)))
  163.   END
  164.   (* ;OCG.TraceOut (mname, pname); *)
  165. END BJ;
  166.  
  167. (*------------------------------------*)
  168. PROCEDURE CBJ * (VAR x : OCT.Item; loc : INTEGER);
  169.  
  170.   (* CONST pname = "CBJ"; *)
  171.  
  172.   VAR op, dest : INTEGER;
  173.  
  174. BEGIN (* CBJ *)
  175.   (* OCG.TraceIn (mname, pname); *)
  176.   IF x.typ.form = Bool THEN
  177.     IF x.mode = Con THEN
  178.       IF x.a0 = 0 THEN setCC (x, OCC.F) ELSE setCC (x, OCC.T) END
  179.     ELSIF x.mode # Coc THEN
  180.       OCC.PutF1 (OCC.TST, B, x); OCI.Unload (x); setCC (x, OCC.NE)
  181.     END
  182.   ELSE
  183.     OCS.Mark (120); setCC (x, OCC.EQ)
  184.   END;
  185.   IF x.a0 # OCC.T THEN
  186.     IF x.a0 = OCC.F THEN op := OCC.BRA
  187.     ELSE op := OCC.Bcc + (OCC.invertedCC (x.a0) * 100H);
  188.     END;
  189.     dest := loc - OCC.pc - 2;
  190.     IF dest < -128 THEN OCC.PutWord (op); OCC.PutWord (dest)
  191.     ELSE OCC.PutWord (SYS.LOR (op, SYS.AND (dest, 0FFH)))
  192.     END
  193.   END;
  194.   OCC.FixLinkWith (x.a2, loc); OCC.FixLink (x.a1)
  195.   (* ;OCG.TraceOut (mname, pname); *)
  196. END CBJ;
  197.  
  198. (*------------------------------------*)
  199. PROCEDURE ModulePrologue * ();
  200.  
  201.   (* CONST pname = "ModulePrologue"; *)
  202.  
  203.   VAR rc1, rc2 : OCT.Item;
  204.  
  205. BEGIN (* ModulePrologue *)
  206.   (* OCG.TraceIn (mname, pname); *)
  207.   OCC.StartPrologue ();
  208.  
  209.   (* Save initial stack pointer *)
  210.   OCC.PutWord (2C4FH);                                   (* MOVE.L A7, A6 *)
  211.  
  212.   (* Call OberonSys initialisation code *)
  213.   OCC.PutWord (4EB9H);
  214.   OCC.PutLongRef (0, OCT.OberonSysINIT);             (* JSR OberonSysINIT *)
  215.  
  216.   (* Branch to module initialisation code *)
  217.   OCC.PutWord (OCC.BSR);
  218.   OCC.PutWordRef (0, OCT.InitSymbol);                   (* BSR InitSymbol *)
  219.  
  220.   (* Set return code to 0 (clean exit) *)
  221.   rc1.mode := Con; rc1.a0 := 0; rc1.typ := OCT.linttyp;
  222.   rc2.mode := Lab; rc2.a0 := OCT.returnCode; rc2.a1 := 4;
  223.   rc2.typ := OCT.linttyp; rc2.symbol := OCT.OberonSysVAR;
  224.   OCC.Move (L, rc1, rc2);               (* MOVE.L #0,OberonSys.returnCode *)
  225.  
  226.   (* Jump to final cleanup code *)
  227.   OCC.PutWord (4EF9H);
  228.   OCC.PutLongRef (0, OCT.OberonSysCLEANUP);       (* JMP OberonSysCLEANUP *)
  229.  
  230.   OCC.EndCodeHunk ()
  231.   (* ;OCG.TraceOut (mname, pname); *)
  232. END ModulePrologue;
  233.  
  234. (*------------------------------------*)
  235. PROCEDURE StartProcedure * (proc : OCT.Object);
  236.  
  237.   (* CONST pname = "StartProcedure"; *)
  238.  
  239. BEGIN (* StartProcedure *)
  240.   (* OCG.TraceIn (mname, pname); *)
  241.   IF OCC.level = 1 THEN OCC.StartCodeHunk (FALSE) END
  242.   (* ;OCG.TraceOut (mname, pname); *)
  243. END StartProcedure;
  244.  
  245. (*------------------------------------*)
  246. PROCEDURE LoadBP (saveBP : BOOLEAN);
  247.  
  248.   (* CONST pname = "LoadBP"; *)
  249.  
  250. BEGIN (* LoadBP *)
  251.   (* OCG.TraceIn (mname, pname); *)
  252.   IF saveBP THEN OCC.PutWord (2F0CH) END;        (* MOVE.L BP,-(SP)       *)
  253.   OCC.PutWord (49F9H);
  254.   OCC.PutLongRef (0, OCT.VarSymbol)              (* LEA    Module_VAR, BP *)
  255.   (* ;OCG.TraceOut (mname, pname); *)
  256. END LoadBP;
  257.  
  258. (*------------------------------------*)
  259. PROCEDURE CopyDynArray (adr : LONGINT; typ : OCT.Struct; dsize : LONGINT);
  260.  
  261.   (* CONST pname = "CopyDynArray"; *)
  262.  
  263.   VAR size, len, desc, ptr1, ptr2, tos, x : OCT.Item;
  264.       moveSize : INTEGER; moveWords, oddSize : BOOLEAN; R : SET;
  265.  
  266.   (*------------------------------------*)
  267.   PROCEDURE DynArrSize (typ : OCT.Struct);
  268.  
  269.     (* CONST pname = "DynArrSize"; *)
  270.  
  271.   BEGIN (* DynArrSize *)
  272.     (* OCG.TraceIn (mname, pname); *)
  273.     IF typ.form = DynArr THEN
  274.       DynArrSize (typ.BaseTyp);
  275.       IF len.mode = Undef THEN
  276.         desc.mode := Var; desc.lev := OCC.level; desc.a0 := adr + typ.adr;
  277.         len.mode := Reg; len.a0 := D0; OCC.Move (L, desc, len);
  278.         desc.typ := OCT.linttyp; len.typ := OCT.linttyp
  279.       ELSE
  280.         IF desc.mode = Var THEN desc.a0 := adr + typ.adr;
  281.         ELSE desc.a1 := adr + typ.adr;
  282.         END;
  283.         OCE.Op (times, len, desc, TRUE)
  284.       END
  285.     ELSE
  286.       size.mode := Con; size.typ := OCT.linttyp; size.a0 := typ.size
  287.     END
  288.     (* ;OCG.TraceOut (mname, pname); *)
  289.   END DynArrSize;
  290.  
  291. BEGIN (* CopyDynArray *)
  292.   (* OCG.TraceIn (mname, pname); *)
  293.   IF OCS.saveRegs OR OCS.saveAllRegs THEN OCS.Mark (345) END;
  294.   R := OCC.RegSet; len.mode := Undef;
  295.  
  296.   (* load total length of dyn array *)
  297.   DynArrSize (typ);
  298.  
  299.   (* calculate size in bytes *)
  300.   oddSize := ODD (size.a0);
  301.   moveWords := ~oddSize & ((size.a0 MOD 4) # 0);
  302.   IF size.a0 > 1 THEN
  303.     OCE.Op (times, len, size, FALSE)
  304.   END;
  305.   IF oddSize THEN
  306.     x.mode := Con; x.a0 := 0; x.typ := OCT.inttyp;
  307.     OCC.Bit (OCC.BTST, x, len);                  (*    BTST   #0, <len>   *)
  308.     OCC.PutWord (6702H);                         (*    BEQ.S  1$          *)
  309.     OCC.PutF7 (OCC.ADDQ, L, 1, len)              (*    ADDQ.L #1, <len>   *)
  310.   END;                                           (* 1$                    *)
  311.   size := len;
  312.  
  313.   IF OCS.stackCheck THEN
  314.     x.mode := Lab; x.a0 := 0; x.a1 := 4; x.symbol := OCT.OberonSysSTACKCHK;
  315.     OCC.PutF3 (OCC.JSR, x)                       (*    JSR    STACKCHK    *)
  316.   END;
  317.  
  318.   (* adjust stack pointer *)
  319.   tos.mode := Reg; tos.a0 := SP;
  320.   OCC.PutF5 (OCC.SUB, L, size, tos);             (*    SUBA.L <size>, A7  *)
  321.  
  322.   (* decrement counter *)
  323.   x.mode := Con; x.typ := OCT.inttyp;
  324.   IF ~oddSize THEN
  325.     (* adjust counter for copy loop *)
  326.     IF moveWords THEN x.a0 := 1 ELSE x.a0 := 2 END;
  327.     OCC.Shift (OCC.ASR, L, x, size);             (*    ASR.L  #?, <size>  *)
  328.   END;
  329.   OCC.PutF7 (OCC.SUBQ, L, 1, size);              (*    SUBQ.L #1, <size>  *)
  330.  
  331.   ptr1.mode := Ind; ptr1.a0 := adr; ptr1.a1 := 0; ptr1.a2 := -1;
  332.   ptr1.lev := OCC.level; ptr1.typ := OCT.notyp;
  333.   x := ptr1; x.mode := Var;
  334.   OCI.LoadAdr (ptr1); ptr1.mode := Pop;          (*    LEA    adr(A5), An *)
  335.   OCC.Move (L, tos, x);                          (*    MOVE.L A7, adr(A5) *)
  336.   OCC.GetAReg (ptr2); OCC.Move (L, tos, ptr2);   (*    MOVE.L A7, Am      *)
  337.   ptr2.mode := Pop;
  338.  
  339.   IF oddSize THEN moveSize := B
  340.   ELSIF moveWords THEN moveSize := W
  341.   ELSE moveSize := L
  342.   END;
  343.   OCC.Move (moveSize, ptr1, ptr2);               (* 2$ MOVE.? (An)+,(Am)+ *)
  344.   OCC.PutWord (OCC.DBF + SHORT (size.a0));
  345.   OCC.PutWord (-4);                              (*    DBF    <size>, 2$  *)
  346.  
  347.   OCC.FreeRegs (R)
  348.   (* ;OCG.TraceOut (mname, pname); *)
  349. END CopyDynArray;
  350.  
  351. (*------------------------------------*)
  352. PROCEDURE StartProcBody * (proc : OCT.Object; dsize : LONGINT);
  353.  
  354.   (* CONST pname = "StartProcBody"; *)
  355.   CONST
  356.     (* Register numbers in *reverse* order. *)
  357.     D0 = 15; D1 = 14; D2 = 13; D7 = 8;
  358.     A0 = 7; A1 = 6; A2 = 5; A4 = 3; A5 = 2; A6 = 1;
  359.  
  360.   VAR
  361.     par : OCT.Object; x, y : OCT.Item; count : LONGINT;
  362.     usesA4, usesA5 : BOOLEAN; savedRegs : SET;
  363.  
  364. BEGIN (* StartProcBody *)
  365.   (* OCG.TraceIn (mname, pname); *)
  366.   (*proc.a1 := OCC.pc;*)
  367.   OCC.StartProcedure (proc);
  368.   IF OCS.stackCheck THEN
  369.     IF OCS.saveAllRegs THEN OCC.PutWord (2F00H) END; (* MOVE.L D0,-(A7) *)
  370.     x.mode := Con; x.a0 := dsize; x.typ := OCT.linttyp;
  371.     y.mode := Reg; y.a0 := 0; (* D0 *)
  372.     OCC.Move (L, x, y);
  373.     x.mode := Lab; x.a0 := 0; x.a1 := 4; x.symbol := OCT.OberonSysSTACKCHK;
  374.     OCC.PutF3 (OCC.JSR, x);
  375.     IF OCS.saveAllRegs THEN OCC.PutWord (201FH) END; (* MOVE.L (A7)+,D0 *)
  376.   END;
  377.   usesA4 := ((proc.mode = XProc)
  378.               OR ((proc.mode = TProc) & (proc.visible = OCT.Exp)))
  379.             & ~OCS.longVars;
  380.   usesA5 := (OCC.level # 1) OR (dsize # 0) OR OCI.IsParam (proc.link);
  381.   IF usesA4 THEN LoadBP (TRUE) END;
  382.   IF usesA5 THEN
  383.     IF (dsize > 0) & OCS.zeroVars THEN
  384.       OCC.PutWord (4E55H); OCC.PutWord (0);     (* LINK    A5,#0          *)
  385.  
  386.       (* Clear all procedure variables. *)
  387.       count := dsize DIV 4; (* clear longwords initially *)
  388.       IF count > 0 THEN
  389.         IF count < 5 THEN (* inline the loop *)
  390.           WHILE count > 0 DO
  391.             OCC.PutWord (42A7H);                (* CLR.L   -(A7)          *)
  392.             DEC (count)
  393.           END;
  394.         ELSE
  395.           IF OCS.saveAllRegs THEN OCC.PutWord (2F00H)  (* MOVE.L D0,-(A7) *)
  396.           END;
  397.           OCC.PutWord (303CH);
  398.           OCC.PutWord (SHORT (count) - 1);      (*    MOVE.W #count-1,D0  *)
  399.           OCC.PutWord (42A7H);                  (* 1$ CLR.L  -(A7)        *)
  400.           OCC.PutWord (OCC.DBF);
  401.           OCC.PutWord (-4);                     (*    DBF.W  D0,1$        *)
  402.           IF OCS.saveAllRegs THEN OCC.PutWord (201FH)  (* MOVE.L (A7)+,D0 *)
  403.           END;
  404.         END
  405.       END;
  406.       IF (dsize MOD 4) # 0 THEN (* Assuming dsize is a multiple of 2 *)
  407.         OCC.PutWord (4267H)                     (*    CLR.W  -(A7)        *)
  408.       END
  409.     ELSE
  410.       OCC.PutWord (4E55H);
  411.       OCC.PutWord (-SHORT (dsize))              (*    LINK   A5,#<-dsize> *)
  412.     END
  413.   END; (* IF *)
  414.   IF OCS.saveRegs OR OCS.saveAllRegs THEN
  415.     savedRegs := {A6..A2,D7..D2};
  416.     IF OCS.saveAllRegs THEN savedRegs := savedRegs + {A0,A1,D0,D1} END;
  417.     IF usesA4 THEN EXCL (savedRegs, A4) END;
  418.     IF usesA5 THEN EXCL (savedRegs, A5) END;
  419.     OCC.PutWord (48E7H);                       (* MOVEM.L savedRegs,-(A7) *)
  420.     OCC.PutWord (SYS.VAL (INTEGER, SHORT (savedRegs)))
  421.   END;
  422.  
  423.   IF OCS.copyDynArray THEN
  424.     par := proc.link;
  425.     WHILE par # NIL DO
  426.       (* code for dynamic array value parameters *)
  427.       IF (par.typ.form = DynArr) & (par.mode = Var) THEN
  428.         CopyDynArray (par.a0, par.typ, dsize)
  429.       END;
  430.       par := par.link
  431.     END
  432.   END;
  433.   returnFound := FALSE
  434.   (* ;OCG.TraceOut (mname, pname); *)
  435. END StartProcBody;
  436.  
  437. (*------------------------------------*)
  438. PROCEDURE EndProcBody *
  439.   (proc : OCT.Object; psize, L0 : INTEGER; vars : BOOLEAN);
  440.  
  441.   (* CONST pname = "EndProcBody"; *)
  442.  
  443.   VAR op : OCT.Item; usesA4, usesA5 : BOOLEAN; savedRegs : SET;
  444.  
  445. BEGIN (* EndProcBody *)
  446.   (* OCG.TraceIn (mname, pname); *)
  447.   usesA4 := ((proc.mode = XProc)
  448.               OR ((proc.mode = TProc) & (proc.visible = OCT.Exp)))
  449.             & ~OCS.longVars;
  450.   usesA5 := (OCC.level # 1) OR vars OR OCI.IsParam (proc.link);
  451.   IF usesA4 THEN
  452.     (* Don't count return address, frame pointer or global var base *)
  453.     DEC (psize, 12)
  454.   ELSE
  455.     (* Don't count return address or frame pointer *)
  456.     DEC (psize, 8)
  457.   END;
  458.   (* Insert trap for missing RETURN in function procedures. *)
  459.   IF (proc.typ # OCT.notyp) & OCS.returnCheck THEN
  460.     IF returnFound THEN OCC.Trap (OCC.ReturnCheck)
  461.     ELSE OCS.Mark (335)
  462.     END
  463.   END;
  464.   OCC.FixLink (L0); (* Fix up RETURN branches *)
  465.   IF OCS.saveRegs OR OCS.saveAllRegs THEN
  466.     savedRegs := {D2..D7,A2..A6};
  467.     IF OCS.saveAllRegs THEN savedRegs := savedRegs + {D0,D1,A0,A1} END;
  468.     IF usesA4 THEN EXCL (savedRegs, A4) END;
  469.     IF usesA5 THEN EXCL (savedRegs, A5) END;
  470.     OCC.PutWord (4CDFH);                        (* MOVEM.L (A7)+,savedRegs *)
  471.     OCC.PutWord (SYS.VAL (INTEGER, SHORT (savedRegs)))
  472.   END;
  473.   IF usesA5 THEN OCC.PutWord (4E5DH) END;       (* UNLK    A5             *)
  474.   IF usesA4 THEN OCC.PutWord (285FH) END;       (* MOVEA.L (A7)+, A4      *)
  475.   IF psize > 0 THEN
  476.     OCC.PutWord (2F57H); OCC.PutWord (psize);   (* MOVE.L  (SP),psize(SP) *)
  477.     IF psize <= 8 THEN
  478.       op.mode := Reg; op.a0 := SP;
  479.       OCC.PutF7 (OCC.ADDQ, L, psize, op)        (* ADDQ    #<psize>,SP    *)
  480.     ELSE
  481.       OCC.PutWord (4FEFH); OCC.PutWord (psize)  (* LEA     psize(SP),SP   *)
  482.     END
  483.   END;
  484.   OCC.PutWord (OCC.RTS);
  485.   IF OCC.level = 1 THEN OCC.EndCodeHunk () END
  486.   (* ;OCG.TraceOut (mname, pname); *)
  487. END EndProcBody;
  488.  
  489. (*------------------------------------*)
  490. PROCEDURE StartModuleBody * (VAR dsize : LONGINT; VAR L0 : INTEGER);
  491.  
  492.   (* CONST pname = "StartModuleBody"; *)
  493.  
  494.   VAR
  495.     op1, op2, op3 : OCT.Item; modno : INTEGER; module : OCT.Module;
  496.     count : LONGINT;
  497.  
  498. BEGIN (* StartModuleBody *)
  499.   (* OCG.TraceIn (mname, pname); *)
  500.   OCC.StartCodeHunk (TRUE);
  501.   IF ~OCS.longVars THEN LoadBP (FALSE) END;
  502.   (* Check if module already initialised *)
  503.   op1.mode := Var; op1.lev := 0; op1.a0 := dsize;
  504.   OCC.PutF1 (OCC.TST, B, op1);
  505.   (* If so, return *)
  506.   L0 := 0; op2.mode := Coc; op2.a0 := OCC.EQ; op2.a1 := 0; op2.a2 := 0;
  507.   op2.typ := OCT.booltyp; CFJ (op2, L0);
  508.  
  509.   IF OCS.garbageCollect & OCC.GlobalPtrs () THEN
  510.     op1.mode := Lab; op1.a0 := OCT.GCVars; op1.a1 := 4;
  511.     op1.symbol := OCT.OberonSysVAR;
  512.     op2.mode := Lab; op2.a0 := 0; op2.a1 := 4; op2.symbol := OCT.GCSymbol;
  513.     OCC.Move (L, op1, op2);
  514.     op2.mode := LabI; OCC.Move (L, op2, op1)
  515.   END;
  516.  
  517.   IF (dsize > 0) & OCS.zeroVars THEN
  518.     (* Clear all global variables. *)
  519.     OCC.GetAReg (op1);
  520.     IF OCS.longVars THEN
  521.       op2.mode := Lab; op2.a0 := 0; op2.a1 := 4;
  522.       op2.symbol := OCT.VarSymbol;
  523.       OCC.PutF2 (OCC.LEA, op2, op1.a0)        (*    LEA     Module_VAR,An *)
  524.     ELSE
  525.       op2.mode := Reg; op2.a0 := BP;
  526.       OCC.Move (L, op2, op1)                  (*    MOVE.L  A4,An         *)
  527.     END;
  528.     op1.mode := Pop; count := dsize DIV 4; (* clear longwords initially *)
  529.     IF count > 0 THEN
  530.       IF count < 5 THEN (* inline the loop *)
  531.         WHILE count > 0 DO OCC.PutF1 (OCC.CLR, L, op1); DEC (count) END;
  532.       ELSE
  533.         IF count > 65536 THEN OCS.Mark (312); count := 65536 END;
  534.         op3.mode := Con; op3.a0 := count - 1; op3.typ := OCT.inttyp;
  535.         OCC.GetDReg (op2);
  536.         OCC.Move (W, op3, op2);               (*    MOVE.W  #count,Dn     *)
  537.         OCC.PutF1 (OCC.CLR, L, op1);          (* 1$ CLR.L   (An)+         *)
  538.         OCC.PutWord (OCC.DBF + SHORT (op2.a0));
  539.         OCC.PutWord (-4);                     (*    DBF.W   Dn,1$         *)
  540.         OCC.FreeReg (op2)
  541.       END
  542.     END;
  543.     IF (dsize MOD 4) # 0 THEN (* Assuming dsize is a multiple of 2 *)
  544.       OCC.PutF1 (OCC.CLR, W, op1)             (*    CLR.W   (An)+         *)
  545.     END;
  546.     OCC.FreeReg (op1)
  547.   END;
  548.  
  549.   (* Set initialisation flag *)
  550.   op1.mode := Var; op1.lev := 0; op1.a0 := dsize; OCC.PutF3 (OCC.ST, op1);
  551.   (* Increment dsize to account for initFlag variable *)
  552.   INC (dsize, OCG.BoolSize); IF ODD (dsize) THEN INC (dsize) END;
  553.  
  554.   IF OCT.nofGmod > 0 THEN
  555.     IF ~OCS.longVars THEN
  556.       (* Save variable base pointer *)
  557.       OCC.PutWord (2F0CH)                              (* MOVE.L BP,-(SP) *)
  558.     END;
  559.     (* Call init code of imported modules *)
  560.     op1.mode := Lab; op1.a0 := 0; op1.a1 := 4; modno := 0;
  561.     WHILE modno < OCT.nofGmod DO
  562.       module := OCT.GlbMod [modno];
  563.       IF module.visible = OCT.Exp THEN
  564.         op1.symbol := module.symbol; OCC.PutF3 (OCC.JSR, op1)
  565.       END;
  566.       INC (modno)
  567.     END;
  568.     IF ~OCS.longVars THEN
  569.       (* Restore variable base pointer *)
  570.       OCC.PutWord (285FH)                            (* MOVEA.L (A7)+, A4 *)
  571.     END
  572.   END
  573.   (* ;OCG.TraceOut (mname, pname); *)
  574. END StartModuleBody;
  575.  
  576. (*------------------------------------*)
  577. PROCEDURE EndModuleBody * (L0 : INTEGER);
  578.  
  579.   (* CONST pname = "EndModuleBody"; *)
  580.  
  581.   VAR op1, op2 : OCT.Item;
  582.  
  583. BEGIN (* EndModuleBody *)
  584.   (* OCG.TraceIn (mname, pname); *)
  585.   OCC.FixLink (L0);
  586.   OCC.PutWord (OCC.RTS);
  587.   OCC.EndCodeHunk ()
  588.   (* ;OCG.TraceOut (mname, pname); *)
  589. END EndModuleBody;
  590.  
  591. (*------------------------------------*)
  592. PROCEDURE CompareParLists * (x, y : OCT.Object);
  593.  
  594.   (* CONST pname = "CompareParLists"; *)
  595.  
  596.   VAR xt, yt : OCT.Struct;
  597.  
  598. BEGIN (* CompareParLists *)
  599.   (* OCG.TraceIn (mname, pname); *)
  600.   WHILE x # NIL DO
  601.     IF y # NIL THEN
  602.       xt := x.typ; yt := y.typ;
  603.       WHILE (xt.form = DynArr) & (yt.form = DynArr) DO
  604.         xt := xt.BaseTyp; yt := yt.BaseTyp
  605.       END;
  606.       IF x.mode # y.mode THEN
  607.         OCS.Mark (115)
  608.       ELSIF xt # yt THEN
  609.         IF (xt.form = ProcTyp) & (yt.form = ProcTyp) THEN
  610.           CompareParLists (xt.link, yt.link)
  611.         ELSE
  612.           OCS.Mark (115)
  613.         END
  614.       END;
  615.       y := y.link
  616.     ELSE
  617.       OCS.Mark (116)
  618.     END;
  619.     x := x.link
  620.   END; (* WHILE *)
  621.   IF (y # NIL) & (y.mode <= Ind) & (y.a0 >= 0) THEN OCS.Mark (117) END
  622.   (* ;OCG.TraceOut (mname, pname); *)
  623. END CompareParLists;
  624.  
  625. (*------------------------------------*)
  626. PROCEDURE Leng (VAR x : OCT.Item; L0 : LONGINT);
  627.  
  628.   (* CONST pname = "Leng"; *)
  629.  
  630.   VAR y : OCT.Item;
  631.  
  632. BEGIN (* Leng *)
  633.   (* OCG.TraceIn (mname, pname); *)
  634.   IF x.mode = Push THEN y.mode := Abs; y.a0 := L0; OCC.PutF3 (OCC.PEA, y)
  635.   ELSE y.mode := Con; y.a0 := L0; y.typ := OCT.linttyp; OCC.Move (L, y, x)
  636.   END
  637.   (* ;OCG.TraceOut (mname, pname); *)
  638. END Leng;
  639.  
  640. (*------------------------------------*)
  641. PROCEDURE DynArrBnd (
  642.   ftyp : OCT.Struct; VAR ap : OCT.Item; varpar : BOOLEAN);
  643.  
  644.   (* CONST pname = "DynArrBnd"; *)
  645.  
  646.   VAR
  647.     f : INTEGER; x, y, z, desc : OCT.Item; atyp : OCT.Struct;
  648.     adr : LONGINT; freeY : BOOLEAN;
  649.  
  650. BEGIN (* DynArrBnd *)
  651.   (* OCG.TraceIn (mname, pname); *)
  652.   (* ftyp.form = DynArr *)
  653.   x.mode := Push; x.a0 := SP; atyp := ap.typ;
  654.   IF varpar & (ftyp.BaseTyp = OCT.bytetyp) THEN
  655.     IF atyp.form # DynArr THEN Leng (x, atyp.size)
  656.     ELSE
  657.       adr := atyp.adr; OCI.DescItem (desc, ap.desc, adr);
  658.       atyp := atyp.BaseTyp; freeY := FALSE;
  659.       IF atyp.form = DynArr THEN
  660.         OCC.GetDReg (y); OCC.Move (L, desc, y);
  661.         OCI.UpdateDesc (desc, adr); freeY := TRUE;
  662.         y.typ := OCT.linttyp;
  663.         REPEAT
  664.           OCI.DescItem (desc, ap.desc, atyp.adr);
  665.           OCE.Op (times, y, desc, FALSE);
  666.           atyp := atyp.BaseTyp
  667.         UNTIL atyp.form # DynArr;
  668.       ELSE
  669.         y := desc
  670.       END;
  671.       IF atyp.size > 1 THEN
  672.         z.mode := Con; z.a0 := atyp.size; z.typ := OCT.linttyp;
  673.         OCE.Op (times, y, z, FALSE)
  674.       END;
  675.       OCC.Move (L, y, x);
  676.       IF freeY THEN OCI.Unload (y) ELSE OCI.UnloadDesc (ap) END
  677.     END
  678.   ELSE
  679.     desc.mode := Undef;
  680.     LOOP
  681.       f := atyp.form;
  682.       IF f = Array THEN Leng (x, atyp.n)
  683.       ELSIF f = DynArr THEN
  684.         OCI.DescItem (desc, ap.desc, atyp.adr);
  685.         OCC.Move (L, desc, x); OCI.UpdateDesc (desc, atyp.adr)
  686.       ELSE OCS.Mark (66)
  687.       END;
  688.       ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp;
  689.       IF ftyp.form # DynArr THEN
  690.         IF ftyp # atyp THEN OCS.Mark (67) END;
  691.         EXIT
  692.       END
  693.     END; (* LOOP *)
  694.     OCI.UnloadDesc (ap)
  695.   END
  696.   (* ;OCG.TraceOut (mname, pname); *)
  697. END DynArrBnd;
  698.  
  699. (*------------------------------------*)
  700. PROCEDURE ExtendStack (size : LONGINT);
  701.  
  702.   VAR sp, x : OCT.Item;
  703.  
  704. BEGIN (* ExtendStack *)
  705.   sp.mode := Reg; sp.a0 := SP;
  706.   IF ODD (size) THEN INC (size) END;
  707.   IF size <= 8 THEN
  708.     OCC.PutF7 (OCC.SUBQ, L, size, sp)
  709.   ELSE
  710.     x.mode := RegI; x.a0 := SP; x.a1 := -size;
  711.     OCC.PutF2 (OCC.LEA, x, sp.a0)
  712.   END
  713. END ExtendStack;
  714.  
  715. (*------------------------------------*)
  716. PROCEDURE moveBW (VAR src, dst : OCT.Item; extend : BOOLEAN);
  717.  
  718.   (* CONST pname = "moveBW"; *)
  719.   VAR x, zero : OCT.Item;
  720.  
  721. BEGIN (* moveBW *)
  722.   (* OCG.TraceIn (mname, pname); *)
  723.   IF src.mode = Con THEN
  724.     OCC.Move (W, src, dst)
  725.   ELSE
  726.     IF ~extend THEN
  727.       zero.mode := Con; zero.a0 := 0; zero.typ := OCT.wordtyp;
  728.     END;
  729.     IF (dst.mode IN regSet) & (dst.a0 IN DataRegs) THEN
  730.       IF ~extend THEN OCC.Move (W, zero, dst) END;
  731.       OCC.Move (B, src, dst);
  732.       IF extend THEN OCI.EXT (W, dst.a0) END
  733.     ELSE
  734.       IF extend THEN
  735.         OCI.Load (src); OCI.EXT (W, src.a0)
  736.       ELSE
  737.         x := src; OCC.GetDReg (src);
  738.         OCC.Move (W, zero, src); OCC.Move (B, x, dst); OCI.Unload (x)
  739.       END;
  740.       OCC.Move (W, src, dst)
  741.     END
  742.   END
  743.   (* ;OCG.TraceOut (mname, pname); *)
  744. END moveBW;
  745.  
  746. (*------------------------------------*)
  747. PROCEDURE moveBL (VAR src, dst : OCT.Item; extend : BOOLEAN);
  748.  
  749.   (* CONST pname = "moveBL"; *)
  750.   VAR x, zero : OCT.Item;
  751.  
  752. BEGIN (* moveBL *)
  753.   (* OCG.TraceIn (mname, pname); *)
  754.   IF src.mode = Con THEN
  755.     OCC.Move (L, src, dst)
  756.   ELSE
  757.     IF ~extend THEN
  758.       zero.mode := Con; zero.a0 := 0; zero.typ := OCT.wordtyp;
  759.     END;
  760.     IF (dst.mode IN regSet) & (dst.a0 IN DataRegs) THEN
  761.       IF ~extend THEN OCC.Move (L, zero, dst) END;
  762.       OCC.Move (B, src, dst);
  763.       IF extend THEN OCI.EXT (W, dst.a0); OCI.EXT (L, dst.a0) END
  764.     ELSE
  765.       IF extend THEN
  766.         OCI.Load (src); OCI.EXT (W, src.a0); OCI.EXT (L, src.a0)
  767.       ELSE
  768.         x := src; OCC.GetDReg (src);
  769.         OCC.Move (L, zero, src); OCC.Move (B, x, src); OCI.Unload (x)
  770.       END;
  771.       OCC.Move (L, src, dst)
  772.     END
  773.   END
  774.   (* ;OCG.TraceOut (mname, pname); *)
  775. END moveBL;
  776.  
  777. (*------------------------------------*)
  778. PROCEDURE moveWL (VAR src, dst : OCT.Item; extend : BOOLEAN);
  779.  
  780.   (* CONST pname = "moveWL"; *)
  781.   VAR x, zero : OCT.Item;
  782.  
  783. BEGIN (* moveWL *)
  784.   (* OCG.TraceIn (mname, pname); *)
  785.   IF src.mode = Con THEN
  786.     OCC.Move (L, src, dst)
  787.   ELSE
  788.     IF ~extend THEN
  789.       zero.mode := Con; zero.a0 := 0; zero.typ := OCT.wordtyp;
  790.     END;
  791.     IF (dst.mode IN regSet) & (dst.a0 IN DataRegs) THEN
  792.       IF ~extend THEN OCC.Move (L, zero, dst) END;
  793.       OCC.Move (W, src, dst);
  794.       IF extend THEN OCI.EXT (L, dst.a0) END
  795.     ELSE
  796.       IF extend THEN
  797.         OCI.Load (src); OCI.EXT (L, src.a0)
  798.       ELSE
  799.         x := src; OCC.GetDReg (src);
  800.         OCC.Move (L, zero, src); OCC.Move (W, x, src); OCI.Unload (x)
  801.       END;
  802.       OCC.Move (L, src, dst)
  803.     END
  804.   END
  805.   (* ;OCG.TraceOut (mname, pname); *)
  806. END moveWL;
  807.  
  808. (*------------------------------------*)
  809. (*
  810.   Moves size bytes from src to dst.
  811. *)
  812. PROCEDURE moveBlock (VAR src, dst : OCT.Item; size : LONGINT);
  813.  
  814.   (* CONST pname = "moveBlock"; *)
  815.  
  816.   VAR
  817.     x, y : OCT.Item; numRegs, i, s : INTEGER; lw : LONGINT; R : SET;
  818.     useMOVEM, freeDst : BOOLEAN;
  819.  
  820. BEGIN (* moveBlock *)
  821.   (* OCG.TraceIn (mname, pname); *)
  822.   freeDst := FALSE;
  823.   (* size must be even, but it may be zero *)
  824.   IF ODD (size) THEN OCS.Mark (957); INC (size) END;
  825.   IF size = 2 THEN OCC.Move (W, src, dst)
  826.   ELSIF size = 4 THEN OCC.Move (L, src, dst)
  827.   ELSIF size > 0 THEN
  828.     R := {D0 .. D7} - OCC.RegSet; numRegs := 0; i := D0;
  829.     WHILE i <= D7 DO IF i IN R THEN INC (numRegs) END; INC (i) END;
  830.     IF (size MOD 4) = 2 THEN useMOVEM := ((numRegs * 2) >= size); s := W
  831.     ELSE useMOVEM := ((numRegs * 4) >= size); s := L
  832.     END;
  833.  
  834.     IF useMOVEM THEN
  835.       (* Calculate which registers are needed *)
  836.       numRegs := SHORT (size DIV s); i := 0;
  837.       WHILE numRegs > 0 DO
  838.         WHILE ~(i IN R) DO INC (i) END;
  839.         INC (i); DEC (numRegs)
  840.       END;
  841.       (* Discard the rest *)
  842.       WHILE i <= D7 DO EXCL (R, i); INC (i) END;
  843.       (* Reserve the registers *)
  844.       OCC.RegSet := OCC.RegSet + R;
  845.       (* Finally ... *)
  846.       x.mode := RList; x.a0 := SYS.VAL (LONGINT, R);
  847.       OCC.Move (s, src, x);                        (* MOVEM.s <src>,Dx-Dy *)
  848.       OCC.Move (s, x, dst);                        (* MOVEM.s Dx-Dy,<dst> *)
  849.       (* Free registers. *)
  850.       OCC.RegSet := OCC.RegSet - R;
  851.     ELSE
  852.       OCI.LoadAdr (src); src.mode := Pop;
  853.       IF dst.mode = Push THEN
  854.         ExtendStack (size);
  855.         y.mode := Reg; y.a0 := dst.a0;
  856.         OCC.GetAReg (dst); OCC.Move (L, y, dst);
  857.         dst.mode := Pop; dst.a1 := 0;
  858.         freeDst := TRUE
  859.       ELSE OCI.LoadAdr (dst); dst.mode := Pop
  860.       END;
  861.       lw := size DIV 4;
  862.       IF lw > 65536 THEN
  863.         x.mode := Con; x.a0 := lw; x.typ := OCT.linttyp;
  864.         OCI.Load (x);                            (*    MOVE.L #<size>,Dc  *)
  865.         OCC.Move (L, src, dst);                  (* 1$ MOVE.L (As)+,(Ad)+ *)
  866.         OCC.PutF7 (OCC.SUBQ, L, 1, x);           (*    SUBQ.L #1,Dc       *)
  867.         OCC.PutWord (66FAH);                     (*    BNE    1$          *)
  868.       ELSIF lw > 1 THEN
  869.         IF lw > 32768 THEN DEC (lw, 65536) END;
  870.         x.mode := Con; x.a0 := lw - 1; x.typ := OCT.inttyp;
  871.         OCI.Load (x);                            (*    MOVE.W #<size>,Dc  *)
  872.         OCC.Move (L, src, dst);                  (* 1$ MOVE.L (As)+,(Ad)+ *)
  873.         OCC.PutWord (OCC.DBF + SHORT (x.a0));
  874.         OCC.PutWord (-4)                         (*    DBF.W  Dc, 1$      *)
  875.       ELSIF lw = 1 THEN
  876.         OCC.Move (L, src, dst)
  877.       END;
  878.       IF (size MOD 4) = 2 THEN OCC.Move (W, src, dst) END;
  879.       IF freeDst THEN OCC.FreeReg (dst) END
  880.     END
  881.   END
  882.   (* ;OCG.TraceOut (mname, pname); *)
  883. END moveBlock;
  884.  
  885. (*------------------------------------*)
  886. PROCEDURE Assign * (VAR dst, src : OCT.Item; param : BOOLEAN);
  887.  
  888.   (* CONST pname = "Assign"; *)
  889.  
  890.   VAR f, g, op, L0, reg : INTEGER; s, vsz : LONGINT;
  891.       y, z, tag, tdes : OCT.Item; p, q : OCT.Struct; R : SET;
  892.       freeDst : BOOLEAN;
  893.  
  894.   (*------------------------------------*)
  895.   PROCEDURE IntToReal ();
  896.  
  897.     (* CONST pname = "IntToReal"; *)
  898.  
  899.     CONST SPFlt = -36;
  900.  
  901.     VAR r0, base, br : OCT.Item; R : SET; f : INTEGER;
  902.  
  903.   BEGIN (* IntToReal *)
  904.     (* OCG.TraceIn (mname, pname); *)
  905.     IF src.mode = Con THEN src.typ := OCT.linttyp END;
  906.     f := src.typ.form;
  907.     r0.mode := Reg; r0.a0 := D0; br.mode := Reg; br.a0 := A6;
  908.     base.mode := Lab; base.a0 := OCT.mathBase; base.a1 := 4;
  909.     base.symbol := OCT.OberonSysVAR;
  910.     OCC.LoadRegParams1 (R, src);
  911.     IF f = SInt THEN OCI.EXT (W, D0); f := Int END;
  912.     IF f = Int THEN OCI.EXT (L, D0) END;
  913.     OCC.Move (L, base, br);
  914.     br.mode := RegI; br.a1 := SPFlt; OCC.PutF3 (OCC.JSR, br);
  915.     OCC.RestoreRegisters (R, src);
  916.     OCC.Move (L, src, dst)
  917.     (* ;OCG.TraceOut (mname, pname); *)
  918.   END IntToReal;
  919.  
  920. BEGIN (* Assign *)
  921.   (* OCG.TraceIn (mname, pname); *)
  922.   IF dst.rdOnly THEN OCS.Mark (324) END;
  923.   f := dst.typ.form; g := src.typ.form;
  924.   IF dst.mode = Con THEN OCS.Mark (56) END;
  925.   CASE f OF
  926.     Undef :
  927.     |
  928.     Byte :
  929.       IF (g = String) & (src.a1 <= 2) THEN
  930.         src.a0 := src.a2; src.typ := OCT.chartyp; g := Char
  931.       END;
  932.       IF g IN byteSet THEN OCC.Move (B, src, dst)
  933.       ELSE OCS.Mark (113)
  934.       END
  935.     |
  936.     Word :
  937.       IF (g = String) & (src.a1 <= 2) THEN
  938.         src.a0 := src.a2; src.typ := OCT.chartyp; g := Char
  939.       END;
  940.       IF g IN wordSet THEN OCC.Move (W, src, dst)
  941.       ELSIF g IN byteSet THEN moveBW (src, dst, g = SInt)
  942.       ELSE OCS.Mark (113)
  943.       END
  944.     |
  945.     Longword :
  946.       IF (g = String) & (src.a1 <= 2) THEN
  947.         src.a0 := src.a2; src.typ := OCT.chartyp; g := Char
  948.       END;
  949.       IF g IN lwordSet THEN OCC.Move (L, src, dst)
  950.       ELSIF g IN wordSet THEN moveWL (src, dst, g = Int)
  951.       ELSIF g IN byteSet THEN moveBL (src, dst, g = SInt)
  952.       ELSE OCS.Mark (113)
  953.       END
  954.     |
  955.     Bool :
  956.       IF src.mode = Coc THEN
  957.         IF (dst.mode IN regSet) & (dst.a0 IN AdrRegs) THEN
  958.           y := dst; OCC.GetDReg (dst)
  959.         ELSE y.mode := Undef
  960.         END;
  961.         IF
  962.           ((src.a1 = 0) & (src.a2 = 0)) OR (src.a0 IN {OCC.T, OCC.F})
  963.         THEN
  964.           op := OCC.Scc + (SHORT (src.a0) * 100H); OCC.PutF3 (op, dst)
  965.         ELSE
  966.           op := OCC.Bcc + (OCC.invertedCC (src.a0) * 100H);
  967.           OCC.PutWord (op); OCC.PutWord (src.a2);       (*    Bcc   1$    *)
  968.           src.a2 := OCC.pc - 2; OCC.FixLink (src.a1);
  969.           z := dst; OCC.PutF3 (OCC.ST, z);              (*    ST    <dst> *)
  970.           L0 := OCC.pc; OCC.PutWord (6000H);            (*    BRA.S 2$    *)
  971.           OCC.FixLink (src.a2);
  972.           z := dst; OCC.PutF3 (OCC.SF, z);              (* 1$ SF    <dst> *)
  973.           OCC.PatchWord (L0, OCC.pc - L0 - 2);          (* 2$             *)
  974.         END;
  975.         IF y.mode # Undef THEN
  976.           OCC.Move (L, dst, y); OCI.Unload (dst) (*OCI.Unload (y)*)
  977.         END
  978.       ELSIF g = Bool THEN
  979.         IF src.mode = Con THEN
  980.           IF (dst.mode IN regSet) & (dst.a0 IN AdrRegs) THEN
  981.             y := dst; OCC.GetDReg (dst)
  982.           ELSE y.mode := Undef
  983.           END;
  984.           IF src.a0 = 0 THEN op := OCC.SF ELSE op := OCC.ST END;
  985.           OCC.PutF3 (op, dst);
  986.           IF y.mode # Undef THEN
  987.             OCC.Move (L, dst, y); OCI.Unload (dst) (*OCI.Unload (y)*)
  988.           END
  989.         ELSE
  990.           OCC.Move (B, src, dst)
  991.         END
  992.       ELSE OCS.Mark (113)
  993.       END
  994.     |
  995.     Char, SInt :
  996.       IF (g = String) & (src.a1 <= 2) THEN
  997.         src.a0 := src.a2; src.typ := OCT.chartyp; g := Char
  998.       END;
  999.       IF (g = f) OR (g = Byte) THEN OCC.Move (B, src, dst)
  1000.       ELSE OCS.Mark (113)
  1001.       END
  1002.     |
  1003.     Int :
  1004.       IF g IN {Int, Word} THEN OCC.Move (W, src, dst)
  1005.       ELSIF g = SInt THEN moveBW (src, dst, TRUE)
  1006.       ELSE OCS.Mark (113)
  1007.       END
  1008.     |
  1009.     LInt :
  1010.       IF g IN {LInt, Longword} THEN OCC.Move (L, src, dst)
  1011.       ELSIF g = Int THEN moveWL (src, dst, TRUE)
  1012.       ELSIF g = SInt THEN moveBL (src, dst, TRUE)
  1013.       ELSE OCS.Mark (113)
  1014.       END
  1015.     |
  1016.     BSet, WSet, Set :
  1017.       IF g = f THEN OCC.Move (src.typ.size, src, dst)
  1018.       ELSIF (g IN {BSet, WSet, Set}) & (src.mode = Con) THEN
  1019.         IF (f = BSet) & ((src.a0 < -128) OR (src.a0 > 255)) THEN
  1020.           OCS.Mark (113)
  1021.         ELSIF (f = WSet) & ((src.a0 < -32768) OR (src.a0 > 65535)) THEN
  1022.           OCS.Mark (113)
  1023.         ELSE
  1024.           OCC.Move (dst.typ.size, src, dst)
  1025.         END
  1026.       ELSE OCS.Mark (113)
  1027.       END
  1028.     |
  1029.     Real :
  1030.       IF g = Real THEN OCC.Move (L, src, dst)
  1031.       ELSIF g IN intSet THEN IntToReal ()
  1032.       ELSE OCS.Mark (113)
  1033.       END
  1034.     |
  1035.     LReal :
  1036.       IF g = LReal THEN OCC.Move (L, src, dst)
  1037.       ELSIF g = Real THEN OCC.Move (L, src, dst)
  1038.       ELSIF g IN intSet THEN IntToReal ()
  1039.       ELSE OCS.Mark (113)
  1040.       END
  1041.     |
  1042.     Pointer :
  1043.       IF (dst.typ = src.typ) OR (g = NilTyp) THEN
  1044.         p := dst.typ.BaseTyp;
  1045.         IF p = NIL THEN OCS.Mark (966); HALT (966) END;
  1046.         IF p.form = DynArr THEN
  1047.           IF param THEN
  1048.             IF g = NilTyp THEN
  1049.               WHILE (p # NIL) & (p.form = DynArr) DO
  1050.                 OCC.Move (L, src, dst);
  1051.                 p := p.BaseTyp
  1052.               END;
  1053.               OCC.Move (L, src, dst);
  1054.             ELSIF src.mode = RList THEN
  1055.               ExtendStack (p.size); dst.mode := RegI; dst.a1 := 0;
  1056.               OCC.Move (L, src, dst)
  1057.             ELSE
  1058.               IF src.mode IN {Ind, IndX, RegI, RegX} THEN
  1059.                 INC (src.a1, p.adr)
  1060.               ELSE
  1061.                 INC (src.a0, p.adr)
  1062.               END;
  1063.               WHILE (p # NIL) & (p.form = DynArr) DO
  1064.                 OCC.Move (L, src, dst);
  1065.                 IF src.mode IN {Ind, IndX, RegI, RegX} THEN DEC (src.a1, 4)
  1066.                 ELSE DEC (src.a0, 4)
  1067.                 END;
  1068.                 p := p.BaseTyp
  1069.               END;
  1070.               OCC.Move (L, src, dst)
  1071.             END
  1072.           ELSE
  1073.             IF g = NilTyp THEN
  1074.               IF dst.mode = RList THEN
  1075.                 R := SYS.VAL (SET, dst.a0); reg := D0; dst.mode := Reg;
  1076.                 WHILE reg <= A7 DO
  1077.                   IF reg IN R THEN
  1078.                     dst.a0 := reg; OCC.Move (L, src, dst)
  1079.                   END;
  1080.                   INC (reg)
  1081.                 END
  1082.               ELSE
  1083.                 WHILE (p # NIL) & (p.form = DynArr) DO
  1084.                   OCC.Move (L, src, dst);
  1085.                   IF dst.mode IN {Ind, IndX, RegI, RegX} THEN INC (dst.a1, 4)
  1086.                   ELSE INC (dst.a0, 4)
  1087.                   END;
  1088.                   p := p.BaseTyp
  1089.                 END;
  1090.                 OCC.Move (L, src, dst)
  1091.               END
  1092.             ELSIF (src.mode = RList) OR (dst.mode = RList) THEN
  1093.               OCC.Move (L, src, dst)
  1094.             ELSE
  1095.               moveBlock (src, dst, dst.typ.size)
  1096.             END
  1097.           END;
  1098.         ELSE OCC.Move (L, src, dst)
  1099.         END
  1100.       ELSIF g = Pointer THEN
  1101.         p := dst.typ.BaseTyp; q := src.typ.BaseTyp;
  1102.         IF (p.form = Record) & (q.form = Record) THEN
  1103.           WHILE (q # p) & (q # NIL) DO q := q.BaseTyp END;
  1104.           IF q # NIL THEN OCC.Move (L, src, dst)
  1105.           ELSE OCS.Mark (113)
  1106.           END
  1107.         ELSE OCS.Mark (113)
  1108.         END
  1109.       ELSE OCS.Mark (113)
  1110.       END
  1111.     |
  1112.     CPointer :
  1113.       IF (dst.typ = src.typ) OR (g IN {CPtrTyp, NilTyp}) THEN
  1114.         OCC.Move (L, src, dst)
  1115.       ELSIF g = CPointer THEN
  1116.         p := dst.typ.BaseTyp; q := src.typ.BaseTyp;
  1117.         IF p = q THEN
  1118.           OCC.Move (L, src, dst)
  1119.         ELSIF (p.form = Record) & (q.form = Record) THEN
  1120.           WHILE (q # p) & (q # NIL) DO q := q.BaseTyp END;
  1121.           IF q # NIL THEN OCC.Move (L, src, dst)
  1122.           ELSE OCS.Mark (113)
  1123.           END
  1124.         ELSE OCS.Mark (113)
  1125.         END
  1126.       ELSE OCS.Mark (113)
  1127.       END
  1128.     |
  1129.     BPointer :
  1130.       IF (dst.typ = src.typ) OR (g = NilTyp) THEN
  1131.         OCC.Move (L, src, dst)
  1132.       ELSE OCS.Mark (113)
  1133.       END
  1134.     |
  1135.     PtrTyp :
  1136.       IF (g IN {Pointer, PtrTyp, NilTyp}) THEN
  1137.         OCC.Move (L, src, dst)
  1138.       ELSE OCS.Mark (113)
  1139.       END
  1140.     |
  1141.     CPtrTyp :
  1142.       IF (g IN {CPointer, CPtrTyp, NilTyp}) THEN
  1143.         OCC.Move (L, src, dst)
  1144.       ELSE OCS.Mark (113)
  1145.       END
  1146.     |
  1147.     BPtrTyp :
  1148.       IF (g IN {BPointer, BPtrTyp, NilTyp}) THEN
  1149.         OCC.Move (L, src, dst)
  1150.       ELSE OCS.Mark (113)
  1151.       END
  1152.     |
  1153.     Array :
  1154.       IF ~(dst.mode IN ptrSet) THEN
  1155.         IF dst.typ = src.typ THEN
  1156.           moveBlock (src, dst, dst.typ.size)
  1157.         ELSIF (g = String) & (dst.typ.BaseTyp = OCT.chartyp) THEN
  1158.           freeDst := FALSE;
  1159.           IF dst.mode = Push THEN
  1160.             ExtendStack (dst.typ.size);
  1161.             y.mode := Reg; y.a0 := dst.a0;
  1162.             OCC.GetAReg (dst); OCC.Move (L, y, dst);
  1163.             dst.mode := RegI; dst.a1 := 0;
  1164.             freeDst := TRUE
  1165.           END;
  1166.           z.mode := Con; z.typ := OCT.inttyp; z.a0 := src.a1 - 1;
  1167.           vsz := dst.typ.n - 1; IF z.a0 > vsz THEN OCS.Mark (114) END;
  1168.           OCI.CopyString (src, dst, z);
  1169.           IF freeDst THEN OCC.FreeReg (dst) END
  1170.         ELSE
  1171.           OCS.Mark (113)
  1172.         END
  1173.       ELSE
  1174.         OCS.Mark (904)
  1175.       END
  1176.     |
  1177.     DynArr :
  1178.       IF param THEN (* formal parameter is open array *)
  1179.         IF (dst.mode = VarR) OR (dst.mode = IndR) THEN
  1180.           (* Register parameter, address only *)
  1181.           IF
  1182.             (dst.typ.BaseTyp = OCT.bytetyp)
  1183.             OR ((g = String) & (dst.typ.BaseTyp.form = Char))
  1184.             OR ((g IN {Array, DynArr})
  1185.               & (src.typ.BaseTyp = dst.typ.BaseTyp))
  1186.           THEN
  1187.             IF (g = String) & (dst.typ.BaseTyp.form = Char) THEN
  1188.               IF src.a1 = 2 THEN OCC.AllocStringFromChar (src) END;
  1189.               IF src.a1 = 1 THEN (* Pass NIL for an empty string *)
  1190.                 src.mode := Con; src.a0 := 0;
  1191.                 OCC.Move (L, src, dst)
  1192.               ELSE
  1193.                 OCI.MoveAdr (src, dst)
  1194.               END
  1195.             ELSE
  1196.               OCI.MoveAdr (src, dst)
  1197.             END;
  1198.           ELSE
  1199.             OCS.Mark (59)
  1200.           END
  1201.         ELSE
  1202.           IF (g = String) & (dst.typ.BaseTyp.form = Char) THEN
  1203.             Leng (dst, src.a1);
  1204.             IF src.a1 < 3 THEN OCC.AllocStringFromChar (src) END
  1205.           ELSIF src.mode >= Abs THEN
  1206.             OCS.Mark (59)
  1207.           ELSE
  1208.             DynArrBnd (dst.typ, src, FALSE)
  1209.           END;
  1210.           IF (g = DynArr) OR (src.mode IN {Ind, IndX}) THEN
  1211.             OCI.MoveAdr (src, dst)
  1212.           ELSE
  1213.             OCC.PutF3 (OCC.PEA, src)
  1214.           END
  1215.         END
  1216.       ELSE
  1217.         OCS.Mark (113)
  1218.       END
  1219.     |
  1220.     Record :
  1221.       IF (dst.mode IN regSet) (*& (src.typ.size > PtrSize)*) THEN
  1222.         OCS.Mark (904)
  1223.       ELSE
  1224.         IF dst.typ # src.typ THEN
  1225.           IF g = Record THEN
  1226.             q := src.typ.BaseTyp;
  1227.             WHILE (q # NIL) & (q # dst.typ) DO q := q.BaseTyp END;
  1228.             IF q = NIL THEN OCS.Mark (113) END
  1229.           ELSE
  1230.             OCS.Mark (113)
  1231.           END
  1232.         END;
  1233.         IF
  1234.           OCS.typeCheck & ~param
  1235.           & ( ( (dst.mode = Ind) OR (dst.mode = RegI))
  1236.                 & ((dst.obj = OCC.wasderef) & (dst.a2 = Pointer))
  1237.           (* p^ := *)
  1238.               OR (dst.mode = Ind) & (dst.obj # NIL) & (dst.obj # OCC.wasderef))
  1239.           (* varpar := *)
  1240.         THEN
  1241.           R := OCC.RegSet; tag := dst;
  1242.           IF dst.obj = OCC.wasderef THEN tag.a1 := -4
  1243.           ELSE tag.mode := Var; INC (tag.a0, 4)
  1244.           END;
  1245.           tdes.mode := LabI; tdes.a0 := 0; tdes.a1 := 4;
  1246.           tdes.symbol := dst.typ.symbol;
  1247.           OCC.PutF5 (OCC.CMP, L, tdes, tag);
  1248.           OCC.TrapCC (OCC.TypeCheck, OCC.NE);
  1249.           OCC.FreeRegs (R)
  1250.         END;
  1251.         moveBlock (src, dst, dst.typ.size)
  1252.       END
  1253.     |
  1254.     ProcTyp :
  1255.       IF (dst.typ = src.typ) OR (g = NilTyp) THEN
  1256.         OCC.Move (L, src, dst)
  1257.       ELSIF src.mode = XProc THEN
  1258.         (* procedure dest to proc. variable, check compatibility *)
  1259.         IF dst.typ.BaseTyp = src.typ THEN
  1260.           CompareParLists (dst.typ.link, src.obj.link);
  1261.           OCI.MoveAdr (src, dst)
  1262.         ELSE OCS.Mark (118)
  1263.         END
  1264.       ELSIF src.mode = LProc THEN OCS.Mark (119)
  1265.       ELSIF src.mode = TProc THEN OCS.Mark (331)
  1266.       ELSIF src.mode = FProc THEN OCS.Mark (341)
  1267.       ELSE OCS.Mark (111)
  1268.       END
  1269.     |
  1270.     TagTyp :
  1271.       IF (f = g) OR (g = NilTyp) THEN
  1272.         OCC.Move (L, src, dst)
  1273.       ELSE
  1274.         OCS.Mark (111)
  1275.       END
  1276.     |
  1277.     NoTyp, NilTyp : OCS.Mark (111)
  1278.     |
  1279.   ELSE
  1280.     OCS.Mark (1016); OCS.Mark (f)
  1281.   END; (* CASE f *)
  1282.   OCI.Unload (src)
  1283.   (* ;OCG.TraceOut (mname, pname); *)
  1284. END Assign;
  1285.  
  1286. (*------------------------------------*)
  1287. PROCEDURE RegsUsed ( fpar : OCT.Object ) : SET;
  1288.  
  1289.   VAR result : SET;
  1290.  
  1291. BEGIN (* RegsUsed *)
  1292.   result := {};
  1293.   WHILE fpar # NIL DO
  1294.     IF fpar.mode IN {VarR, IndR, VarArgMode} THEN
  1295.       INCL (result, fpar.a0)
  1296.     END;
  1297.     fpar := fpar.link
  1298.   END;
  1299.   RETURN result
  1300. END RegsUsed;
  1301.  
  1302. (*------------------------------------*)
  1303. PROCEDURE PrepCall *
  1304.   ( VAR x    : OCT.Item;
  1305.     VAR fpar : OCT.Object;
  1306.     VAR mask : SET );
  1307.  
  1308.   (* CONST pname = "PrepCall"; *)
  1309.  
  1310. BEGIN (* PrepCall *)
  1311.   (* OCG.TraceIn (mname, pname); *)
  1312.   mask := OCC.AllRegs;
  1313.   IF x.mode IN {LProc, XProc, FProc} THEN
  1314.     fpar := x.obj.link
  1315.   ELSIF (x.mode = LibCall) OR (x.mode = TProc) THEN
  1316.     fpar := x.obj.link.link;
  1317.     IF x.mode = LibCall THEN
  1318.       mask := OCC.ScratchRegs + RegsUsed (fpar)
  1319.     END;
  1320.   ELSIF (x.typ # NIL) & (x.typ.form = ProcTyp) THEN
  1321.     fpar := x.typ.link
  1322.   ELSE
  1323.     OCS.Mark (121); fpar := NIL; x.typ := OCT.undftyp
  1324.   END
  1325.   (* ;OCG.TraceOut (mname, pname); *)
  1326. END PrepCall;
  1327.  
  1328. (*------------------------------------*)
  1329. PROCEDURE VarArg *
  1330.   ( VAR ap : OCT.Item; fpo : OCT.Object;
  1331.     VAR stackload : LONGINT; load : BOOLEAN );
  1332.  
  1333.   (* CONST pname = "VarArg"; *)
  1334.  
  1335.   VAR fp, reg : OCT.Item;
  1336.  
  1337. BEGIN (* VarArg *)
  1338.   (* OCG.TraceIn (mname, pname); *)
  1339.   fp.mode := Push; fp.a0 := A7; fp.typ := fpo.typ; fp.rdOnly := FALSE;
  1340.   Assign (fp, ap, TRUE); INC (stackload, fp.typ.size);
  1341.   IF load THEN
  1342.     fp.mode := Reg; reg.mode := Reg; reg.a0 := fpo.a0;
  1343.     OCC.ReserveReg (SHORT (reg.a0));
  1344.     OCC.Move (L, fp, reg)
  1345.   END;
  1346.   (* ;OCG.TraceOut (mname, pname); *)
  1347. END VarArg;
  1348.  
  1349. (*------------------------------------*)
  1350. PROCEDURE RegParam (VAR ap : OCT.Item; fpo : OCT.Object);
  1351.  
  1352.   (* CONST pname = "RegParam"; *)
  1353.  
  1354.   VAR fp, t : OCT.Item; q : OCT.Struct; f, g : INTEGER;
  1355.  
  1356. BEGIN (* RegParam *)
  1357.   (* OCG.TraceIn (mname, pname); *)
  1358.   fp.mode := fpo.mode; fp.a0 := fpo.a0; fp.typ := fpo.typ;
  1359.   fp.rdOnly := FALSE; f := fp.typ.form; g := ap.typ.form;
  1360.   IF fpo.mode = IndR THEN (* VAR parameter *)
  1361.     IF ap.mode >= Con THEN OCS.Mark (122)
  1362.     ELSIF ap.rdOnly THEN OCS.Mark (324)
  1363.     END;
  1364.     IF fp.typ.form = DynArr THEN
  1365.       IF
  1366.         (fp.typ.BaseTyp = OCT.bytetyp)
  1367.         OR ((ap.typ.form IN {Array, DynArr})
  1368.           & (fp.typ.BaseTyp = ap.typ.BaseTyp))
  1369.       THEN
  1370.         OCI.MoveAdr (ap, fp)
  1371.       ELSE
  1372.         OCS.Mark (111)
  1373.       END
  1374.     ELSIF (fp.typ.form = Record) & (ap.typ.form = Record) THEN
  1375.       q := ap.typ; WHILE (q # fp.typ) & (q # NIL) DO q := q.BaseTyp END;
  1376.       IF q # NIL THEN
  1377.         OCI.MoveAdr (ap, fp)
  1378.       ELSE
  1379.         OCS.Mark (111)
  1380.       END
  1381.     ELSIF
  1382.       (ap.typ = fp.typ)
  1383.       OR ((f = Byte)     & (g IN {Char, SInt, BSet}))
  1384.       OR ((f = Word)     & (g IN wordSet))
  1385.       OR ((f = Longword) & (g IN lwordSet))
  1386.       OR ((f = PtrTyp)   & (g IN {Pointer, PtrTyp}))
  1387.       OR ((f = CPtrTyp)  & (g IN {CPointer, CPtrTyp}))
  1388.       OR ((f = BPtrTyp)  & (g IN {BPointer, BPtrTyp}))
  1389.     THEN
  1390.       OCI.MoveAdr (ap, fp)
  1391.     ELSE OCS.Mark (123)
  1392.     END;
  1393.     OCI.Unload (ap)
  1394.   ELSE
  1395.     Assign (fp, ap, TRUE)
  1396.   END;
  1397.   OCC.ReserveReg (SHORT (fp.a0))
  1398.   (* ;OCG.TraceOut (mname, pname); *)
  1399. END RegParam;
  1400.  
  1401. (*------------------------------------*)
  1402. PROCEDURE Param * (VAR ap : OCT.Item; fpo : OCT.Object);
  1403.  
  1404.   (* CONST pname = "Param"; *)
  1405.  
  1406.   VAR
  1407.     fp, t : OCT.Item; q : OCT.Struct; freeFp : BOOLEAN; f, g : INTEGER;
  1408.     s : LONGINT;
  1409.  
  1410. BEGIN (* Param *)
  1411.   (* OCG.TraceIn (mname, pname); *)
  1412.   IF (fpo.mode = VarR) OR (fpo.mode = IndR) THEN RegParam (ap, fpo)
  1413.   ELSE
  1414.     fp.mode := Push; fp.a0 := SP; fp.typ := fpo.typ; fp.rdOnly := FALSE;
  1415.     f := fpo.typ.form; g := ap.typ.form;
  1416.     IF fpo.mode = Ind THEN (* VAR parameter *)
  1417.       IF ap.mode >= Con THEN OCS.Mark (122)
  1418.       ELSIF ap.rdOnly THEN OCS.Mark (324)
  1419.       END;
  1420.       IF fp.typ.form = DynArr THEN
  1421.         DynArrBnd (fp.typ, ap, TRUE);
  1422.         IF (ap.typ.form = DynArr) OR (ap.mode IN {Ind, IndX}) THEN
  1423.           OCI.MoveAdr (ap, fp)
  1424.         ELSE OCC.PutF3 (OCC.PEA, ap)
  1425.         END;
  1426.         OCI.Unload (ap)
  1427.       ELSIF (fp.typ.form = Record) & (ap.typ.form = Record) THEN
  1428.         q := ap.typ; WHILE (q # fp.typ) & (q # NIL) DO q := q.BaseTyp END;
  1429.         IF q # NIL THEN
  1430.           IF (ap.mode = Ind) & (ap.obj # NIL) & (ap.obj # OCC.wasderef) THEN
  1431.             (* actual parameter is a VAR parameter *)
  1432.             ap.mode := Var; INC (ap.a0, 4); OCC.Move (L, ap, fp);
  1433.             IF ap.mode = Var THEN DEC (ap.a0, 4) ELSE DEC (ap.a1, 4) END;
  1434.             OCC.Move (L, ap, fp)
  1435.           ELSIF
  1436.             ((ap.mode = Ind) OR (ap.mode = RegI)) & (ap.obj = OCC.wasderef)
  1437.           THEN
  1438.             (* actual parameter is a dereferenced pointer *)
  1439.             IF ap.a2 = Pointer THEN
  1440.               ap.a1 := -4; OCC.Move (L, ap, fp);
  1441.               ap.a1 := 0; OCI.MoveAdr (ap, fp)
  1442.             ELSIF ap.a2 IN uptrSet THEN
  1443.               t.mode := Lab; t.a0 := 0; t.a1 := 4;
  1444.               t.symbol := ap.typ.symbol;
  1445.               OCC.PutF3 (OCC.PEA, t); OCI.MoveAdr (ap, fp)
  1446.             ELSE
  1447.               OCS.Mark (111)
  1448.             END
  1449.           ELSE
  1450.             t.mode := Lab; t.a0 := 0; t.a1 := 4; t.symbol := ap.typ.symbol;
  1451.             OCC.PutF3 (OCC.PEA, t); OCC.PutF3 (OCC.PEA, ap)
  1452.           END
  1453.         ELSE
  1454.           OCS.Mark (111)
  1455.         END;
  1456.         OCI.Unload (ap)
  1457.       ELSIF
  1458.         (ap.typ = fp.typ)
  1459.         OR ((f = Byte)     & (g IN {Char, SInt, BSet}))
  1460.         OR ((f = Word)     & (g IN wordSet))
  1461.         OR ((f = Longword) & (g IN lwordSet))
  1462.         OR ((f = PtrTyp)   & (g IN {Pointer, PtrTyp}))
  1463.         OR ((f = CPtrTyp)  & (g IN {CPointer, CPtrTyp}))
  1464.         OR ((f = BPtrTyp)  & (g IN {BPointer, BPtrTyp}))
  1465.       THEN
  1466.         IF ap.mode IN {Ind, IndX} THEN OCI.MoveAdr (ap, fp)
  1467.         ELSE OCC.PutF3 (OCC.PEA, ap)
  1468.         END;
  1469.         OCI.Unload (ap)
  1470.       ELSE
  1471.         OCS.Mark (123)
  1472.       END
  1473.     ELSE
  1474.       (*
  1475.       freeFp := FALSE;
  1476.       IF fp.typ.form IN {Array, Record} THEN
  1477.         fp.mode := Reg;
  1478.         IF fp.typ.size <= 8 THEN
  1479.           s := fp.typ.size; IF ODD (s) THEN INC (s) END;
  1480.           OCC.PutF7 (OCC.SUBQ, L, s, fp)
  1481.         ELSE
  1482.           t.mode := RegI; t.a0 := SP; t.a1 := -fp.typ.size;
  1483.           IF ODD (t.a1) THEN DEC (t.a1) END;
  1484.           OCC.PutF2 (OCC.LEA, t, fp.a0)
  1485.         END;
  1486.         OCC.GetAReg (t); OCC.Move (L, fp, t);
  1487.         fp.mode := RegI; fp.a0 := t.a0; fp.a1 := 0;
  1488.         freeFp := TRUE
  1489.       END;
  1490.       *)
  1491.       Assign (fp, ap, TRUE);
  1492.       (*IF freeFp THEN OCI.Unload (fp) END*)
  1493.     END
  1494.   END
  1495.   (* ;OCG.TraceOut (mname, pname); *)
  1496. END Param;
  1497.  
  1498. (*------------------------------------*)
  1499. PROCEDURE Receiver * (VAR x : OCT.Item; rcvr : OCT.Object);
  1500.  
  1501.   (* CONST pname = "Receiver"; *)
  1502.  
  1503.   VAR y : OCT.Item;
  1504.  
  1505. BEGIN (* Receiver *)
  1506.   (* OCG.TraceIn (mname, pname); *)
  1507.   y := x;
  1508.   IF (y.typ.form IN ptrSet) & (rcvr.mode = Ind) THEN OCE.DeRef (y) END;
  1509.   Param (y, rcvr)
  1510.   (* ;OCG.TraceOut (mname, pname); *)
  1511. END Receiver;
  1512.  
  1513.  
  1514. (*------------------------------------*)
  1515. PROCEDURE Call * (VAR x : OCT.Item);
  1516.  
  1517.   (* CONST pname = "Call"; *)
  1518.  
  1519.   VAR y, z : OCT.Item;
  1520.  
  1521. BEGIN (* Call *)
  1522.   (* OCG.TraceIn (mname, pname); *)
  1523.   IF x.mode = LProc THEN
  1524.     IF x.lev > 0 THEN
  1525.       y.mode := Var; y.typ := OCT.linttyp;
  1526.       IF x.lev = OCC.level THEN
  1527.         y.lev := x.lev; y.a0 := 0; OCC.PutF3 (OCC.PEA, y)
  1528.       ELSE
  1529.         y.lev := x.lev + 1; y.a0 := 8; z.mode := Push; z.a0 := SP;
  1530.         OCC.Move (L, y, z)
  1531.       END
  1532.     END;
  1533.     OCC.PutWord (OCC.BSR); OCC.PutWordRef (0, x.symbol)
  1534.   ELSIF x.mode IN {XProc, FProc} THEN
  1535.     IF x.lev = 0 THEN
  1536.       OCC.PutWord (OCC.BSR); OCC.PutWordRef (0, x.symbol)
  1537.     ELSE
  1538.       OCC.PutF3 (OCC.JSR, x)
  1539.     END
  1540.   ELSIF (x.mode < Con) & (x.typ # OCT.undftyp) THEN (* procedure variable *)
  1541.     y := x; y.typ := OCT.ptrtyp; OCC.GetAReg (x);
  1542.     IF OCS.nilCheck THEN
  1543.       OCI.Load (y);                               (*    MOVE.L  x,Dn      *)
  1544.       OCC.PutWord (6602H);                        (*    BNE     1$        *)
  1545.       OCC.PutWord (OCC.TRAP + OCC.NilCheck);      (*    TRAP    #NilCheck *)
  1546.     END;                                          (* 1$                   *)
  1547.     OCC.Move (L, y, x); OCI.Unload (y); x.mode := RegI;
  1548.     x.a1 := 0; OCC.PutF3 (OCC.JSR, x); x.typ := x.typ.BaseTyp
  1549.   ELSE
  1550.     OCS.Mark (121)
  1551.   END
  1552.   (* ;OCG.TraceOut (mname, pname); *)
  1553. END Call;
  1554.  
  1555. (*-------------------------------------------*)
  1556. PROCEDURE CallLibCall * (VAR x, rcvr : OCT.Item; stackload : LONGINT);
  1557.  
  1558.   (* CONST pname = "CallLibCall"; *)
  1559.  
  1560.   VAR y, sp : OCT.Item;
  1561.  
  1562. BEGIN (* CallLibCall *)
  1563.   (* OCG.TraceIn (mname, pname); *)
  1564.   (* x.mode = LibCall *)
  1565.   y.mode := Reg; y.a0 := A6; OCC.Move (L, rcvr, y);
  1566.   y.mode := RegI; y.a1 := x.a0; OCC.PutF3 (OCC.JSR, y);
  1567.   IF stackload > 0 THEN
  1568.     IF stackload <= 8 THEN
  1569.       sp.mode := Reg; sp.a0 := SP;
  1570.       OCC.PutF7 (OCC.ADDQ, L, stackload, sp)
  1571.     ELSE
  1572.       sp.mode := RegI; sp.a0 := SP; sp.a1 := stackload;
  1573.       OCC.PutF2 (OCC.LEA, sp, SP)
  1574.     END;
  1575.   END;
  1576.   (* ;OCG.TraceOut (mname, pname); *)
  1577. END CallLibCall;
  1578.  
  1579. (*------------------------------------*)
  1580. PROCEDURE CallTypeBound * (VAR x, rcvr : OCT.Item);
  1581.  
  1582.   (* CONST pname = "CallTypeBound"; *)
  1583.  
  1584.   VAR y, z : OCT.Item;
  1585.  
  1586. BEGIN (* CallTypeBound *)
  1587.   (* OCG.TraceIn (mname, pname); *)
  1588.   (* x.mode = TProc *)
  1589.   IF x.a2 < 0 THEN (* Super-call, call directly *)
  1590.     x.lev := -x.obj.link.typ.mno;
  1591.     IF x.lev = 0 THEN
  1592.       OCC.PutWord (OCC.BSR); OCC.PutWordRef (0, x.symbol)
  1593.     ELSE
  1594.       x.mode := XProc; OCC.PutF3 (OCC.JSR, x)
  1595.       (*OCC.PutWord (OCC.JSR); OCC.PutLongRef (0, x.symbol)*)
  1596.     END
  1597.   ELSE
  1598.     y := rcvr; IF y.typ.form = Pointer THEN OCE.DeRef (y) END;
  1599.     IF (y.mode IN {RegI, Ind}) & (y.obj = OCC.wasderef) & (y.a2 = Pointer)
  1600.     THEN
  1601.       (* rcvr is dereferenced pointer *)
  1602.       IF y.mode = Ind THEN OCC.GetAReg (z)
  1603.       ELSE z.mode := Reg; z.a0 := y.a0
  1604.       END;
  1605.       y.a1 := -4; OCC.Move (L, y, z);
  1606.       z.mode := RegI; z.a1 := -x.obj.a0 * 4;
  1607.       y.mode := Reg; y.a0 := z.a0; y.a1 := 0;
  1608.       OCC.Move (L, z, y); y.mode := RegI; OCC.PutF3 (OCC.JSR, y)
  1609.     ELSIF (y.mode = Ind) & (rcvr.obj # OCC.wasderef) THEN
  1610.       (* rcvr is record variable parameter *)
  1611.       y.mode := Var; INC (y.a0, 4); OCC.GetAReg (z); OCC.Move (L, y, z);
  1612.       z.mode := RegI; z.a1 := -x.obj.a0 * 4;
  1613.       y.mode := Reg; y.a0 := z.a0; y.a1 := 0;
  1614.       OCC.Move (L, z, y); y.mode := RegI; OCC.PutF3 (OCC.JSR, y)
  1615.     ELSE
  1616.       (* rcvr is record variable *)
  1617.       x.lev := -x.obj.link.typ.mno;
  1618.       IF x.lev = 0 THEN
  1619.         OCC.PutWord (OCC.BSR); OCC.PutWordRef (0, x.symbol)
  1620.       ELSE
  1621.         x.mode := XProc; OCC.PutF3 (OCC.JSR, x)
  1622.       END
  1623.     END
  1624.   END
  1625.   (* ;OCG.TraceOut (mname, pname); *)
  1626. END CallTypeBound;
  1627.  
  1628. (*------------------------------------*)
  1629. PROCEDURE Result * (VAR x : OCT.Item; typ : OCT.Struct);
  1630.  
  1631.   (* CONST pname = "Result"; *)
  1632.  
  1633.   VAR res : OCT.Item; R : SET; reg : INTEGER;
  1634.  
  1635. BEGIN (* Result *)
  1636.   (* OCG.TraceIn (mname, pname); *)
  1637.   IF
  1638.     (typ.form = Pointer) & (typ.BaseTyp # NIL) & (typ.BaseTyp.form = DynArr)
  1639.   THEN
  1640.     res.mode := RList; R := {}; reg := D0;
  1641.     WHILE (reg * 4) < typ.size DO INCL (R, reg); INC (reg) END;
  1642.     res.a0 := SYS.VAL (LONGINT, R)
  1643.   ELSE
  1644.     res.mode := Reg; res.a0 := D0
  1645.   END;
  1646.   res.typ := typ; res.rdOnly := FALSE;
  1647.   Assign (res, x, FALSE);
  1648.   returnFound := TRUE
  1649.   (* ;OCG.TraceOut (mname, pname); *)
  1650. END Result;
  1651.  
  1652. (*------------------------------------*)
  1653. PROCEDURE CaseIn * (VAR x : OCT.Item; VAR L0 : INTEGER);
  1654.  
  1655.   (* CONST pname = "CaseIn"; *)
  1656.  
  1657. BEGIN (* CaseIn *)
  1658.   (* OCG.TraceIn (mname, pname); *)
  1659.   IF ~(x.typ.form IN caseSet) THEN OCS.Mark (125) END;
  1660.   OCI.Load (x); OCC.UnReserveReg (SHORT (x.a0)); L0 := 0; FJ (L0)
  1661.   (* ;OCG.TraceOut (mname, pname); *)
  1662. END CaseIn;
  1663.  
  1664. (*------------------------------------*)
  1665. PROCEDURE CaseOut *
  1666.   ( VAR x : OCT.Item;
  1667.     L0, L1, L2, n : INTEGER;
  1668.     VAR tab : ARRAY OF LabelRange);
  1669.  
  1670.   (* CONST pname = "CaseOut"; *)
  1671.  
  1672.   VAR labItem, y, z : OCT.Item; i, L3 : INTEGER;
  1673.  
  1674. BEGIN (* CaseOut *)
  1675.   (* OCG.TraceIn (mname, pname); *)
  1676.   labItem.mode := Con; labItem.typ := x.typ; i := 0;
  1677.   OCC.FixLink (L0); (* fixup jump from case expression *)
  1678.   WHILE i < n DO
  1679.     IF tab [i].low = tab [i].high THEN
  1680.       y := x; labItem.a0 := tab [i].low; OCE.Op (neq, y, labItem, FALSE);
  1681.       CBJ (y, tab [i].label)
  1682.     ELSE
  1683.       L3 := 0; y := x; labItem.a0 := tab [i].low;
  1684.       OCE.Op (geq, y, labItem, FALSE); CFJ (y, L3); z := x;
  1685.       labItem.a0 := tab [i].high; OCE.Op (gtr, z, labItem, FALSE);
  1686.       CBJ (z, tab [i].label); OCC.fixup (L3)
  1687.     END;
  1688.     INC (i)
  1689.   END;
  1690.   BJ (L2); (* jump to code for else part *)
  1691.   OCC.FixLink (L1); (* fixup jumps from individual cases *)
  1692.   (* ;OCG.TraceOut (mname, pname); *)
  1693. END CaseOut;
  1694.  
  1695. (*------------------------------------*)
  1696. PROCEDURE BeginFor *
  1697.   ( VAR control, low, high, step : OCT.Item; VAR L0, L1 : INTEGER );
  1698.  
  1699.   (* CONST pname = "BeginFor"; *)
  1700.  
  1701.   VAR f, g, h, i : INTEGER; x, y : OCT.Item;
  1702.  
  1703. BEGIN (* BeginFor *)
  1704.   (* OCG.TraceIn (mname, pname); *)
  1705.   f := control.typ.form; g := low.typ.form; h := high.typ.form;
  1706.   i := step.typ.form;
  1707.   IF (f IN intSet) & (g IN intSet) & (h IN intSet) & (i IN intSet) THEN
  1708.     IF low.mode = Con THEN
  1709.       IF (f = Int) & (g = LInt) THEN OCS.Mark (317)
  1710.       ELSIF (f = SInt) & (g # SInt) THEN OCS.Mark (317)
  1711.       END;
  1712.       low.typ := control.typ
  1713.     END;
  1714.     IF high.mode = Con THEN
  1715.       IF (f = Int) & (h = LInt) THEN OCS.Mark (317)
  1716.       ELSIF (f = SInt) & (h # SInt) THEN OCS.Mark (317)
  1717.       END;
  1718.       high.typ := control.typ
  1719.     ELSE OCI.Load (high)
  1720.     END;
  1721.     IF (f = Int) & (i = LInt) THEN OCS.Mark (317)
  1722.     ELSIF (f = SInt) & (i # SInt) THEN OCS.Mark (317)
  1723.     END;
  1724.     step.typ := control.typ;
  1725.     IF (low.mode = Con) & (high.mode = Con) THEN
  1726.       IF (step.a0 > 0) & (high.a0 < low.a0) THEN OCS.Mark (318)
  1727.       ELSIF (step.a0 < 0) & (low.a0 < high.a0) THEN OCS.Mark (318)
  1728.       END
  1729.     END;
  1730.     x := control; Assign (x, low, FALSE);
  1731.     L0 := OCC.pc; x := control; y := high;
  1732.     IF high.mode = Con THEN
  1733.       IF step.a0 > 0 THEN OCE.Op (leq, x, y, FALSE);
  1734.       ELSE OCE.Op (geq, x, y, FALSE);
  1735.       END;
  1736.       CFJ (x, L1)
  1737.     ELSE
  1738.       IF step.a0 > 0 THEN OCE.Op (geq, y, x, FALSE);
  1739.       ELSE OCE.Op (leq, y, x, FALSE);
  1740.       END;
  1741.       CFJ (y, L1)
  1742.     END;
  1743.   END
  1744.   (* ;OCG.TraceOut (mname, pname); *)
  1745. END BeginFor;
  1746.  
  1747. (*------------------------------------*)
  1748. PROCEDURE EndFor *
  1749.   ( VAR control, step : OCT.Item; L0, L1 : INTEGER );
  1750.  
  1751.   (* CONST pname = "EndFor"; *)
  1752.  
  1753. BEGIN (* EndFor *)
  1754.   (* OCG.TraceIn (mname, pname); *)
  1755.   IF step.a0 > 0 THEN OCC.PutF5 (OCC.ADD, step.typ.size, step, control)
  1756.   ELSE
  1757.     step.a0 := -step.a0; OCC.PutF5 (OCC.SUB, step.typ.size, step, control)
  1758.   END;
  1759.   (*IF OCS.overflowCheck THEN OCC.PutWord (OCC.TRAPV) END;*)
  1760.   BJ (L0); OCC.FixLink (L1)
  1761.   (* ;OCG.TraceOut (mname, pname); *)
  1762. END EndFor;
  1763.  
  1764. END OCH.
  1765.  
  1766. (***************************************************************************
  1767.  
  1768.   $Log: OCH.mod $
  1769.   Revision 4.11  1994/08/03  11:47:56  fjc
  1770.   - Changed error codes.
  1771.   - Implemented SaveRegs switch, changed code generated for
  1772.     SaveAllRegs switch.
  1773.  
  1774.   Revision 4.10  1994/07/26  18:37:11  fjc
  1775.   *** empty log message ***
  1776.  
  1777.   Revision 4.9  1994/07/25  00:52:13  fjc
  1778.   - Implemented stack checking.
  1779.  
  1780.   Revision 4.8  1994/07/23  16:04:26  fjc
  1781.   - Changed Assign() to sign- or zero-extend values assigned
  1782.     to WORD and LONGWORD variables.
  1783.   - Changed PrepCall() to generate a register mask.
  1784.  
  1785.   Revision 4.7  1994/07/22  14:17:15  fjc
  1786.   - Changed to handle FProc objects.
  1787.   - Changed code generated for procedure entry and exit to
  1788.     implement the $A compiler switch.
  1789.   - Changed parameter passing code to save A4 if necessary.
  1790.   - Renamed procedure call procedures.
  1791.  
  1792.   Revision 4.6  1994/07/10  13:27:21  fjc
  1793.   - Commented out trace code.
  1794.   - Changed code generated for module prologue.
  1795.   - Added check for $G compiler switch before creating GC data.
  1796.   - Fixed register allocation bug in RegParam().
  1797.  
  1798.   Revision 4.5  1994/06/19  20:44:37  fjc
  1799.   - Fixing passing empty strings to register parameters
  1800.     broke the passing of non-empty strings. What a
  1801.     maroon :-(.
  1802.   - Calling type-bound procedures through CPointers
  1803.     was always broken.
  1804.  
  1805.   Revision 4.4  1994/06/17  17:50:57  fjc
  1806.   - Implemented TagTyp.
  1807.   - Fixed bug passing short strings to LIBCALLs.
  1808.  
  1809.   Revision 4.3  1994/06/06  18:36:15  fjc
  1810.   - Implemented varargs for LibCall procedures:
  1811.     - Created VarArg() to push one argument;
  1812.     - Created RestoreStack() to pop parameters off the stack.
  1813.  
  1814.   Revision 4.2  1994/06/05  22:45:21  fjc
  1815.   - Changed to use new symbol table format.
  1816.   - Fixed bug allowing any constant to be assigned to a set.
  1817.  
  1818.   Revision 4.1  1994/06/01  09:33:44  fjc
  1819.   - Bumped version number
  1820.  
  1821. ***************************************************************************)
  1822.