home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 9 / FreshFishVol9-CD1.bin / useful / dev / obero / oberon-a / source / oc / ocp.mod < prev    next >
Encoding:
Text File  |  1995-03-09  |  36.6 KB  |  1,107 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCP.mod $
  4.   Description: Code selection for standard procedures
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.9.1.1 $
  8.       $Author: fjc $
  9.         $Date: 1995/03/08 19:20:29 $
  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 OCP;
  23.  
  24. IMPORT SYS := SYSTEM, OCM, OCS, OCT, OCC, OCI, OCE;
  25.  
  26.  
  27. (* --- Local declarations ----------------------------------------------- *)
  28.  
  29. CONST
  30.  
  31.   (* object modes *)
  32.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  33.   RegI = OCM.RegI; RegX = OCM.RegX; Lab = OCM.Lab; LabI = OCM.LabI;
  34.   Con = OCM.Con; Push = OCM.Push; Pop = OCM.Pop; Coc = OCM.Coc;
  35.   Reg = OCM.Reg; Fld = OCM.Fld; Typ = OCM.Typ; Abs = OCM.Abs;
  36.   XProc = OCM.XProc; LProc = OCM.LProc;
  37.  
  38.   (* System flags *)
  39.  
  40.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  41.   BCPLFlag = OCM.BCPLFlag; AsmFlag = OCM.AsmFlag;
  42.  
  43.   (* structure forms *)
  44.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  45.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  46.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  47.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  48.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  49.   Record = OCT.Record; PtrTyp = OCT.PtrTyp; AdrTyp = OCT.AdrTyp;
  50.   BPtrTyp = OCT.BPtrTyp; BSet = OCT.BSet; WSet = OCT.WSet; Word = OCT.Word;
  51.   Longword = OCT.Longword; TagTyp = OCT.TagTyp;
  52.  
  53.   intSet   = {SInt, Int, LInt};
  54.   realSet  = {Real, LReal};
  55.   setSet   = {BSet, WSet, Set};
  56.   ptrSet   = {Pointer, PtrTyp, AdrTyp, BPtrTyp};
  57.   uptrSet  = {AdrTyp, BPtrTyp};
  58.   allSet   = {0 .. 31};
  59.   adrSet   = {LInt, Pointer, PtrTyp, AdrTyp, Longword};
  60.   bitOpSet = intSet + setSet + {Byte, Char, Word, Longword};
  61.   putSet   =
  62.     {Undef .. LInt, Word, Longword, ProcTyp} + setSet + ptrSet + realSet;
  63.  
  64.   (* CPU Registers *)
  65.  
  66.   D0 = 0; D1 = 1; D7 = 7; A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  67.   A6 = 14; A7 = 15; BP = A4; FP = A5; SP = A7;
  68.   DataRegs = {D0 .. D7};
  69.   AdrRegs = {A0 .. A7};
  70.  
  71.   (* Data sizes *)
  72.  
  73.   B = 1; W = 2; L = 4;
  74.  
  75. (* CONST mname = "OCP"; *)
  76.  
  77. (* --- Procedure declarations ------------------------------------------- *)
  78.  
  79. (*------------------------------------*)
  80. PROCEDURE CheckCleanupProc (VAR x : OCT.Item);
  81.  
  82.   (* CONST pname = "CheckCleanupProc"; *)
  83.  
  84.   VAR par : OCT.Object; typ : OCT.Struct;
  85.  
  86. BEGIN (* CheckCleanupProc *)
  87.   (* OCM.TraceIn (mname, pname); *)
  88.   IF (x.mode = XProc) OR (x.typ.form = ProcTyp) THEN
  89.     IF x.mode = XProc THEN par := x.obj.link; typ := x.typ
  90.     ELSE par := x.typ.link; typ := x.typ.BaseTyp;
  91.     END;
  92.     IF OCI.IsParam (par) THEN OCS.Mark (117) END;
  93.     IF typ # OCT.notyp THEN OCS.Mark (301) END
  94.   ELSE
  95.     OCS.Mark (300)
  96.   END
  97.   (* ;OCM.TraceOut (mname, pname); *)
  98. END CheckCleanupProc;
  99.  
  100. (*------------------------------------*)
  101. PROCEDURE NeedsTag (typ : OCT.Struct) : BOOLEAN;
  102.  
  103.   VAR fld : OCT.Object;
  104.  
  105. BEGIN (* NeedsTag *)
  106.   IF (typ.form IN {Pointer, Record}) & (typ.sysflg = OberonFlag) THEN
  107.     RETURN TRUE
  108.   ELSIF typ.form IN {Array, DynArr} THEN
  109.     RETURN NeedsTag (typ.BaseTyp)
  110.   END;
  111.   RETURN FALSE
  112. END NeedsTag;
  113.  
  114. (*------------------------------------*)
  115. PROCEDURE SaveRegs * ( fctno : INTEGER; VAR R : SET );
  116.   VAR x : OCT.Item;
  117. BEGIN (* SaveRegs *)
  118.   CASE fctno OF
  119.     OCT.pDISPOSE, OCT.pMOVE :
  120.       x.mode := Undef; OCC.SaveRegisters (R, x, OCC.AllRegs)
  121.     |
  122.   ELSE
  123.     R := {}
  124.   END
  125. END SaveRegs;
  126.  
  127. (*------------------------------------*)
  128. PROCEDURE StPar1 * (VAR x : OCT.Item; fctno : INTEGER; VAR R : SET);
  129.  
  130.   (* CONST pname = "StPar1"; *)
  131.  
  132.   VAR f, f1 : INTEGER; y, z, r0, r1 : OCT.Item;
  133.       L0, L1 : INTEGER; size : LONGINT; par : OCT.Object;
  134.       typ : OCT.Struct; desc : OCT.Desc; s : SET;
  135.  
  136. BEGIN (* StPar1 *)
  137.   (* OCM.TraceIn (mname, pname); *)
  138.   f := x.typ.form; size := x.typ.size;
  139.   CASE fctno OF
  140.     OCT.pABS :
  141.       IF f IN intSet THEN
  142.         IF x.mode = Con THEN
  143.           x.a0 := ABS (x.a0)
  144.         ELSE
  145.           OCI.Load (x);                                (*    MOVE.z  x,Dn *)
  146.           OCC.PutF1 (OCC.TST, size, x);                (*    TST.z   Dn   *)
  147.           OCC.PutWord (6A02H);                         (*    BPL     1$   *)
  148.           OCC.PutF1 (OCC.NEG, size, x)                 (*    NEG.z   Dn   *)
  149.         END
  150.       ELSIF f IN realSet THEN
  151.         OCC.LoadRegParams1 (R, x);
  152.         OCC.CallKernel (OCC.kSPAbs);
  153.         OCC.RestoreRegisters (R, x)
  154.       ELSE
  155.         OCS.Mark (111)
  156.       END
  157.     |
  158.     OCT.pCAP :
  159.       IF (f = String) & (x.a1 <= 2) THEN
  160.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  161.       END;
  162.       IF f = Char THEN
  163.         IF x.mode = Con THEN
  164.           x.a0 := ORD (CAP (CHR (x.a0)))
  165.         ELSE
  166.           y.mode := Con; y.typ := OCT.chartyp;
  167.           OCI.Load (x);                                (*    MOVE x,Dn    *)
  168.           y.a0 := ORD ("a");
  169.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "a", Dn *)
  170.           OCC.PutWord (6510H);                         (*    BCS 1$       *)
  171.           y.a0 := ORD ("z");
  172.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "z", Dn *)
  173.           OCC.PutWord (6306H);                         (*    BLS 0$       *)
  174.           y.a0 := 0E0H; OCC.PutF6 (OCC.CMPI, B, y, x); (*    CMPI 0E0X,Dn *)
  175.           OCC.PutWord (6504H);                         (*    BCS 1$       *)
  176.           y.a0 := 0DFH; OCC.PutF6 (OCC.ANDI, B, y, x); (* 0$ ANDI 0DFH,Dn *)
  177.         END                                            (* 1$              *)
  178.       ELSE
  179.         OCS.Mark (111); x.typ := OCT.chartyp
  180.       END
  181.     |
  182.     OCT.pCHR :
  183.       IF ~(f IN {Undef, Byte, SInt, Int, LInt}) THEN OCS.Mark (111) END;
  184.       IF ~(f IN {Byte, SInt}) & (x.mode # Con) THEN OCI.Load (x) END;
  185.       x.typ := OCT.chartyp
  186.     |
  187.     OCT.pENTIER :
  188.       IF f IN realSet THEN
  189.         OCC.LoadRegParams1 (R, x);
  190.         OCC.CallKernel (OCC.kSPFix);
  191.         OCC.RestoreRegisters (R, x)
  192.       ELSE OCS.Mark (111)
  193.       END;
  194.       x.typ := OCT.linttyp;
  195.     |
  196.     OCT.pHALT :
  197.       IF (f IN intSet) & (x.mode = Con) THEN
  198.         r0.mode := Reg; r0.a0 := D0;
  199.         OCC.Move (L, x, r0);                     (* MOVE.L x,D0          *)
  200.         y.mode := Con; y.a0 := 0; y.typ := OCT.stringtyp;
  201.         y.label := OCT.ConstLabel;
  202.         OCC.PutF2 (OCC.LEA, y, A0);              (* LEA    ModuleName,A0 *)
  203.         y.a0 := (OCS.line * 10000H) + OCS.col; y.typ := OCT.linttyp;
  204.         r1.mode := Reg; r1.a0 := D1;
  205.         OCC.Move (L, y, r1);                     (* MOVE.L pos,D1        *)
  206.         OCC.CallKernel (OCC.kHalt)               (* JSR    Kernel_Halt   *)
  207.       ELSE
  208.         OCS.Mark (17)
  209.       END;
  210.       x.typ := OCT.notyp
  211.     |
  212.     OCT.pLONG :
  213.       IF (f = String) & (x.a1 <= 2) THEN
  214.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  215.       END;
  216.       IF f = SInt THEN OCE.ConvertInts (x, OCT.inttyp)
  217.       ELSIF f = Int THEN OCE.ConvertInts (x, OCT.linttyp)
  218.       ELSIF f = BSet THEN
  219.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  220.         IF x.mode # Con THEN
  221.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.wsettyp;
  222.           OCI.Load (x); OCC.Move (B, y, x)
  223.         END;
  224.         x.typ := OCT.wsettyp
  225.       ELSIF f = WSet THEN
  226.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  227.         IF x.mode # Con THEN
  228.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.settyp;
  229.           OCI.Load (x); OCC.Move (W, y, x)
  230.         END;
  231.         x.typ := OCT.settyp
  232.       ELSIF f = Real THEN
  233.         x.typ := OCT.lrltyp
  234.       ELSIF f = Char THEN
  235.         IF x.mode # Con THEN
  236.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  237.           OCI.Load (x); OCC.Move (B, y, x)
  238.         END;
  239.         x.typ := OCT.linttyp
  240.       ELSE
  241.         OCS.Mark (111)
  242.       END
  243.     |
  244.     OCT.pMAX :
  245.       IF x.mode = Typ THEN
  246.         x.mode := Con;
  247.         CASE f OF
  248.           Bool  : x.a0 := OCM.MaxBool                      |
  249.           Char  : x.a0 := OCM.MaxChar                      |
  250.           SInt  : x.a0 := OCM.MaxSInt                      |
  251.           Int   : x.a0 := OCM.MaxInt                       |
  252.           LInt  : x.a0 := OCM.MaxLInt                      |
  253.           Real  : x.a0 := 07F7FFFFFH                       |
  254.           LReal : x.a0 := 07F7FFFFFH                       |
  255.           BSet  : x.a0 := OCM.MaxBSet; x.typ := OCT.inttyp |
  256.           WSet  : x.a0 := OCM.MaxWSet; x.typ := OCT.inttyp |
  257.           Set   : x.a0 := OCM.MaxSet; x.typ := OCT.inttyp  |
  258.         ELSE
  259.           OCS.Mark (111)
  260.         END; (* CASE f *)
  261.       ELSE
  262.         OCS.Mark (110)
  263.       END
  264.     |
  265.     OCT.pMIN :
  266.       IF x.mode = Typ THEN
  267.         x.mode := Con;
  268.         CASE f OF
  269.           Bool  : x.a0 := OCM.MinBool                               |
  270.           Char  : x.a0 := OCM.MinChar                               |
  271.           SInt  : x.a0 := OCM.MinSInt                               |
  272.           Int   : x.a0 := OCM.MinInt                                |
  273.           LInt  : x.a0 := OCM.MinLInt                               |
  274.           Real  : x.a0 := 0FF7FFFFFH                                |
  275.           LReal : x.a0 := 0FF7FFFFFH                                |
  276.           BSet, WSet, Set : x.a0 := OCM.MinSet; x.typ := OCT.inttyp |
  277.         ELSE
  278.           OCS.Mark (111)
  279.         END; (* CASE f *)
  280.       ELSE
  281.         OCS.Mark (110)
  282.       END
  283.     |
  284.     OCT.pNEW :
  285.       IF (f = Pointer) & (x.mode # Con) THEN
  286.         IF x.rdOnly THEN OCS.Mark (324) END;
  287.         typ := x.typ; f1 := typ.sysflg;
  288.         typ := typ.BaseTyp; f := typ.form;
  289.         IF f = DynArr THEN
  290.           OCI.UnloadDesc (x);
  291.           desc := x.desc; IF desc = NIL THEN desc := OCT.AllocDesc() END;
  292.           desc.lev := x.lev; desc.mode := x.mode; desc.a0 := x.a0;
  293.           desc.a1 := x.a1; desc.a2 := x.a2; x.desc := desc;
  294.         END;
  295.         z.mode := Undef; OCC.SaveRegisters (R, z, OCC.AllRegs);
  296.         IF (f = DynArr) & (x.mode IN {VarX, IndX, RegI, RegX}) THEN
  297.           IF x.mode IN {RegI, RegX} THEN OCC.ReserveReg (x.a0) END;
  298.           IF x.mode # RegI THEN OCC.ReserveReg (x.a2) END
  299.         END;
  300.         z.mode := Push; z.a0 := SP;
  301.         IF (f1 = OberonFlag) & NeedsTag (typ) THEN
  302.           IF f = Record THEN
  303.             OCC.PutWord (2F3CH);
  304.             OCC.PutLongRef (0, typ.label);       (* MOVE.L #tag,-(A7)   *)
  305.           ELSIF f = Array THEN
  306.             y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  307.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  308.             OCC.PutWord (2F3CH);
  309.             OCC.PutLongRef (0, typ.label);       (* MOVE.L #tag,-(A7)   *)
  310.             OCC.Move (L, y, z);                   (* MOVE.L #size,-(A7)  *)
  311.           ELSIF f = DynArr THEN
  312.             WHILE typ.form = DynArr DO typ := typ.BaseTyp END;
  313.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  314.             OCC.PutWord (2F3CH);
  315.             OCC.PutLongRef (0, typ.label);       (* MOVE.L #tag,-(A7)   *)
  316.           END
  317.         ELSIF f # DynArr THEN
  318.           y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  319.           OCC.Move (L, y, z);                     (* MOVE.L #size, -(A7) *)
  320.         END
  321.       ELSE OCS.Mark (111)
  322.       END
  323.     |
  324.     OCT.pODD :
  325.       IF f IN intSet THEN
  326.         y.mode := Con; y.a0 := 0; y.typ := OCT.inttyp;
  327.         IF f = SInt THEN OCC.Bit (OCC.BTST, y, x);
  328.         ELSE OCI.Load (x); OCC.Bit (OCC.BTST, y, x); OCI.Unload (x)
  329.         END;
  330.       ELSE
  331.         OCS.Mark (111)
  332.       END;
  333.       OCE.setCC (x, OCC.NE)
  334.     |
  335.     OCT.pORD :
  336.       IF (f = String) & (x.a1 <= 2) THEN
  337.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  338.       END;
  339.       IF (f = Char) OR (f = Byte) THEN
  340.         IF x.mode # Con THEN
  341.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.inttyp;
  342.           OCI.Load (x); OCC.Move (B, y, x)
  343.         END
  344.       ELSE
  345.         OCS.Mark (111)
  346.       END;
  347.       x.typ := OCT.inttyp
  348.     |
  349.     OCT.pSHORT :
  350.       IF f = LInt THEN
  351.         IF x.mode = Con THEN
  352.           OCE.SetIntType (x); IF x.typ.form = LInt THEN OCS.Mark (203) END
  353.         ELSE
  354.           OCI.Load (x);
  355.           IF OCS.pragma [OCS.rangeChk] THEN
  356.             OCC.GetDReg (y); OCC.Move (W, x, y); OCI.EXT (L, y.a0);
  357.             OCC.PutF5 (OCC.CMP, L, x, y); OCI.Unload (y);
  358.             OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  359.           END
  360.         END;
  361.         x.typ := OCT.inttyp
  362.       ELSIF f = Int THEN
  363.         IF x.mode = Con THEN
  364.           OCE.SetIntType (x); IF x.typ.form # SInt THEN OCS.Mark (203) END
  365.         ELSE
  366.           OCI.Load (x);
  367.           IF OCS.pragma [OCS.rangeChk] THEN
  368.             OCC.GetDReg (y); OCC.Move (B, x, y); OCI.EXT (W, y.a0);
  369.             OCC.PutF5 (OCC.CMP, W, x, y); OCI.Unload (y);
  370.             OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  371.           END
  372.         END;
  373.         x.typ := OCT.sinttyp
  374.       ELSIF f = Set THEN
  375.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  376.         IF x.mode = Con THEN
  377.           s := SYS.VAL (SET, x.a0);
  378.           IF (s - {0..15}) # {} THEN OCS.Mark (203) END;
  379.         ELSE
  380.           OCI.Load (x);
  381.           IF OCS.pragma [OCS.rangeChk] THEN
  382.             y.mode := Con; y.a0 := 0; y.typ := OCT.linttyp;
  383.             OCI.Load (y); OCC.Move (W, x, y);
  384.             OCC.PutF5 (OCC.CMP, L, x, y); OCI.Unload (y);
  385.             OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  386.           END
  387.         END;
  388.         x.typ := OCT.wsettyp
  389.       ELSIF f = WSet THEN
  390.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  391.         IF x.mode = Con THEN
  392.           s := SYS.VAL (SET, x.a0);
  393.           IF (s - {0..7}) # {} THEN OCS.Mark (203) END;
  394.         ELSE
  395.           OCI.Load (x);
  396.           IF OCS.pragma [OCS.rangeChk] THEN
  397.             y.mode := Con; y.a0 := 0; y.typ := OCT.linttyp;
  398.             OCI.Load (y); OCC.Move (B, x, y);
  399.             OCC.PutF5 (OCC.CMP, W, x, y); OCI.Unload (y);
  400.             OCC.TrapCC (OCC.RangeCheck, OCC.NE)
  401.           END
  402.         END;
  403.         x.typ := OCT.bsettyp
  404.       ELSIF f = LReal THEN
  405.         x.typ := OCT.realtyp
  406.       ELSE
  407.         OCS.Mark (111)
  408.       END
  409.     |
  410.     OCT.pADR :
  411.       OCI.Adr (x); x.typ := OCT.adrtyp
  412.     |
  413.     OCT.pCC :
  414.       IF (f = SInt) & (x.mode = Con) THEN
  415.         IF (x.a0 >= 0) & (x.a0 < 16) THEN OCE.setCC (x, x.a0)
  416.         ELSE OCS.Mark (219)
  417.         END
  418.       ELSE OCS.Mark (17)
  419.       END
  420.     |
  421.     OCT.pDISPOSE :
  422.       IF f IN ptrSet THEN
  423.         IF x.rdOnly THEN OCS.Mark (324) END;
  424.         IF x.typ.sysflg = BCPLFlag THEN
  425.           y := x; OCI.Load (y);
  426.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  427.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  428.           OCC.Move (L, y, x); OCI.Unload (y)
  429.         END;
  430.         y.mode := Push; y.a0 := SP;
  431.         IF x.mode IN {Ind, IndX} THEN OCI.MoveAdr (x, y)
  432.         ELSE OCC.PutF3 (OCC.PEA, x)
  433.         END;
  434.         OCI.Unload (x);
  435.         OCC.CallKernel (OCC.kDispose);
  436.         z.mode := Undef; OCC.RestoreRegisters (R, z)
  437.       ELSE
  438.         OCS.Mark (111)
  439.       END;
  440.       x.typ := OCT.notyp
  441.     |
  442.     OCT.pSIZE :
  443.       IF x.mode = Typ THEN x.a0 := x.typ.size
  444.       ELSE OCS.Mark (110); x.a0 := 1
  445.       END;
  446.       x.mode := Con; OCE.SetIntType (x)
  447.     |
  448.     OCT.pSTRLEN :
  449.       IF ((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char) THEN
  450.         y := x; OCI.LoadAdr (y); y.mode := Pop;       (*    LEA    <y>,Ay *)
  451.         x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  452.         OCI.Load (x);                                 (*    MOVEQ  #0,Dx  *)
  453.         OCC.PutF1 (OCC.TST, B, y); OCC.FreeReg (y);   (* 1$ TST.B  (Ay)+  *)
  454.         OCC.PutWord (6704H);                          (*    BEQ    2$     *)
  455.         OCC.PutF7 (OCC.ADDQ, L, 1, x);                (*    ADDQ.L #1,Dx  *)
  456.         OCC.PutWord (60F8H);                          (*    BRA    1$     *)
  457.       ELSIF f = String THEN                           (* 2$               *)
  458.         x.mode := Con; x.a0 := x.a1 - 1; x.typ := OCT.linttyp
  459.       ELSE
  460.         OCS.Mark (111)
  461.       END
  462.     |
  463.     OCT.pASH :
  464.       IF f IN intSet THEN
  465.         OCI.Load (x); IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END
  466.       ELSE
  467.         OCS.Mark (111)
  468.       END
  469.     |
  470.     OCT.pASSERT :
  471.       IF f = Bool THEN
  472.         IF x.mode = Con THEN
  473.           IF x.a0 = 0 THEN OCS.Mark (319) ELSE OCS.Mark (320) END;
  474.           OCE.setCC (x, OCC.T)
  475.         END;
  476.       ELSE OCS.Mark (120)
  477.       END
  478.     |
  479.     OCT.pCOPY :
  480.       IF
  481.         ~((((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char))
  482.           OR (f = String))
  483.       THEN
  484.         OCS.Mark (111)
  485.       END
  486.     |
  487.     OCT.pDEC, OCT.pINC :
  488.       IF x.mode >= Con THEN     OCS.Mark (112)
  489.       ELSIF ~(f IN intSet) THEN OCS.Mark (111)
  490.       ELSIF x.rdOnly THEN OCS.Mark (324)
  491.       END
  492.     |
  493.     OCT.pINCL, OCT.pEXCL :
  494.       IF x.mode >= Con THEN     OCS.Mark (112)
  495.       ELSIF ~(f IN setSet) THEN OCS.Mark (111); x.typ := OCT.settyp
  496.       ELSIF x.rdOnly THEN OCS.Mark (324)
  497.       END
  498.     |
  499.     OCT.pLEN :
  500.       IF (f # DynArr) & (f # Array) THEN OCS.Mark (131) END
  501.     |
  502.     OCT.pAND, OCT.pOR, OCT.pXOR :
  503.       IF ~(f IN bitOpSet) THEN OCS.Mark (111) END
  504.     |
  505.     OCT.pBIT, OCT.pGET, OCT.pPUT :
  506.       IF (f IN intSet) & (x.mode = Con) THEN
  507.         x.mode := Abs
  508.       ELSIF f IN adrSet THEN
  509.         IF x.mode = Var THEN
  510.           x.mode := Ind; x.a1 := 0
  511.         ELSE
  512.           OCC.GetAReg (y); OCC.Move (L, x, y);
  513.           x := y; x.mode := RegI; x.a1 := 0
  514.         END
  515.       ELSE
  516.         OCS.Mark (111)
  517.       END
  518.     |
  519.     OCT.pGETREG, OCT.pPUTREG, OCT.pREG :
  520.       IF (f IN intSet) & (x.mode = Con) THEN
  521.         IF (0 <= x.a0) & (x.a0 <= 15) THEN
  522.           x.mode := Reg;
  523.           IF fctno = OCT.pREG THEN
  524.             OCC.ReserveReg (x.a0); x.typ := OCT.lwordtyp
  525.           END
  526.         ELSE OCS.Mark (219)
  527.         END
  528.       ELSE
  529.         OCS.Mark (17)
  530.       END
  531.     |
  532.     OCT.pLSH, OCT.pROT :
  533.       IF (f = String) & (x.a1 <= 2) THEN
  534.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  535.       END;
  536.       IF f IN bitOpSet THEN OCI.Load (x)
  537.       ELSE OCS.Mark (111)
  538.       END
  539.     |
  540.     OCT.pSYSNEW :
  541.       IF ~(f IN ptrSet) OR (x.mode = Con) THEN OCS.Mark (111)
  542.       ELSIF x.rdOnly THEN OCS.Mark (324)
  543.       ELSIF NeedsTag (x.typ) THEN OCS.Mark (339)
  544.       ELSE y.mode := Undef; OCC.SaveRegisters (R, y, OCC.AllRegs)
  545.       END
  546.     |
  547.     OCT.pVAL : IF x.mode # Typ THEN OCS.Mark (110) END
  548.     |
  549.     OCT.pMOVE :
  550.       IF (f IN adrSet) THEN
  551.         y.mode := Push; y.a0 := SP;
  552.         OCC.Move (L, x, y); OCI.Unload (x);
  553.       ELSE
  554.         OCS.Mark (111)
  555.       END
  556.     |
  557.     OCT.pTAG :
  558.       typ := x.typ; f1 := typ.sysflg;
  559.       IF f = Pointer THEN typ := typ.BaseTyp END;
  560.       IF (typ.form = Record) & (f1 = OberonFlag) THEN
  561.         IF x.mode = Typ THEN (* Type *)
  562.           x.mode := LabI; x.a0 := 0; x.a1 := 4; x.label := typ.label
  563.         ELSIF (x.mode <= RegX) & (f = Pointer) THEN (* Pointer variable *)
  564.           OCE.DeRef (x); x.a1 := -4
  565.         ELSIF (x.mode = Ind) & (x.obj # NIL) & (x.obj # OCC.wasderef) THEN
  566.           (* VAR parameter *)
  567.           x.mode := Var; INC (x.a0, 4)
  568.         ELSE (* Bzzzzt! *)
  569.           OCS.Mark (338)
  570.         END
  571.       ELSIF f = PtrTyp THEN
  572.         IF (x.mode <= RegX) THEN (* Pointer variable *)
  573.           IF x.mode = Var THEN
  574.             IF OCS.pragma [OCS.nilChk] THEN
  575.               y := x;
  576.               OCC.PutF1 (OCC.TST, L, y); OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  577.               OCI.Unload (y)
  578.             END;
  579.             x.mode := Ind
  580.           ELSE
  581.             y := x; y.typ := OCT.ptrtyp; OCC.GetAReg (x);
  582.             IF OCS.pragma [OCS.nilChk] THEN
  583.               OCI.Load (y); OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  584.             END;
  585.             OCC.Move (L, y, x); OCI.Unload (y); x.mode := RegI
  586.           END;
  587.           x.a1 := -4; x.rdOnly := FALSE
  588.         ELSE (* Bzzzzt! *)
  589.           OCS.Mark (338)
  590.         END
  591.       ELSE
  592.         OCS.Mark (338)
  593.       END;
  594.       x.typ := OCT.tagtyp; x.rdOnly := FALSE
  595.     |
  596.   ELSE
  597.     OCS.Mark (1014); OCS.Mark (fctno)
  598.   END; (* CASE fctno *)
  599.   (* ;OCM.TraceOut (mname, pname); *)
  600. END StPar1;
  601.  
  602. (*------------------------------------*)
  603. PROCEDURE StPar2 * (
  604.   VAR par1, par2 : OCT.Item; fctno : INTEGER; VAR R : SET);
  605.  
  606.   (* CONST pname = "StPar2"; *)
  607.  
  608.   VAR f, dim, L0, L1 : INTEGER; op : LONGINT; typ, btyp, t1 : OCT.Struct;
  609.       freePar2 : BOOLEAN; x, y, r0, r1 : OCT.Item;
  610.       dsc : OCT.Desc;
  611.  
  612. BEGIN (* StPar2 *)
  613.   (* OCM.TraceIn (mname, pname); *)
  614.   f := par2.typ.form; freePar2 := FALSE;
  615.   IF fctno < OCT.TwoPar THEN OCS.Mark (64); RETURN END;
  616.   CASE fctno OF
  617.     OCT.pASH, OCT.pLSH, OCT.pROT :
  618.       IF
  619.         ((fctno = OCT.pASH) & (f IN intSet)) OR
  620.         ((fctno # OCT.pASH) & (f IN bitOpSet))
  621.       THEN
  622.         IF (par2.mode = Con) & (par2.a0 = 0) THEN RETURN END;
  623.         IF fctno = OCT.pASH THEN op := OCC.ASR
  624.         ELSIF fctno = OCT.pLSH THEN op := OCC.LSR
  625.         ELSE op := OCC.ROR
  626.         END;
  627.         IF par2.mode = Con THEN
  628.           IF par2.a0 < 0 THEN par2.a0 := -par2.a0 ELSE INC (op, 100H) END;
  629.           IF par2.a0 > 8 THEN OCI.Load (par2); freePar2 := TRUE END;
  630.           OCC.Shift (op, par1.typ.size, par2, par1);
  631.           IF freePar2 THEN OCC.FreeReg (par2) END
  632.         ELSE
  633.           OCI.Load (par2);                         (*    MOVE.L <par2>,Dn *)
  634.           OCC.PutF1 (OCC.TST, par2.typ.size, par2);(*    TST.?  Dn        *)
  635.           L0 := OCC.pc; OCC.PutWord (6A00H);       (*    BPL.S  1$        *)
  636.           OCC.PutF1 (OCC.NEG, par2.typ.size, par2);(*    NEG.?  Dn        *)
  637.           OCC.Shift (op, par1.typ.size, par2, par1);
  638.                                                    (*    opR.?  Dn,<par1> *)
  639.           L1 := OCC.pc; OCC.PutWord (6000H);       (*    BRA.S  $2        *)
  640.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  641.           OCC.Shift (op+100H, par1.typ.size, par2, par1);
  642.                                                    (* 1$ opL.?  Dn,<par1> *)
  643.           OCC.PatchWord (L1, OCC.pc - L1 - 2);     (* 2$                  *)
  644.         END
  645.       ELSE
  646.         OCS.Mark (111)
  647.       END
  648.     |
  649.     OCT.pASSERT :
  650.       IF (par2.mode = Con) & (f IN intSet) THEN
  651.         IF par1.mode # Coc THEN
  652.           OCC.PutF1 (OCC.TST, B, par1);          (*    TST.B  <par1>      *)
  653.           OCI.Unload (par1); L0 := OCC.pc;
  654.           OCC.PutWord (OCC.BNE)                  (*    BNE.S  2$          *)
  655.         ELSE
  656.           op := OCC.Bcc + (par1.a0 * 100H);
  657.           OCC.PutWord (op);
  658.           OCC.PutWord (par1.a1);                 (*    Bcc    2$          *)
  659.           L0 := OCC.pc - 2; OCC.FixLink (par1.a2);
  660.         END;
  661.         r0.mode := Reg; r0.a0 := D0;
  662.         OCC.Move (L, par2, r0);               (* 1$ MOVE.L #par2,D0      *)
  663.         OCI.Unload (par2);
  664.         x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  665.         x.label := OCT.ConstLabel;
  666.         OCC.PutF2 (OCC.LEA, x, A0);           (*    LEA    ModuleName,A0 *)
  667.         x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  668.         r1.mode := Reg; r1.a0 := D1;
  669.         OCC.Move (L, x, r1);                  (*    MOVE.L pos,D1        *)
  670.         OCC.CallKernel (OCC.kHalt);           (*    JSR    Kernel.Halt   *)
  671.         IF par1.mode # Coc THEN               (* 2$                      *)
  672.           OCC.PatchWord (L0, OCC.pc - L0 - 2)
  673.         ELSE OCC.FixLink (L0)
  674.         END;
  675.       ELSE OCS.Mark (17)
  676.       END;
  677.       par1.typ := OCT.notyp
  678.     |
  679.     OCT.pDEC, OCT.pINC :
  680.       IF par1.typ # par2.typ THEN
  681.         IF (par2.mode = Con) & (f IN intSet) THEN par2.typ := par1.typ
  682.         ELSIF (par1.typ.form = Int) & (f = SInt) THEN
  683.           OCE.ConvertInts (par2, OCT.inttyp)
  684.         ELSIF (par1.typ.form = LInt) & (f IN {SInt, Int}) THEN
  685.           OCE.ConvertInts (par2, OCT.linttyp)
  686.         ELSE OCS.Mark (111)
  687.         END
  688.       ELSIF par2.mode # Con THEN
  689.         OCI.Load (par2)
  690.       END;
  691.       IF fctno = OCT.pDEC THEN op := OCC.SUB ELSE op := OCC.ADD END;
  692.       OCC.PutF5 (op, par1.typ.size, par2, par1);
  693.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  694.       par1.typ := OCT.notyp
  695.     |
  696.     OCT.pEXCL :
  697.       OCE.Set0 (x, par2);
  698.       IF x.mode = Con THEN
  699.         x.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, x.a0));
  700.         OCC.PutF6 (OCC.ANDI, par1.typ.size, x, par1)
  701.       ELSE
  702.         OCC.PutF1 (OCC.NOT, L, x);
  703.         OCC.PutF5 (OCC.AND, par1.typ.size, x, par1)
  704.       END;
  705.       par1.typ := OCT.notyp
  706.     |
  707.     OCT.pINCL :
  708.       OCE.Set0 (x, par2);
  709.       IF x.mode = Con THEN OCC.PutF6 (OCC.ORI, par1.typ.size, x, par1)
  710.       ELSE OCC.PutF5 (OCC.iOR, par1.typ.size, x, par1)
  711.       END;
  712.       par1.typ := OCT.notyp
  713.     |
  714.     OCT.pLEN :
  715.       IF (par2.mode = Con) & (f = SInt) THEN
  716.         dim := SHORT (par2.a0); typ := par1.typ;
  717.         WHILE (dim > 0) & (typ.form IN {DynArr, Array}) DO
  718.           typ := typ.BaseTyp; DEC (dim)
  719.         END;
  720.         IF (dim # 0) OR ~(typ.form IN {DynArr, Array}) THEN OCS.Mark (132)
  721.         ELSE
  722.           IF typ.form = DynArr THEN OCI.DescItem (par1, par1.desc, typ.adr)
  723.           ELSE par1.mode := Con; par1.a0 := typ.n
  724.           END;
  725.           par1.typ := OCT.linttyp
  726.         END
  727.       ELSE
  728.         OCS.Mark (111)
  729.       END
  730.     |
  731.     OCT.pAND, OCT.pOR, OCT.pXOR :
  732.       IF f IN bitOpSet THEN
  733.         IF (par1.mode = Con) & (par2.mode = Con) THEN
  734.           IF fctno = OCT.pAND THEN
  735.             par1.a0 := SYS.AND (par1.a0, par2.a0)
  736.           ELSIF fctno = OCT.pXOR THEN
  737.             par1.a0 := SYS.XOR (par1.a0, par2.a0)
  738.           ELSE
  739.             par1.a0 := SYS.LOR (par1.a0, par2.a0)
  740.           END;
  741.           IF f IN intSet THEN OCE.SetIntType (par1) END
  742.         ELSE
  743.           IF fctno = OCT.pAND THEN op := OCC.AND
  744.           ELSIF fctno = OCT.pXOR THEN op := OCC.EOR
  745.           ELSE op := OCC.iOR
  746.           END;
  747.           IF par1.mode = Con THEN
  748.             IF par1.typ.form # par2.typ.form THEN par1.typ := par2.typ END;
  749.             OCI.Load (par2); OCC.PutF5 (op, par2.typ.size, par1, par2);
  750.             par1 := par2
  751.           ELSIF par2.mode = Con THEN
  752.             IF par2.typ.form # par1.typ.form THEN par2.typ := par1.typ END;
  753.             OCI.Load (par1); OCC.PutF5 (op, par1.typ.size, par2, par1)
  754.           ELSE
  755.             IF par1.typ.form = par2.typ.form THEN
  756.               OCI.Load (par1); IF op = OCC.EOR THEN OCI.Load (par2) END;
  757.               OCC.PutF5 (op, par1.typ.size, par2, par1); OCI.Unload (par2)
  758.             ELSE
  759.               OCS.Mark (100)
  760.             END
  761.           END
  762.         END
  763.       ELSE
  764.         OCS.Mark (111)
  765.       END
  766.     |
  767.     OCT.pBIT :
  768.       IF f IN intSet THEN
  769.         IF (par2.mode = Con) & (par2.a0 >= 8) THEN OCI.Load (par1)
  770.         ELSIF (par2.mode # Con) THEN OCI.Load (par1); OCI.Load (par2)
  771.         END;
  772.         OCC.Bit (OCC.BTST, par2, par1); OCI.Unload (par1); OCI.Unload (par2)
  773.       ELSE
  774.         OCS.Mark (111)
  775.       END;
  776.       OCE.setCC (par1, OCC.NE)
  777.     |
  778.     OCT.pGET, OCT.pGETREG :
  779.       IF par2.mode >= Con THEN OCS.Mark (112)
  780.       ELSIF ~(f IN realSet) THEN
  781.         IF par2.rdOnly THEN OCS.Mark (324) END;
  782.         OCC.Move (par2.typ.size, par1, par2)
  783.       ELSE OCS.Mark (111)
  784.       END;
  785.       par1.typ := OCT.notyp
  786.     |
  787.     OCT.pPUT, OCT.pPUTREG :
  788.       IF par2.mode IN {XProc, LProc} THEN OCI.MoveAdr (par2, par1)
  789.       ELSIF f IN putSet THEN OCC.Move (par2.typ.size, par2, par1)
  790.       ELSE OCS.Mark (111)
  791.       END;
  792.       par1.typ := OCT.notyp
  793.     |
  794.     OCT.pSYSNEW :
  795.       x.mode := Push; x.a0 := SP;
  796.       IF par2.typ.form # LInt THEN OCE.ConvertInts (par2, OCT.linttyp) END;
  797.       OCC.Move (L, par2, x); OCI.Unload (par2)
  798.     |
  799.     OCT.pVAL : par2.typ := par1.typ; par1 := par2
  800.     |
  801.     OCT.pCOPY :
  802.       IF
  803.         ((f = Array) OR (f = DynArr)) & (par2.typ.BaseTyp.form = Char)
  804.       THEN
  805.         IF par2.rdOnly THEN OCS.Mark (324) END;
  806.         IF f = Array THEN
  807.           x.mode := Con; x.a0 := par2.typ.n;
  808.           IF (par1.typ.form = String) & (par1.a1 < x.a0) THEN
  809.             x.a0 := par1.a1
  810.           ELSIF (par1.typ.form = Array) & (par1.typ.n < x.a0) THEN
  811.             x.a0 := par1.typ.n
  812.           END;
  813.           DEC (x.a0); OCE.SetIntType (x)
  814.         ELSE
  815.           IF (par1.typ.form = String) & (par1.a1 = 1) THEN
  816.             x.mode := Con; x.a0 := 0; x.typ := OCT.sinttyp
  817.           ELSE OCI.DescItem (x, par2.desc, par2.typ.adr)
  818.           END
  819.         END;
  820.         OCI.CopyString (par1, par2, x)
  821.       ELSE
  822.         OCS.Mark (111)
  823.       END;
  824.       par1.typ := OCT.notyp
  825.     |
  826.     OCT.pMOVE :
  827.       IF (f IN adrSet) THEN
  828.         x.mode := Push; x.a0 := SP;
  829.         OCC.Move (L, par2, x); OCI.Unload (par2)
  830.       ELSE
  831.         OCS.Mark (111)
  832.       END
  833.     |
  834.   ELSE
  835.     OCS.Mark (1015); OCS.Mark (fctno)
  836.   END; (* CASE fctno *)
  837.   (* ;OCM.TraceOut (mname, pname); *)
  838. END StPar2;
  839.  
  840. (*------------------------------------*)
  841. PROCEDURE StPar3 * (VAR p, x : OCT.Item; fctno : INTEGER; VAR R : SET);
  842.  
  843.   (* CONST pname = "StPar3"; *)
  844.  
  845.   VAR f : INTEGER; y : OCT.Item;
  846.  
  847. BEGIN (* StPar3 *)
  848.   (* OCM.TraceIn (mname, pname); *)
  849.   f := x.typ.form;
  850.   IF fctno = OCT.pMOVE THEN
  851.     IF f IN intSet THEN
  852.       IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END;
  853.       y.mode := Push; y.a0 := SP;
  854.       OCC.Move (L, x, y); OCI.Unload (x);
  855.       OCC.CallKernel (OCC.kMove);
  856.       y.mode := Undef; OCC.RestoreRegisters (R, y)
  857.     ELSE
  858.       OCS.Mark (111)
  859.     END;
  860.     p.typ := OCT.notyp
  861.   ELSE
  862.     OCS.Mark (64)
  863.   END
  864.   (* ;OCM.TraceOut (mname, pname); *)
  865. END StPar3;
  866.  
  867. (*------------------------------------*)
  868. PROCEDURE StFct * (VAR p : OCT.Item; fctno, parno : INTEGER; VAR R : SET);
  869.  
  870.   (* CONST pname = "StFct"; *)
  871.  
  872.   VAR
  873.     p2, r0, r1, x, y : OCT.Item; L0, f, f1, proc : INTEGER;
  874.     btyp : OCT.Struct;
  875.  
  876. BEGIN (* StFct *)
  877.   (* OCM.TraceIn (mname, pname); *)
  878.   IF fctno >= OCT.TwoPar THEN
  879.     IF (fctno = OCT.pASSERT) & (parno = 1) THEN
  880.       IF p.mode # Coc THEN
  881.         OCC.PutF1 (OCC.TST, B, p);                    (*    TST.B <p>     *)
  882.         OCI.Unload (p); L0 := OCC.pc;
  883.         OCC.PutWord (OCC.BNE)                         (*    BNE.S 2$      *)
  884.       ELSE
  885.         OCC.PutWord (OCC.Bcc + (p.a0 * 100H));
  886.         OCC.PutWord (p.a1);                           (*    Bcc   2$      *)
  887.         L0 := OCC.pc - 2; OCC.FixLink (p.a2);
  888.       END;
  889.       p2.mode := Con; p2.a0 := 20; p2.typ := OCT.linttyp;
  890.       r0.mode := Reg; r0.a0 := D0;
  891.       OCC.Move (L, p2, r0); OCI.Unload (p2);  (* 1$ MOVE.L #20,D0        *)
  892.       x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  893.       x.label := OCT.ConstLabel;
  894.       OCC.PutF2 (OCC.LEA, x, A0);             (*    LEA    ModuleName,A0 *)
  895.       x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  896.       r1.mode := Reg; r1.a0 := D1;
  897.       OCC.Move (L, x, r1);                    (*    MOVE.L pos,D1        *)
  898.       OCC.CallKernel (OCC.kHalt);             (*    JSR    Kernel.Halt   *)
  899.       IF p.mode # Coc THEN                    (* 2$                      *)
  900.         OCC.PatchWord (L0, OCC.pc - L0 - 2)
  901.       ELSE OCC.FixLink (L0)
  902.       END;
  903.       p.typ := OCT.notyp
  904.     ELSIF (fctno = OCT.pDEC) & (parno = 1) THEN
  905.       IF p.rdOnly THEN OCS.Mark (324) END;
  906.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  907.       OCC.PutF5 (OCC.SUB, p.typ.size, p2, p);
  908.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  909.       p.typ := OCT.notyp
  910.     ELSIF (fctno = OCT.pINC) & (parno = 1) THEN
  911.       IF p.rdOnly THEN OCS.Mark (324) END;
  912.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  913.       OCC.PutF5 (OCC.ADD, p.typ.size, p2, p);
  914.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  915.       p.typ := OCT.notyp
  916.     ELSIF (fctno = OCT.pLEN) & (parno = 1) THEN
  917.       IF p.typ.form = DynArr THEN OCI.DescItem (p, p.desc, p.typ.adr)
  918.       ELSE p.mode := Con; p.a0 := p.typ.n; p.typ := OCT.linttyp
  919.       END
  920.     ELSIF fctno = OCT.pINLINE THEN
  921.       p.typ := OCT.notyp
  922.     ELSIF fctno = OCT.pSYSNEW THEN
  923.       IF
  924.         ((p.typ.form = Pointer) & (p.typ.sysflg = OberonFlag))
  925.         OR (p.typ.form = PtrTyp)
  926.       THEN
  927.         OCC.PutWord (50E7H)                           (* ST     -(A7)     *)
  928.       ELSE
  929.         OCC.PutWord (51E7H)                           (* SF     -(A7)     *)
  930.       END;
  931.       OCC.CallKernel (OCC.kNewSysBlk);                (* JSR    NewSysBlk *)
  932.       IF p.typ.sysflg = BCPLFlag THEN
  933.         OCC.PutWord (0E480H)                          (* ASR.L  #2,D0     *)
  934.       END;
  935.       x.mode := Undef; OCC.RestoreRegisters (R, x);
  936.       r0.mode := Reg; r0.a0 := D0;
  937.       OCC.Move (L, r0, p);                            (* MOVE.L D0,<var>  *)
  938.       p.typ := OCT.notyp
  939.     ELSIF (parno < 2) OR (fctno = OCT.pMOVE) & (parno < 3) THEN
  940.       OCS.Mark (65)
  941.     END
  942.   ELSIF (fctno = OCT.pNEW) & (parno >= 1) THEN
  943.     f := p.typ.form;
  944.     IF f = Pointer THEN
  945.       f1 := p.typ.sysflg; btyp := p.typ.BaseTyp; f := btyp.form;
  946.       r0.mode := Reg; r0.a0 := D0;
  947.       IF (f1 = OberonFlag) & NeedsTag (btyp) THEN
  948.         IF f = Record THEN
  949.           IF parno > 1 THEN OCS.Mark (64) END;
  950.           proc := OCC.kNewRecord
  951.         ELSIF f = Array THEN
  952.           IF parno > 1 THEN OCS.Mark (64) END;
  953.           proc := OCC.kNewArray
  954.         ELSIF f = DynArr THEN
  955.           WHILE btyp.form = DynArr DO btyp := btyp.BaseTyp; DEC (parno) END;
  956.           WHILE btyp.form = Array DO btyp := btyp.BaseTyp END;
  957.           IF parno > 1 THEN OCS.Mark (64)
  958.           ELSIF parno < 1 THEN OCS.Mark (65)
  959.           END;
  960.           proc := OCC.kNewArray
  961.         END
  962.       ELSE
  963.         IF f1 = OberonFlag THEN
  964.           IF f = DynArr THEN
  965.             WHILE btyp.form = DynArr DO
  966.               btyp := btyp.BaseTyp; DEC (parno)
  967.             END;
  968.             IF parno > 1 THEN OCS.Mark (64)
  969.             ELSIF parno < 1 THEN OCS.Mark (65)
  970.             END
  971.           END;
  972.           OCC.PutWord (50E7H)                     (* ST     -(A7)        *)
  973.         ELSE
  974.           OCC.PutWord (51E7H)                     (* SF     -(A7)        *)
  975.         END;
  976.         proc := OCC.kNewSysBlk
  977.       END;
  978.       OCC.CallKernel (proc);
  979.       IF f1 = BCPLFlag THEN OCC.PutWord (0E480H) END;(* ASR.L  #2,D0     *)
  980.       x.mode := Undef; OCC.RestoreRegisters (R, x);
  981.       OCC.Move (L, r0, p);                           (* MOVE.L D0,<var>  *)
  982.     END;
  983.     p.typ := OCT.notyp
  984.   ELSIF parno < 1 THEN
  985.     OCS.Mark (65)
  986.   END
  987.   (* ;OCM.TraceOut (mname, pname); *)
  988. END StFct;
  989.  
  990. (*------------------------------------*)
  991. PROCEDURE Inline * (VAR x : OCT.Item);
  992.  
  993.   (* CONST pname = "Inline"; *)
  994.  
  995.   VAR f : INTEGER;
  996.  
  997. BEGIN (* Inline *)
  998.   (* OCM.TraceIn (mname, pname); *)
  999.   f := x.typ.form;
  1000.   IF (f IN intSet) & (x.mode = Con) THEN
  1001.     IF f = LInt THEN OCC.PutLong (x.a0)
  1002.     ELSE OCC.PutWord (x.a0)
  1003.     END
  1004.   ELSE
  1005.     OCS.Mark (17)
  1006.   END
  1007.   (* ;OCM.TraceOut (mname, pname); *)
  1008. END Inline;
  1009.  
  1010. (*------------------------------------*)
  1011. PROCEDURE NewPar * (VAR x, p0, p1 : OCT.Item; n : INTEGER);
  1012.  
  1013.   (* CONST pname = "NewPar"; *)
  1014.  
  1015.   VAR f, i : INTEGER; btyp : OCT.Struct; desc, r0, y : OCT.Item;
  1016.       calcSize : BOOLEAN;
  1017.  
  1018. BEGIN (* NewPar *)
  1019.   (* OCM.TraceIn (mname, pname); *)
  1020.   IF p1.typ.form IN intSet THEN
  1021.     f := x.typ.form;
  1022.     IF (f = Pointer) & (x.typ.sysflg = OberonFlag) THEN
  1023.       btyp := x.typ; i := 0;
  1024.       WHILE (btyp.BaseTyp # NIL) & (i < n) DO
  1025.         btyp := btyp.BaseTyp; INC (i)
  1026.       END;
  1027.       f := btyp.form;
  1028.       IF f = DynArr THEN
  1029.         IF p1.typ.form # LInt THEN OCE.ConvertInts (p1, OCT.linttyp) END;
  1030.         OCI.DescItem (desc, x.desc, btyp.adr);
  1031.         OCC.Move (L, p1, desc);
  1032.         OCI.UpdateDesc (desc, btyp.adr);
  1033.         btyp := btyp.BaseTyp; f := btyp.form;
  1034.         IF p1.mode = Con THEN
  1035.           IF f # DynArr THEN p1.a0 := p1.a0 * btyp.size END;
  1036.           calcSize := FALSE
  1037.         ELSE
  1038.           calcSize := TRUE
  1039.         END;
  1040.         IF n = 1 THEN p0 := p1
  1041.         ELSE OCE.Op (OCS.times, p0, p1, TRUE)
  1042.         END;
  1043.         IF calcSize & (f # DynArr) & (btyp.size > 1) THEN
  1044.           y.mode := Con; y.a0 := btyp.size; y.typ := OCT.linttyp;
  1045.           OCE.Op (OCS.times, p0, y, TRUE)
  1046.         END;
  1047.         IF f # DynArr THEN
  1048.           OCI.UnloadDesc (x);
  1049.           y.mode := Push; y.a0 := SP;
  1050.           OCC.Move (L, p0, y); OCI.Unload (p0)
  1051.         END;
  1052.       ELSE OCS.Mark (64)
  1053.       END
  1054.     ELSE OCS.Mark (64)
  1055.     END
  1056.   ELSE OCS.Mark (328)
  1057.   END
  1058.   (* ;OCM.TraceOut (mname, pname); *)
  1059. END NewPar;
  1060.  
  1061. END OCP.
  1062.  
  1063. (***************************************************************************
  1064.  
  1065.   $Log: OCP.mod $
  1066.   Revision 5.9.1.1  1995/03/08  19:20:29  fjc
  1067.   - OC 5.22
  1068.  
  1069.   Revision 5.9.1.1  1995/03/08  19:04:46  fjc
  1070.   - OC 5.22
  1071.  
  1072.   Revision 5.9  1995/01/26  00:17:17  fjc
  1073.   - Release 1.5
  1074.  
  1075.   Revision 5.8  1995/01/03  21:22:07  fjc
  1076.   - Changed OCG to OCM.
  1077.  
  1078.   Revision 5.7  1994/12/16  17:33:01  fjc
  1079.   - Changed Symbol to Label.
  1080.  
  1081.   Revision 5.6  1994/11/13  11:31:33  fjc
  1082.   - Changed handling of ENTIER.
  1083.   - [bug] ABS now implemented for reals.
  1084.   - Implemented SYSTEM.CC.
  1085.  
  1086.   Revision 5.5  1994/10/23  16:16:31  fjc
  1087.   - Complete overhaul:
  1088.     - Added SaveRegs().
  1089.     - Removed code for handling obsolete SYSTEM procedures:
  1090.       GC, RC, ARGLEN, ARGS, SIZETAG, SETCLEANUP, BIND,
  1091.       GETNAME and NEWTAG.
  1092.     - All access to RTS is now through OCC.CallKernel().
  1093.  
  1094.   Revision 5.4  1994/09/25  18:01:55  fjc
  1095.   - Changed to reflect new object modes and system flags.
  1096.  
  1097.   Revision 5.3  1994/09/15  10:36:36  fjc
  1098.   - Replaced switches with pragmas.
  1099.  
  1100.   Revision 5.2  1994/09/08  10:50:49  fjc
  1101.   - Changed to use pragmas/options.
  1102.  
  1103.   Revision 5.1  1994/09/03  19:29:08  fjc
  1104.   - Bumped version number
  1105.  
  1106. ***************************************************************************)
  1107.