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