home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 2 / goldfish_vol2_cd1.bin / files / dev / obero / oberon-a / source / oc / ocp.mod < prev    next >
Text File  |  1994-08-08  |  41KB  |  1,203 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: OCP.mod $
  4.   Description: Code selection for standard procedures
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 4.9 $
  8.       $Author: fjc $
  9.         $Date: 1994/08/03 11:44:38 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1994, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. ***************************************************************************)
  19.  
  20. MODULE OCP;
  21.  
  22. (*
  23. ** $C= CaseChk       $I= IndexChk  $L+ LongAdr   $N= NilChk
  24. ** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  25. ** $V= OvflChk       $Z= ZeroVars
  26. *)
  27.  
  28. IMPORT OCG, OCS, OCT, OCC, OCI, OCE, SYS := SYSTEM;
  29.  
  30.  
  31. (* --- Local declarations ----------------------------------------------- *)
  32.  
  33. CONST
  34.  
  35.   (* object modes *)
  36.   Var = OCG.Var; VarX = OCG.VarX; VarR = OCG.VarR; Ind = OCG.Ind;
  37.   IndX = OCG.IndX; IndR = OCG.IndR; RegI = OCG.RegI; RegX = OCG.RegX;
  38.   Lab = OCG.Lab; LabI = OCG.LabI; Con = OCG.Con; Push = OCG.Push;
  39.   Pop = OCG.Pop; Coc = OCG.Coc; Reg = OCG.Reg; Fld = OCG.Fld;
  40.   Typ = OCG.Typ; Abs = OCG.Abs; XProc = OCG.XProc;
  41.  
  42.   (* structure forms *)
  43.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  44.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  45.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  46.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  47.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  48.   Record = OCT.Record; PtrTyp = OCT.PtrTyp; CPtrTyp = OCT.CPtrTyp;
  49.   BPtrTyp = OCT.BPtrTyp; BPointer = OCT.BPointer; CPointer = OCT.CPointer;
  50.   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, CPointer, BPointer, PtrTyp, CPtrTyp, BPtrTyp};
  57.   uptrSet  = {CPointer, BPointer, CPtrTyp, BPtrTyp};
  58.   allSet   = {0 .. 31};
  59.   adrSet   = {LInt, Pointer, PtrTyp, CPointer, CPtrTyp, 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 Entier (VAR x : OCT.Item);
  81.  
  82.   (* CONST pname = "Entier"; *)
  83.  
  84.   CONST SPFix = -30;
  85.   VAR base, br : OCT.Item; R : SET;
  86.  
  87. BEGIN (* Entier *)
  88.   (* OCG.TraceIn (mname, pname); *)
  89.   br.mode := Reg; br.a0 := A6;
  90.   base.mode := Lab; base.a0 := OCT.mathBase; base.a1 := 4;
  91.   base.symbol := OCT.OberonSysVAR;
  92.   OCC.LoadRegParams1 (R, x);
  93.   OCC.Move (L, base, br);
  94.   br.mode := RegI; br.a1 := SPFix;
  95.   OCC.PutF3 (OCC.JSR, br);
  96.   OCC.RestoreRegisters (R, x)
  97.   (* ;OCG.TraceOut (mname, pname); *)
  98. END Entier;
  99.  
  100. (*------------------------------------*)
  101. PROCEDURE CheckCleanupProc (VAR x : OCT.Item);
  102.  
  103.   (* CONST pname = "CheckCleanupProc"; *)
  104.  
  105.   VAR par : OCT.Object; typ : OCT.Struct;
  106.  
  107. BEGIN (* CheckCleanupProc *)
  108.   (* OCG.TraceIn (mname, pname); *)
  109.   IF (x.mode = XProc) OR (x.typ.form = ProcTyp) THEN
  110.     IF x.mode = XProc THEN par := x.obj.link; typ := x.typ
  111.     ELSE par := x.typ.link; typ := x.typ.BaseTyp;
  112.     END;
  113.     IF OCI.IsParam (par) THEN OCS.Mark (117) END;
  114.     IF typ # OCT.notyp THEN OCS.Mark (301) END
  115.   ELSE
  116.     OCS.Mark (300)
  117.   END
  118.   (* ;OCG.TraceOut (mname, pname); *)
  119. END CheckCleanupProc;
  120.  
  121. (*------------------------------------*)
  122. PROCEDURE NeedsTag (typ : OCT.Struct) : BOOLEAN;
  123.  
  124.   VAR fld : OCT.Object;
  125.  
  126. BEGIN (* NeedsTag *)
  127.   IF typ.form IN {Pointer, Record} THEN
  128.     RETURN TRUE
  129.   ELSIF typ.form IN {Array, DynArr} THEN
  130.     RETURN NeedsTag (typ.BaseTyp)
  131.   (*
  132.   ELSIF typ.form = Record THEN
  133.     IF (typ.BaseTyp # NIL) & NeedsTag (typ.BaseTyp) THEN RETURN TRUE END;
  134.     fld := typ.link;
  135.     WHILE fld # NIL DO
  136.       IF (fld.name < 0) OR NeedsTag (fld.typ) THEN RETURN TRUE END;
  137.       fld := fld.left
  138.     END
  139.   *)
  140.   END;
  141.   RETURN FALSE
  142. END NeedsTag;
  143.  
  144. (*------------------------------------*)
  145. PROCEDURE StPar1 * (VAR x : OCT.Item; fctno : INTEGER; VAR R : SET);
  146.  
  147.   (* CONST pname = "StPar1"; *)
  148.  
  149.   VAR f, f1 : INTEGER; y, z, r0, r1 : OCT.Item;
  150.       L0, L1 : INTEGER; size : LONGINT; par : OCT.Object;
  151.       typ : OCT.Struct; sym : OCT.Symbol; desc : OCT.Desc;
  152.  
  153. BEGIN (* StPar1 *)
  154.   (* OCG.TraceIn (mname, pname); *)
  155.   IF (fctno = OCT.pGC) OR (fctno = OCT.pRC) THEN OCS.Mark (64); RETURN END;
  156.   f := x.typ.form; size := x.typ.size;
  157.   CASE fctno OF
  158.     OCT.pABS :
  159.       IF f IN intSet THEN
  160.         IF x.mode = Con THEN
  161.           x.a0 := ABS (x.a0)
  162.         ELSE
  163.           OCI.Load (x);                                (*    MOVE.z  x,Dn *)
  164.           OCC.PutF1 (OCC.TST, size, x);                (*    TST.z   Dn   *)
  165.           OCC.PutWord (6A02H);                         (*    BPL     1$   *)
  166.           OCC.PutF1 (OCC.NEG, size, x)                 (*    NEG.z   Dn   *)
  167.         END
  168.       ELSE
  169.         OCS.Mark (111)
  170.       END
  171.     |
  172.     OCT.pCAP :
  173.       IF (f = String) & (x.a1 <= 2) THEN
  174.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  175.       END;
  176.       IF f = Char THEN
  177.         IF x.mode = Con THEN
  178.           x.a0 := ORD (CAP (CHR (x.a0)))
  179.         ELSE
  180.           y.mode := Con; y.typ := OCT.chartyp;
  181.           OCI.Load (x);                                (*    MOVE x,Dn    *)
  182.           y.a0 := ORD ("a");
  183.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "a", Dn *)
  184.           OCC.PutWord (6510H);                         (*    BCS 1$       *)
  185.           y.a0 := ORD ("z");
  186.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "z", Dn *)
  187.           OCC.PutWord (6306H);                         (*    BLS 0$       *)
  188.           y.a0 := 0E0H; OCC.PutF6 (OCC.CMPI, B, y, x); (*    CMPI 0E0X,Dn *)
  189.           OCC.PutWord (6504H);                         (*    BCS 1$       *)
  190.           y.a0 := 0DFH; OCC.PutF6 (OCC.ANDI, B, y, x); (* 0$ ANDI 0DFH,Dn *)
  191.         END                                            (* 1$              *)
  192.       ELSE
  193.         OCS.Mark (111); x.typ := OCT.chartyp
  194.       END
  195.     |
  196.     OCT.pCHR :
  197.       IF ~(f IN {Undef, Byte, SInt, Int, LInt}) THEN OCS.Mark (111) END;
  198.       IF ~(f IN {Byte, SInt}) & (x.mode # Con) THEN OCI.Load (x) END;
  199.       x.typ := OCT.chartyp
  200.     |
  201.     OCT.pENTIER :
  202.       IF f IN realSet THEN Entier (x)
  203.       ELSE OCS.Mark (111)
  204.       END;
  205.       x.typ := OCT.linttyp;
  206.     |
  207.     OCT.pHALT :
  208.       IF (f IN intSet) & (x.mode = Con) THEN
  209.         y.mode := Lab; y.a0 := OCT.returnCode; y.a1 := 4;
  210.         y.symbol := OCT.OberonSysVAR;
  211.         OCC.Move (L, x, y);
  212.         y.mode := Lab; y.a0 := 0; y.a1 := 4;
  213.         y.symbol := OCT.OberonSysCLEANUP;
  214.         OCC.PutF3 (OCC.JMP, y);
  215.       ELSE
  216.         OCS.Mark (17)
  217.       END;
  218.       x.typ := OCT.notyp
  219.     |
  220.     OCT.pLONG :
  221.       IF (f = String) & (x.a1 <= 2) THEN
  222.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  223.       END;
  224.       IF f = SInt THEN OCE.ConvertInts (x, OCT.inttyp)
  225.       ELSIF f = Int THEN OCE.ConvertInts (x, OCT.linttyp)
  226.       ELSIF f = BSet THEN
  227.         IF OCS.portableCode THEN OCS.Mark (915) END;
  228.         IF x.mode # Con THEN
  229.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.wsettyp;
  230.           OCI.Load (x); OCC.Move (B, y, x)
  231.         END;
  232.         x.typ := OCT.wsettyp
  233.       ELSIF f = WSet THEN
  234.         IF OCS.portableCode THEN OCS.Mark (915) END;
  235.         IF x.mode # Con THEN
  236.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.settyp;
  237.           OCI.Load (x); OCC.Move (W, y, x)
  238.         END;
  239.         x.typ := OCT.settyp
  240.       ELSIF f = Real THEN
  241.         x.typ := OCT.lrltyp
  242.       ELSIF f = Char THEN
  243.         IF x.mode # Con THEN
  244.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  245.           OCI.Load (x); OCC.Move (B, y, x)
  246.         END;
  247.         x.typ := OCT.linttyp
  248.       ELSE
  249.         OCS.Mark (111)
  250.       END
  251.     |
  252.     OCT.pMAX :
  253.       IF x.mode = Typ THEN
  254.         x.mode := Con;
  255.         CASE f OF
  256.           Bool  : x.a0 := OCG.MaxBool                      |
  257.           Char  : x.a0 := OCG.MaxChar                      |
  258.           SInt  : x.a0 := OCG.MaxSInt                      |
  259.           Int   : x.a0 := OCG.MaxInt                       |
  260.           LInt  : x.a0 := OCG.MaxLInt                      |
  261.           Real  : x.a0 := SYS.VAL (LONGINT, OCG.MaxReal)   |
  262.           LReal : x.a0 := SYS.VAL (LONGINT, OCG.MaxLReal)  |
  263.           BSet  : x.a0 := OCG.MaxBSet; x.typ := OCT.inttyp |
  264.           WSet  : x.a0 := OCG.MaxWSet; x.typ := OCT.inttyp |
  265.           Set   : x.a0 := OCG.MaxSet; x.typ := OCT.inttyp  |
  266.         ELSE
  267.           OCS.Mark (111)
  268.         END; (* CASE f *)
  269.       ELSE
  270.         OCS.Mark (110)
  271.       END
  272.     |
  273.     OCT.pMIN :
  274.       IF x.mode = Typ THEN
  275.         x.mode := Con;
  276.         CASE f OF
  277.           Bool  : x.a0 := OCG.MinBool                               |
  278.           Char  : x.a0 := OCG.MinChar                               |
  279.           SInt  : x.a0 := OCG.MinSInt                               |
  280.           Int   : x.a0 := OCG.MinInt                                |
  281.           LInt  : x.a0 := OCG.MinLInt                               |
  282.           Real  : x.a0 := SYS.VAL (LONGINT, OCG.MinReal)            |
  283.           LReal : x.a0 := SYS.VAL (LONGINT, OCG.MinLReal)           |
  284.           BSet, WSet, Set : x.a0 := OCG.MinSet; x.typ := OCT.inttyp |
  285.         ELSE
  286.           OCS.Mark (111)
  287.         END; (* CASE f *)
  288.       ELSE
  289.         OCS.Mark (110)
  290.       END
  291.     |
  292.     OCT.pNEW :
  293.       IF (f IN {Pointer, CPointer, BPointer}) & (x.mode # Con) THEN
  294.         IF x.rdOnly THEN OCS.Mark (324) END;
  295.         f1 := f; typ := x.typ.BaseTyp; f := typ.form;
  296.         r0.mode := Reg; r0.a0 := D0;
  297.         IF (f1 = Pointer) & NeedsTag (typ) THEN
  298.           IF f = Array THEN
  299.             y.mode := Con; y.a0 := typ.size;
  300.             OCC.Move (L, y, r0)                       (* MOVE.L #size,D0  *)
  301.           END
  302.         ELSE
  303.           IF f # DynArr THEN
  304.             y.mode := Con; y.a0 := typ.size;
  305.             OCC.Move (L, y, r0)                       (* MOVE.L #size,D0  *)
  306.           END
  307.         END;
  308.         IF f = DynArr THEN
  309.           OCI.UnloadDesc (x);
  310.           desc := x.desc; IF desc = NIL THEN desc := OCT.AllocDesc() END;
  311.           desc.lev := x.lev; desc.mode := x.mode; desc.a0 := x.a0;
  312.           desc.a1 := x.a1; desc.a2 := x.a2; x.desc := desc;
  313.         END
  314.       ELSE OCS.Mark (111)
  315.       END
  316.     |
  317.     OCT.pODD :
  318.       IF f IN intSet THEN
  319.         y.mode := Con; y.a0 := 0; y.typ := OCT.inttyp;
  320.         IF f = SInt THEN OCC.Bit (OCC.BTST, y, x);
  321.         ELSE OCI.Load (x); OCC.Bit (OCC.BTST, y, x); OCI.Unload (x)
  322.         END;
  323.       ELSE
  324.         OCS.Mark (111)
  325.       END;
  326.       OCE.setCC (x, OCC.NE)
  327.     |
  328.     OCT.pORD :
  329.       IF (f = String) & (x.a1 <= 2) THEN
  330.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  331.       END;
  332.       IF (f = Char) OR (f = Byte) THEN
  333.         IF x.mode # Con THEN
  334.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.inttyp;
  335.           OCI.Load (x); OCC.Move (B, y, x)
  336.         END
  337.       ELSE
  338.         OCS.Mark (111)
  339.       END;
  340.       x.typ := OCT.inttyp
  341.     |
  342.     OCT.pSHORT :
  343.       IF f = LInt THEN (* range test missing *)
  344.         IF x.mode = Con THEN
  345.           OCE.SetIntType (x); IF x.typ.form = LInt THEN OCS.Mark (203) END
  346.         ELSE
  347.           OCI.Load (x)
  348.         END;
  349.         x.typ := OCT.inttyp
  350.       ELSIF f = Int THEN (* range test missing *)
  351.         IF x.mode = Con THEN
  352.           OCE.SetIntType (x); IF x.typ.form # SInt THEN OCS.Mark (203) END
  353.         ELSE
  354.           OCI.Load (x)
  355.         END;
  356.         x.typ := OCT.sinttyp
  357.       ELSIF f = Set THEN (* range test missing *)
  358.         IF OCS.portableCode THEN OCS.Mark (915) END;
  359.         IF x.mode # Con THEN OCI.Load (x) END;
  360.         x.typ := OCT.wsettyp
  361.       ELSIF f = WSet THEN (* range test missing *)
  362.         IF OCS.portableCode THEN OCS.Mark (915) END;
  363.         IF x.mode # Con THEN OCI.Load (x) END;
  364.         x.typ := OCT.bsettyp
  365.       ELSIF f = LReal THEN
  366.         x.typ := OCT.realtyp
  367.       ELSE
  368.         OCS.Mark (111)
  369.       END
  370.     |
  371.     OCT.pADR :
  372.       OCI.Adr (x); x.typ := OCT.cptrtyp
  373.     |
  374.     OCT.pARGLEN, OCT.pARGS :
  375.       IF x.mode >= Con THEN OCS.Mark (122)
  376.       ELSIF f = LInt THEN
  377.         IF x.rdOnly THEN OCS.Mark (324) END;
  378.         y.mode := Lab; y.a1 := 4; y.symbol := OCT.OberonSysVAR;
  379.         IF fctno = OCT.pARGLEN THEN y.a0 := OCT.argLen
  380.         ELSE y.a0 := OCT.args
  381.         END;
  382.         OCC.Move (L, y, x)
  383.       ELSE
  384.         OCS.Mark (111)
  385.       END;
  386.       x.typ := OCT.notyp
  387.     |
  388.     OCT.pDISPOSE :
  389.       IF f IN ptrSet THEN
  390.         IF x.rdOnly THEN OCS.Mark (324) END;
  391.         r0.mode := Reg; r0.a0 := D0;
  392.         OCC.Move (L, x, r0);                            (* MOVE.L x,D0    *)
  393.         IF f = BPointer THEN
  394.           OCC.PutWord (-2F80H);                         (* ADD.L  D0,D0   *)
  395.           OCC.PutWord (-2F80H);                         (* ADD.L  D0,D0   *)
  396.         END;
  397.         z.mode := Lab; z.a0 := 0; z.a1 := 4;
  398.         z.symbol := OCT.OberonSysDISPOSE;
  399.         OCC.SaveRegisters (R, z, OCC.AllRegs);
  400.         OCC.PutF3 (OCC.JSR, z);                         (* JSR    DISPOSE *)
  401.         OCC.RestoreRegisters (R, z);
  402.         y.mode := Con; y.a0 := 0; y.typ := OCT.niltyp;
  403.         OCC.Move (L, y, x)                              (* MOVE.L #NIL,x  *)
  404.       ELSE
  405.         OCS.Mark (111)
  406.       END;
  407.       x.typ := OCT.notyp
  408.     |
  409.     OCT.pSETCLEANUP :
  410.       CheckCleanupProc (x); IF x.mode = XProc THEN OCI.Adr (x) END;
  411.       y.mode := Reg; y.a0 := D0; OCC.Move (L, x, y);
  412.       y.mode := Lab; y.a0 := 0; y.a1 := 4;
  413.       y.symbol := OCT.OberonSysSETCLEANUP;
  414.       OCC.PutF3 (OCC.JSR, y);
  415.       x.typ := OCT.notyp
  416.     |
  417.     OCT.pSIZE :
  418.       IF x.mode = Typ THEN x.a0 := x.typ.size
  419.       ELSE OCS.Mark (110); x.a0 := 1
  420.       END;
  421.       x.mode := Con; OCE.SetIntType (x)
  422.     |
  423.     OCT.pSTRLEN :
  424.       IF ((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char) THEN
  425.         y := x; OCI.LoadAdr (y); y.mode := Pop;       (*    LEA    <y>,Ay *)
  426.         x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  427.         OCI.Load (x);                                 (*    MOVEQ  #0,Dx  *)
  428.         OCC.PutF1 (OCC.TST, B, y); OCC.FreeReg (y);   (* 1$ TST.B  (Ay)+  *)
  429.         OCC.PutWord (6704H);                          (*    BEQ    2$     *)
  430.         OCC.PutF7 (OCC.ADDQ, L, 1, x);                (*    ADDQ.L #1,Dx  *)
  431.         OCC.PutWord (60F8H);                          (*    BRA    1$     *)
  432.       ELSIF f = String THEN                           (* 2$               *)
  433.         x.mode := Con; x.a0 := x.a1 - 1; x.typ := OCT.linttyp
  434.       ELSE
  435.         OCS.Mark (111)
  436.       END
  437.     |
  438.     OCT.pASH :
  439.       IF f IN intSet THEN
  440.         OCI.Load (x); IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END
  441.       ELSE
  442.         OCS.Mark (111)
  443.       END
  444.     |
  445.     OCT.pASSERT :
  446.       IF f = Bool THEN
  447.         IF x.mode = Con THEN
  448.           IF x.a0 = 0 THEN OCS.Mark (319) ELSE OCS.Mark (320) END;
  449.           OCE.setCC (x, OCC.T)
  450.         END;
  451.       ELSE OCS.Mark (120)
  452.       END
  453.     |
  454.     OCT.pBIND :
  455.       IF (x.mode # Typ) THEN
  456.         IF
  457.           (f = Pointer) & (x.typ.BaseTyp # OCT.undftyp)
  458.           & (x.typ.BaseTyp.form # Array)
  459.         THEN
  460.           OCS.Mark (110)
  461.         ELSIF (f # CPointer) (*& (f # BPointer)*) THEN
  462.           OCS.Mark (110)
  463.         END
  464.       END
  465.     |
  466.     OCT.pCOPY :
  467.       IF
  468.         ~((((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char))
  469.           OR (f = String))
  470.       THEN
  471.         OCS.Mark (111)
  472.       END
  473.     |
  474.     OCT.pDEC, OCT.pINC :
  475.       IF x.mode >= Con THEN     OCS.Mark (112)
  476.       ELSIF ~(f IN intSet) THEN OCS.Mark (111)
  477.       ELSIF x.rdOnly THEN OCS.Mark (324)
  478.       END
  479.     |
  480.     OCT.pINCL, OCT.pEXCL :
  481.       IF x.mode >= Con THEN     OCS.Mark (112)
  482.       ELSIF ~(f IN setSet) THEN OCS.Mark (111); x.typ := OCT.settyp
  483.       ELSIF x.rdOnly THEN OCS.Mark (324)
  484.       END
  485.     |
  486.     OCT.pLEN :
  487.       IF (f # DynArr) & (f # Array) THEN OCS.Mark (131) END
  488.     |
  489.     OCT.pAND, OCT.pOR, OCT.pXOR :
  490.       IF ~(f IN bitOpSet) THEN OCS.Mark (111) END
  491.     |
  492.     OCT.pBIT, OCT.pGET, OCT.pPUT :
  493.       IF (f IN intSet) & (x.mode = Con) THEN
  494.         x.mode := Abs
  495.       ELSIF f IN adrSet THEN
  496.         IF x.mode = Var THEN
  497.           x.mode := Ind; x.a1 := 0
  498.         ELSE
  499.           OCC.GetAReg (y); OCC.Move (L, x, y);
  500.           x := y; x.mode := RegI; x.a1 := 0
  501.         END
  502.       ELSE
  503.         OCS.Mark (111)
  504.       END
  505.     |
  506.     OCT.pGETREG, OCT.pPUTREG, OCT.pREG :
  507.       IF (f IN intSet) & (x.mode = Con) THEN
  508.         IF (0 <= x.a0) & (x.a0 <= 15) THEN
  509.           x.mode := Reg;
  510.           IF fctno = OCT.pREG THEN
  511.             OCC.ReserveReg (SHORT (x.a0)); x.typ := OCT.lwordtyp
  512.           END
  513.         ELSE OCS.Mark (219)
  514.         END
  515.       ELSE
  516.         OCS.Mark (17)
  517.       END
  518.     |
  519.     OCT.pLSH, OCT.pROT :
  520.       IF (f = String) & (x.a1 <= 2) THEN
  521.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  522.       END;
  523.       IF f IN bitOpSet THEN OCI.Load (x)
  524.       ELSE OCS.Mark (111)
  525.       END
  526.     |
  527.     OCT.pSYSNEW :
  528.       IF ~(f IN ptrSet) OR (x.mode = Con) THEN OCS.Mark (111)
  529.       ELSIF x.rdOnly THEN OCS.Mark (324)
  530.       (* ELSIF NeedsTag (x.typ) THEN OCS.Mark (339) *)
  531.       END
  532.     |
  533.     OCT.pVAL : IF x.mode # Typ THEN OCS.Mark (110) END
  534.     |
  535.     OCT.pMOVE :
  536.       IF (f IN adrSet) THEN
  537.         OCC.ReserveReg (A0); r0.mode := Reg; r0.a0 := A0;
  538.         OCC.Move (L, x, r0); OCI.Unload (x);
  539.       ELSE
  540.         OCS.Mark (111)
  541.       END
  542.     |
  543.     OCT.pTAG :
  544.       typ := x.typ; IF f = Pointer THEN typ := typ.BaseTyp END;
  545.       IF typ.form = Record THEN
  546.         IF x.mode = Typ THEN (* Type *)
  547.           x.mode := LabI; x.a0 := 0; x.a1 := 4; x.symbol := typ.symbol
  548.         ELSIF (x.mode <= RegX) & (f = Pointer) THEN (* Pointer variable *)
  549.           OCE.DeRef (x); x.a1 := -4
  550.         ELSIF (x.mode = Ind) & (x.obj # NIL) & (x.obj # OCC.wasderef) THEN
  551.           (* VAR parameter *)
  552.           x.mode := Var; INC (x.a0, 4)
  553.         ELSE (* Bzzzzt! *)
  554.           OCS.Mark (338)
  555.         END
  556.       ELSIF f = PtrTyp THEN
  557.         IF (x.mode <= RegX) THEN (* Pointer variable *)
  558.           IF x.mode = Var THEN
  559.             IF OCS.nilCheck THEN
  560.               y := x;
  561.               OCC.PutF1 (OCC.TST, L, y);            (*    TST.L x         *)
  562.               OCC.PutWord (6602H);                  (*    BNE   1$        *)
  563.               OCC.PutWord (OCC.TRAP + OCC.NilCheck);(*    TRAP  #NilCheck *)
  564.               OCI.Unload (y)                        (* 1$                 *)
  565.             END;
  566.             x.mode := Ind
  567.           ELSE
  568.             y := x; y.typ := OCT.ptrtyp; OCC.GetAReg (x);
  569.             IF OCS.nilCheck THEN
  570.               OCI.Load (y);                       (*    MOVE.L  x,Dn      *)
  571.               OCC.PutWord (6602H);                (*    BNE     1$        *)
  572.               OCC.PutWord (OCC.TRAP + OCC.NilCheck);
  573.                                                   (*    TRAP    #NilCheck *)
  574.             END;                                  (* 1$                   *)
  575.             OCC.Move (L, y, x);                   (*    MOVEA.L x, An     *)
  576.             OCI.Unload (y); x.mode := RegI
  577.           END;
  578.           x.a1 := -4; x.rdOnly := FALSE
  579.         ELSE (* Bzzzzt! *)
  580.           OCS.Mark (338)
  581.         END
  582.       ELSE
  583.         OCS.Mark (53)
  584.       END;
  585.       x.typ := OCT.tagtyp; x.rdOnly := FALSE
  586.     |
  587.     OCT.pSIZETAG :
  588.       IF f = TagTyp THEN
  589.         OCI.UnloadDesc (x);
  590.         IF x.mode = Var THEN
  591.           x.mode := Ind
  592.         ELSE
  593.           y := x; OCC.GetAReg (x); OCC.Move (L, y, x);  (* MOVEA.L x, An  *)
  594.           OCI.Unload (y); x.mode := RegI
  595.         END
  596.       ELSE
  597.         OCS.Mark (111)
  598.       END;
  599.       x.typ := OCT.linttyp; x.rdOnly := FALSE; x.a1 := 0
  600.     |
  601.     OCT.pGETNAME :
  602.       IF (f # TagTyp) OR (x.mode = Con) THEN
  603.         OCS.Mark (111)
  604.       END
  605.     |
  606.     OCT.pNEWTAG :
  607.       IF ~(f IN {Pointer, PtrTyp}) OR (x.mode = Con) THEN OCS.Mark (111)
  608.       ELSIF x.rdOnly THEN OCS.Mark (324)
  609.       END
  610.     |
  611.   ELSE
  612.     OCS.Mark (1014); OCS.Mark (fctno)
  613.   END; (* CASE fctno *)
  614.   (* ;OCG.TraceOut (mname, pname); *)
  615. END StPar1;
  616.  
  617. (*------------------------------------*)
  618. PROCEDURE StPar2 * (
  619.   VAR par1, par2 : OCT.Item; fctno : INTEGER; VAR R : SET);
  620.  
  621.   (* CONST pname = "StPar2"; *)
  622.  
  623.   VAR f : INTEGER; op, dim : INTEGER; typ, btyp, t1 : OCT.Struct;
  624.       freePar2 : BOOLEAN; L0, L1 : INTEGER; x, y, r0, r1 : OCT.Item;
  625.       dsc : OCT.Desc;
  626.  
  627. BEGIN (* StPar2 *)
  628.   (* OCG.TraceIn (mname, pname); *)
  629.   f := par2.typ.form; freePar2 := FALSE;
  630.   IF fctno < OCT.TwoPar THEN OCS.Mark (64); RETURN END;
  631.   CASE fctno OF
  632.     OCT.pASH, OCT.pLSH, OCT.pROT :
  633.       IF
  634.         ((fctno = OCT.pASH) & (f IN intSet)) OR
  635.         ((fctno # OCT.pASH) & (f IN bitOpSet))
  636.       THEN
  637.         IF (par2.mode = Con) & (par2.a0 = 0) THEN RETURN END;
  638.         IF fctno = OCT.pASH THEN op := OCC.ASR
  639.         ELSIF fctno = OCT.pLSH THEN op := OCC.LSR
  640.         ELSE op := OCC.ROR
  641.         END;
  642.         IF par2.mode = Con THEN
  643.           IF par2.a0 < 0 THEN par2.a0 := -par2.a0 ELSE INC (op, 100H) END;
  644.           IF par2.a0 > 8 THEN OCI.Load (par2); freePar2 := TRUE END;
  645.           OCC.Shift (op, par1.typ.size, par2, par1);
  646.           IF freePar2 THEN OCC.FreeReg (par2) END
  647.         ELSE
  648.           OCI.Load (par2);                         (*    MOVE.L <par2>,Dn *)
  649.           OCC.PutF1 (OCC.TST, par2.typ.size, par2);(*    TST.?  Dn        *)
  650.           L0 := OCC.pc; OCC.PutWord (6A00H);       (*    BPL.S  1$        *)
  651.           OCC.PutF1 (OCC.NEG, par2.typ.size, par2);(*    NEG.?  Dn        *)
  652.           OCC.Shift (op, par1.typ.size, par2, par1);
  653.                                                    (*    opR.?  Dn,<par1> *)
  654.           L1 := OCC.pc; OCC.PutWord (6000H);       (*    BRA.S  $2        *)
  655.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  656.           OCC.Shift (op+100H, par1.typ.size, par2, par1);
  657.                                                    (* 1$ opL.?  Dn,<par1> *)
  658.           OCC.PatchWord (L1, OCC.pc - L1 - 2);     (* 2$                  *)
  659.         END
  660.       ELSE
  661.         OCS.Mark (111)
  662.       END
  663.     |
  664.     OCT.pASSERT :
  665.       IF (par2.mode = Con) & (f IN intSet) THEN
  666.         IF par1.mode # Coc THEN
  667.           OCC.PutF1 (OCC.TST, B, par1);            (*    TST.B  <par1>    *)
  668.           OCI.Unload (par1); L0 := OCC.pc;
  669.           OCC.PutWord (OCC.BNE)                    (*    BNE.S  2$        *)
  670.         ELSE
  671.           op := OCC.Bcc + (SHORT (par1.a0) * 100H);
  672.           OCC.PutWord (op);
  673.           OCC.PutWord (SHORT (par1.a1));           (*    Bcc    2$        *)
  674.           L0 := OCC.pc - 2; OCC.FixLink (par1.a2);
  675.         END;
  676.         x.mode := Lab; x.a0 := OCT.returnCode; x.a1 := 4;
  677.         x.symbol := OCT.OberonSysVAR;
  678.         OCC.Move (L, par2, x);                     (* 1$ MOVE.L <par2>,D0 *)
  679.         x.mode := Lab; x.a0 := 0; x.a1 := 4;
  680.         x.symbol := OCT.OberonSysCLEANUP;
  681.         OCC.PutF3 (OCC.JMP, x);                    (*    JMP    CLEANUP   *)
  682.         IF par1.mode # Coc THEN                    (* 2$                  *)
  683.           OCC.PatchWord (L0, OCC.pc - L0 - 2)
  684.         ELSE OCC.FixLink (L0)
  685.         END;
  686.       ELSE OCS.Mark (17)
  687.       END;
  688.       par1.typ := OCT.notyp
  689.     |
  690.     OCT.pBIND :
  691.       typ := par1.typ; btyp := typ.BaseTyp; par1.typ := OCT.cptrtyp;
  692.       IF
  693.         (btyp = OCT.undftyp) OR (par2.typ = NIL) OR (par2.typ = OCT.undftyp)
  694.       THEN
  695.         OCS.Mark (111)
  696.       ELSIF btyp # par2.typ THEN
  697.         IF
  698.           (typ.form = CPointer) & (btyp.form = Record)
  699.           & (par2.typ.form = Record)
  700.         THEN
  701.           t1 := par2.typ;
  702.           WHILE (t1 # NIL) & (t1 # btyp) DO t1 := t1.BaseTyp END;
  703.           IF t1 # btyp THEN OCS.Mark (111) END;
  704.         ELSE
  705.           OCS.Mark (111)
  706.         END
  707.       END;
  708.       par1 := par2; OCI.Adr (par1); par1.typ := typ;
  709.     |
  710.     OCT.pDEC, OCT.pINC :
  711.       IF par1.typ # par2.typ THEN
  712.         IF (par2.mode = Con) & (f IN intSet) THEN par2.typ := par1.typ
  713.         ELSIF (par1.typ.form = Int) & (f = SInt) THEN
  714.           OCE.ConvertInts (par2, OCT.inttyp)
  715.         ELSIF (par1.typ.form = LInt) & (f IN {SInt, Int}) THEN
  716.           OCE.ConvertInts (par2, OCT.linttyp)
  717.         ELSE OCS.Mark (111)
  718.         END
  719.       ELSIF par2.mode # Con THEN
  720.         OCI.Load (par2)
  721.       END;
  722.       IF fctno = OCT.pDEC THEN op := OCC.SUB ELSE op := OCC.ADD END;
  723.       OCC.PutF5 (op, par1.typ.size, par2, par1);
  724.       IF OCS.overflowCheck THEN OCC.PutWord (OCC.TRAPV) END;
  725.       par1.typ := OCT.notyp
  726.     |
  727.     OCT.pEXCL :
  728.       OCE.Set0 (x, par2);
  729.       IF x.mode = Con THEN
  730.         x.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, x.a0));
  731.         OCC.PutF6 (OCC.ANDI, par1.typ.size, x, par1)
  732.       ELSE
  733.         OCC.PutF1 (OCC.NOT, L, x);
  734.         OCC.PutF5 (OCC.AND, par1.typ.size, x, par1)
  735.       END;
  736.       par1.typ := OCT.notyp
  737.     |
  738.     OCT.pINCL :
  739.       OCE.Set0 (x, par2);
  740.       IF x.mode = Con THEN OCC.PutF6 (OCC.ORI, par1.typ.size, x, par1)
  741.       ELSE OCC.PutF5 (OCC.iOR, par1.typ.size, x, par1)
  742.       END;
  743.       par1.typ := OCT.notyp
  744.     |
  745.     OCT.pLEN :
  746.       IF (par2.mode = Con) & (f = SInt) THEN
  747.         dim := SHORT (par2.a0); typ := par1.typ;
  748.         WHILE (dim > 0) & (typ.form IN {DynArr, Array}) DO
  749.           typ := typ.BaseTyp; DEC (dim)
  750.         END;
  751.         IF (dim # 0) OR ~(typ.form IN {DynArr, Array}) THEN OCS.Mark (132)
  752.         ELSE
  753.           IF typ.form = DynArr THEN OCI.DescItem (par1, par1.desc, typ.adr)
  754.           ELSE par1.mode := Con; par1.a0 := typ.n
  755.           END;
  756.           par1.typ := OCT.linttyp
  757.         END
  758.       ELSE
  759.         OCS.Mark (111)
  760.       END
  761.     |
  762.     OCT.pAND, OCT.pOR, OCT.pXOR :
  763.       IF f IN bitOpSet THEN
  764.         IF (par1.mode = Con) & (par2.mode = Con) THEN
  765.           IF fctno = OCT.pAND THEN
  766.             par1.a0 := SYS.AND (par1.a0, par2.a0)
  767.           ELSIF fctno = OCT.pXOR THEN
  768.             par1.a0 := SYS.XOR (par1.a0, par2.a0)
  769.           ELSE
  770.             par1.a0 := SYS.LOR (par1.a0, par2.a0)
  771.           END;
  772.           IF f IN intSet THEN OCE.SetIntType (par1) END
  773.         ELSE
  774.           IF fctno = OCT.pAND THEN op := OCC.AND
  775.           ELSIF fctno = OCT.pXOR THEN op := OCC.EOR
  776.           ELSE op := OCC.iOR
  777.           END;
  778.           IF par1.mode = Con THEN
  779.             IF par1.typ.form # par2.typ.form THEN par1.typ := par2.typ END;
  780.             OCI.Load (par2); OCC.PutF5 (op, par2.typ.size, par1, par2);
  781.             par1 := par2
  782.           ELSIF par2.mode = Con THEN
  783.             IF par2.typ.form # par1.typ.form THEN par2.typ := par1.typ END;
  784.             OCI.Load (par1); OCC.PutF5 (op, par1.typ.size, par2, par1)
  785.           ELSE
  786.             IF par1.typ.form = par2.typ.form THEN
  787.               OCI.Load (par1); IF op = OCC.EOR THEN OCI.Load (par2) END;
  788.               OCC.PutF5 (op, par1.typ.size, par2, par1); OCI.Unload (par2)
  789.             ELSE
  790.               OCS.Mark (100)
  791.             END
  792.           END
  793.         END
  794.       ELSE
  795.         OCS.Mark (111)
  796.       END
  797.     |
  798.     OCT.pBIT :
  799.       IF f IN intSet THEN
  800.         IF (par2.mode = Con) & (par2.a0 >= 8) THEN OCI.Load (par1)
  801.         ELSIF (par2.mode # Con) THEN OCI.Load (par1); OCI.Load (par2)
  802.         END;
  803.         OCC.Bit (OCC.BTST, par2, par1); OCI.Unload (par1); OCI.Unload (par2)
  804.       ELSE
  805.         OCS.Mark (111)
  806.       END;
  807.       OCE.setCC (par1, OCC.NE)
  808.     |
  809.     OCT.pGET, OCT.pGETREG :
  810.       IF par2.mode >= Con THEN OCS.Mark (112)
  811.       ELSIF ~(f IN realSet) THEN
  812.         IF par2.rdOnly THEN OCS.Mark (324) END;
  813.         OCC.Move (par2.typ.size, par1, par2)
  814.       ELSE OCS.Mark (111)
  815.       END;
  816.       par1.typ := OCT.notyp
  817.     |
  818.     OCT.pPUT, OCT.pPUTREG :
  819.       IF f IN putSet THEN OCC.Move (par2.typ.size, par2, par1) END;
  820.       par1.typ := OCT.notyp
  821.     |
  822.     OCT.pSYSNEW :
  823.       r0.mode := Reg; r0.a0 := D0;
  824.       IF par2.mode = Con THEN par2.typ := OCT.linttyp END;
  825.       OCC.Move (par2.typ.size, par2, r0);             (* MOVE.z <size>,D0 *)
  826.       r0.typ := par2.typ;
  827.       IF par2.typ.form # LInt THEN OCE.ConvertInts (r0, OCT.linttyp) END;
  828.       OCI.Unload (par2); OCC.ReserveReg (D0)
  829.     |
  830.     OCT.pVAL : par2.typ := par1.typ; par1 := par2
  831.     |
  832.     OCT.pCOPY :
  833.       IF
  834.         ((f = Array) OR (f = DynArr)) & (par2.typ.BaseTyp.form = Char)
  835.       THEN
  836.         IF par2.rdOnly THEN OCS.Mark (324) END;
  837.         IF f = Array THEN
  838.           x.mode := Con; x.a0 := par2.typ.n;
  839.           IF (par1.typ.form = String) & (par1.a1 < x.a0) THEN
  840.             x.a0 := par1.a1
  841.           ELSIF (par1.typ.form = Array) & (par1.typ.n < x.a0) THEN
  842.             x.a0 := par1.typ.n
  843.           END;
  844.           DEC (x.a0); OCE.SetIntType (x)
  845.         ELSE
  846.           IF (par1.typ.form = String) & (par1.a1 = 1) THEN
  847.             x.mode := Con; x.a0 := 0; x.typ := OCT.sinttyp
  848.           ELSE OCI.DescItem (x, par2.desc, par2.typ.adr)
  849.           END
  850.         END;
  851.         OCI.CopyString (par1, par2, x)
  852.       ELSE
  853.         OCS.Mark (111)
  854.       END;
  855.       par1.typ := OCT.notyp
  856.     |
  857.     OCT.pMOVE :
  858.       IF (f IN adrSet) THEN
  859.         OCC.ReserveReg (A1); r0.mode := Reg; r0.a0 := A1;
  860.         OCC.Move (L, par2, r0); OCI.Unload (par2)
  861.       ELSE
  862.         OCS.Mark (111)
  863.       END
  864.     |
  865.     OCT.pGETNAME :
  866.       IF
  867.         ((f = Array) OR (f = DynArr)) & (par2.typ.BaseTyp.form = Char)
  868.       THEN
  869.         IF par2.rdOnly THEN OCS.Mark (324) END;
  870.         IF f = Array THEN
  871.           x.mode := Con; x.a0 := par2.typ.n - 1; OCE.SetIntType (x)
  872.         ELSE
  873.           OCI.DescItem (x, par2.desc, par2.typ.adr)
  874.         END;
  875.         y := par1; OCC.GetAReg (par1);
  876.         OCC.Move (L, y, par1); OCI.Unload (y);
  877.         par1.mode := RegI; par1.a1 := 36;
  878.         OCC.PutF2 (OCC.LEA, par1, par1.a0);
  879.         par1.mode := Pop; par1.a1 := 0; OCC.GetDReg (y);
  880.         L0 := OCC.pc; OCC.Move (L, par1, y); OCC.FreeReg (y);
  881.         OCC.PutWord (06CFCH); par1.mode := RegI; par1.a1 := 0;
  882.         OCI.CopyString (par1, par2, x)
  883.       ELSE
  884.         OCS.Mark (111)
  885.       END;
  886.       par1.typ := OCT.notyp
  887.     |
  888.     OCT.pNEWTAG :
  889.       IF (f = TagTyp) & (par2.mode # Con) THEN
  890.         r0.mode := Reg; r0.a0 := D0; r1.mode := Reg; r1.a0 := D1;
  891.         x.mode := Lab; x.a0 := 0; x.a1 := 4; x.symbol := OCT.OberonSysNEW;
  892.         OCC.Move (L, par2, r1); OCI.Unload (par2);    (* MOVE.L <tag>,D1  *)
  893.         OCC.SaveRegisters (R, x, OCC.AllRegs);
  894.         OCC.PutF3 (OCC.JSR, x);                       (* JSR    NEW       *)
  895.         OCC.RestoreRegisters (R, x);
  896.         OCC.Move (L, r0, par1);                       (* MOVE.L D0,<var>  *)
  897.       ELSE
  898.         OCS.Mark (111)
  899.       END;
  900.       par1.typ := OCT.notyp
  901.     |
  902.   ELSE
  903.     OCS.Mark (1015); OCS.Mark (fctno)
  904.   END; (* CASE fctno *)
  905.   (* ;OCG.TraceOut (mname, pname); *)
  906. END StPar2;
  907.  
  908. (*------------------------------------*)
  909. PROCEDURE StPar3 * (VAR p, x : OCT.Item; fctno : INTEGER; VAR R : SET);
  910.  
  911.   (* CONST pname = "StPar3"; *)
  912.  
  913.   VAR f : INTEGER; r, sproc : OCT.Item;
  914.  
  915. BEGIN (* StPar3 *)
  916.   (* OCG.TraceIn (mname, pname); *)
  917.   f := x.typ.form;
  918.   IF fctno = OCT.pMOVE THEN
  919.     IF f IN intSet THEN
  920.       r.mode := Reg; r.a0 := D0;
  921.       IF x.mode = Con THEN x.typ := OCT.linttyp END;
  922.       OCC.Move (x.typ.size, x, r); r.typ := x.typ;
  923.       IF f # LInt THEN OCE.ConvertInts (r, OCT.linttyp) END;
  924.       OCI.Unload (x);
  925.       OCC.UnReserveReg (A0); OCC.UnReserveReg (A1);
  926.       sproc.mode := Lab; sproc.a0 := 0; sproc.a1 := 4;
  927.       sproc.symbol := OCT.OberonSysMOVE;
  928.       OCC.SaveRegisters (R, sproc, OCC.AllRegs);
  929.       OCC.PutF3 (OCC.JSR, sproc);
  930.       OCC.RestoreRegisters (R, sproc)
  931.     ELSE
  932.       OCS.Mark (111)
  933.     END;
  934.     p.typ := OCT.notyp
  935.   ELSIF fctno = OCT.pSYSNEW THEN
  936.     IF (f = Set) OR ((x.mode = Con) & (f IN setSet)) THEN
  937.       r.mode := Reg; r.a0 := D1; OCC.Move (L, x, r);  (* MOVE.L memReq,D1 *)
  938.       OCI.Unload (x);
  939.     ELSE
  940.       OCS.Mark (111)
  941.     END
  942.   ELSE
  943.     OCS.Mark (64)
  944.   END
  945.   (* ;OCG.TraceOut (mname, pname); *)
  946. END StPar3;
  947.  
  948. (*------------------------------------*)
  949. PROCEDURE StFct * (VAR p : OCT.Item; fctno, parno : INTEGER; VAR R : SET);
  950.  
  951.   (* CONST pname = "StFct"; *)
  952.  
  953.   VAR p2, r0, r1, x : OCT.Item; L0, f, f1 : INTEGER; btyp : OCT.Struct;
  954.  
  955. BEGIN (* StFct *)
  956.   (* OCG.TraceIn (mname, pname); *)
  957.   IF fctno >= OCT.TwoPar THEN
  958.     IF (fctno = OCT.pASSERT) & (parno = 1) THEN
  959.       IF p.mode # Coc THEN
  960.         OCC.PutF1 (OCC.TST, B, p);                    (*    TST.B <p>     *)
  961.         OCI.Unload (p); L0 := OCC.pc;
  962.         OCC.PutWord (OCC.BNE)                         (*    BNE.S 2$      *)
  963.       ELSE
  964.         OCC.PutWord (OCC.Bcc + (SHORT (p.a0) * 100H));
  965.         OCC.PutWord (SHORT (p.a1));                   (*    Bcc   2$      *)
  966.         L0 := OCC.pc - 2; OCC.FixLink (p.a2);
  967.       END;
  968.       p2.mode := Con; p2.a0 := 20; p2.typ := OCT.linttyp;
  969.       x.mode := Lab; x.a0 := OCT.returnCode; x.a1 := 4;
  970.       x.symbol := OCT.OberonSysVAR;
  971.       OCC.Move (L, p2, x);                            (* 1$ MOVEQ #20,D0  *)
  972.       x.mode := Lab; x.a0 := 0; x.a1 := 4;
  973.       x.symbol := OCT.OberonSysCLEANUP;
  974.       OCC.PutF3 (OCC.JMP, x);                         (*    JMP   CLEANUP *)
  975.       IF p.mode # Coc THEN                            (* 2$               *)
  976.         OCC.PatchWord (L0, OCC.pc - L0 - 2)
  977.       ELSE OCC.FixLink (L0)
  978.       END;
  979.       p.typ := OCT.notyp
  980.     ELSIF (fctno = OCT.pDEC) & (parno = 1) THEN
  981.       IF p.rdOnly THEN OCS.Mark (324) END;
  982.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  983.       OCC.PutF5 (OCC.SUB, p.typ.size, p2, p);
  984.       IF OCS.overflowCheck THEN OCC.PutWord (OCC.TRAPV) END;
  985.       p.typ := OCT.notyp
  986.     ELSIF (fctno = OCT.pINC) & (parno = 1) THEN
  987.       IF p.rdOnly THEN OCS.Mark (324) END;
  988.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  989.       OCC.PutF5 (OCC.ADD, p.typ.size, p2, p);
  990.       IF OCS.overflowCheck THEN OCC.PutWord (OCC.TRAPV) END;
  991.       p.typ := OCT.notyp
  992.     ELSIF (fctno = OCT.pLEN) & (parno = 1) THEN
  993.       IF p.typ.form = DynArr THEN OCI.DescItem (p, p.desc, p.typ.adr)
  994.       ELSE p.mode := Con; p.a0 := p.typ.n; p.typ := OCT.linttyp
  995.       END
  996.     ELSIF fctno = OCT.pINLINE THEN
  997.       p.typ := OCT.notyp
  998.     ELSIF fctno = OCT.pSYSNEW THEN
  999.       IF parno = 2 THEN (* Supply a memory req *)
  1000.         p2.mode := Con; p2.typ := OCT.settyp;
  1001.         IF OCS.zeroVars THEN p2.a0 := 10000H (* {memClear} *)
  1002.         ELSE p2.a0 := 0 (* {} *)
  1003.         END;
  1004.         r1.mode := Reg; r1.a0 := D1;
  1005.         OCC.Move (L, p2, r1);                         (* MOVE.L memReq,D1 *)
  1006.       END;
  1007.       IF p.typ.form IN {Pointer, PtrTyp} THEN
  1008.         OCC.PutWord (50C2H)                           (* ST     D2        *)
  1009.       ELSE
  1010.         OCC.PutWord (51C2H)                           (* SF     D2        *)
  1011.       END;
  1012.       OCC.UnReserveReg (D0);
  1013.       x.mode := Lab; x.a0 := 0; x.a1 := 4; x.symbol := OCT.OberonSysSYSNEW;
  1014.       OCC.SaveRegisters (R, x, OCC.AllRegs);
  1015.       OCC.PutF3 (OCC.JSR, x);                         (* JSR    SYSNEW    *)
  1016.       IF p.typ.form = BPointer THEN
  1017.         OCC.PutWord (-1B80H)                          (* ASR.L  #2,D0     *)
  1018.       END;
  1019.       OCC.RestoreRegisters (R, x);
  1020.       r0.mode := Reg; r0.a0 := D0;
  1021.       OCC.Move (L, r0, p);                            (* MOVE.L D0,<var>  *)
  1022.       p.typ := OCT.notyp
  1023.     ELSIF (parno < 2) OR (fctno = OCT.pMOVE) & (parno < 3) THEN
  1024.       OCS.Mark (65)
  1025.     END
  1026.   ELSIF (fctno = OCT.pNEW) & (parno >= 1) THEN
  1027.     f := p.typ.form;
  1028.     IF f IN {Pointer, CPointer, BPointer} THEN
  1029.       f1 := f; btyp := p.typ.BaseTyp; f := btyp.form;
  1030.       r0.mode := Reg; r0.a0 := D0; x.mode := Lab; x.a0 := 0; x.a1 := 4;
  1031.       IF (f1 = Pointer) & NeedsTag (btyp) THEN
  1032.         IF f = Record THEN
  1033.           IF parno > 1 THEN OCS.Mark (64) END;
  1034.           OCC.PutWord (223CH);
  1035.           OCC.PutLongRef (0, btyp.symbol)             (* MOVE.L #tag,D1   *)
  1036.         ELSIF f = Array THEN
  1037.           IF parno > 1 THEN OCS.Mark (64) END;
  1038.           WHILE btyp.form = Array DO btyp := btyp.BaseTyp END;
  1039.           OCC.PutWord (223CH);                        (* MOVE.L #tag+2,D1 *)
  1040.           OCC.PutLongRef (2, btyp.symbol);
  1041.         ELSIF f = DynArr THEN
  1042.           WHILE btyp.form = DynArr DO btyp := btyp.BaseTyp; DEC (parno) END;
  1043.           WHILE btyp.form = Array DO btyp := btyp.BaseTyp END;
  1044.           IF parno > 1 THEN OCS.Mark (64)
  1045.           ELSIF parno < 1 THEN OCS.Mark (65)
  1046.           END;
  1047.           OCC.PutWord (223CH);                        (* MOVE.L #tag+2,D1 *)
  1048.           OCC.PutLongRef (2, btyp.symbol)
  1049.         END;
  1050.         x.symbol := OCT.OberonSysNEW
  1051.       ELSE
  1052.         p2.mode := Con; p2.typ := OCT.settyp;
  1053.         IF OCS.zeroVars THEN p2.a0 := 10000H (* {memClear} *)
  1054.         ELSE p2.a0 := 0 (* {} *)
  1055.         END;
  1056.         r1.mode := Reg; r1.a0 := D1;
  1057.         OCC.Move (L, p2, r1);                         (* MOVE.L memReq,D1 *)
  1058.         IF f1 = Pointer THEN
  1059.           IF f = DynArr THEN
  1060.             WHILE btyp.form = DynArr DO
  1061.               btyp := btyp.BaseTyp; DEC (parno)
  1062.             END;
  1063.             IF parno > 1 THEN OCS.Mark (64)
  1064.             ELSIF parno < 1 THEN OCS.Mark (65)
  1065.             END
  1066.           END;
  1067.           OCC.PutWord (50C2H)                         (* ST     D2        *)
  1068.         ELSE OCC.PutWord (51C2H)                      (* SF     D2        *)
  1069.         END;
  1070.         x.symbol := OCT.OberonSysSYSNEW
  1071.       END;
  1072.       OCC.SaveRegisters (R, x, OCC.AllRegs);
  1073.       OCC.PutF3 (OCC.JSR, x);                         (* JSR    (SYS)NEW  *)
  1074.       IF f1 = BPointer THEN
  1075.         OCC.PutWord (-1B80H)                          (* ASR.L  #2,D0     *)
  1076.       END;
  1077.       OCC.RestoreRegisters (R, x);
  1078.       OCC.Move (L, r0, p);                            (* MOVE.L D0,<var>  *)
  1079.     END;
  1080.     p.typ := OCT.notyp
  1081.   ELSIF fctno = OCT.pGC THEN
  1082.     p2.mode := Lab; p2.a0 := 0; p2.a1 := 4;
  1083.     p2.symbol := OCT.OberonSysGC;
  1084.     OCC.PutF3 (OCC.JSR, p2)
  1085.   ELSIF fctno = OCT.pRC THEN
  1086.     p.mode := Lab; p.a0 := OCT.returnCode; p.a1 := 4;
  1087.     p.symbol := OCT.OberonSysVAR; p.typ := OCT.linttyp
  1088.   ELSIF parno < 1 THEN
  1089.     OCS.Mark (65)
  1090.   END
  1091.   (* ;OCG.TraceOut (mname, pname); *)
  1092. END StFct;
  1093.  
  1094. (*------------------------------------*)
  1095. PROCEDURE Inline * (VAR x : OCT.Item);
  1096.  
  1097.   (* CONST pname = "Inline"; *)
  1098.  
  1099.   VAR f : INTEGER;
  1100.  
  1101. BEGIN (* Inline *)
  1102.   (* OCG.TraceIn (mname, pname); *)
  1103.   f := x.typ.form;
  1104.   IF (f IN intSet) & (x.mode = Con) THEN
  1105.     IF f = LInt THEN OCC.PutLong (x.a0)
  1106.     ELSE OCC.PutWord (SHORT (x.a0))
  1107.     END
  1108.   ELSE
  1109.     OCS.Mark (17)
  1110.   END
  1111.   (* ;OCG.TraceOut (mname, pname); *)
  1112. END Inline;
  1113.  
  1114. (*------------------------------------*)
  1115. PROCEDURE NewPar * (VAR x, p : OCT.Item; n : INTEGER);
  1116.  
  1117.   (* CONST pname = "NewPar"; *)
  1118.  
  1119.   VAR f, i : INTEGER; btyp : OCT.Struct; desc, r0, y : OCT.Item;
  1120.       calcSize : BOOLEAN;
  1121.  
  1122. BEGIN (* NewPar *)
  1123.   (* OCG.TraceIn (mname, pname); *)
  1124.   IF p.typ.form IN intSet THEN
  1125.     f := x.typ.form;
  1126.     IF f = Pointer THEN
  1127.       btyp := x.typ; i := 0;
  1128.       WHILE (btyp.BaseTyp # NIL) & (i < n) DO
  1129.         btyp := btyp.BaseTyp; INC (i)
  1130.       END;
  1131.       f := btyp.form;
  1132.       IF f = DynArr THEN
  1133.         IF p.typ.form # LInt THEN OCE.ConvertInts (p, OCT.linttyp) END;
  1134.         OCI.DescItem (desc, x.desc, btyp.adr);
  1135.         OCC.Move (L, p, desc);
  1136.         (*OCI.UpdateDesc (x, btyp.adr);*)
  1137.         btyp := btyp.BaseTyp; f := btyp.form;
  1138.         r0.mode := Reg; r0.a0 := D0; r0.typ := OCT.linttyp;
  1139.         IF p.mode = Con THEN
  1140.           IF f # DynArr THEN p.a0 := p.a0 * btyp.size END;
  1141.           calcSize := FALSE
  1142.         ELSE
  1143.           calcSize := TRUE
  1144.         END;
  1145.         IF n = 1 THEN OCC.Move (L, p, r0); OCI.Unload (p)
  1146.         ELSE OCE.Op (OCS.times, r0, p, TRUE)
  1147.         END;
  1148.         IF calcSize & (f # DynArr) & (btyp.size > 1) THEN
  1149.           y.mode := Con; y.a0 := btyp.size; y.typ := OCT.linttyp;
  1150.           OCE.Op (OCS.times, r0, y, TRUE)
  1151.         END
  1152.       ELSE OCS.Mark (64)
  1153.       END
  1154.     END
  1155.   ELSE OCS.Mark (328)
  1156.   END
  1157.   (* ;OCG.TraceOut (mname, pname); *)
  1158. END NewPar;
  1159.  
  1160. END OCP.
  1161.  
  1162. (***************************************************************************
  1163.  
  1164.   $Log: OCP.mod $
  1165.   Revision 4.9  1994/08/03  11:44:38  fjc
  1166.   - Changed error codes.
  1167.   - Changed bit operations (LSH, AND, etc.) to work with
  1168.     more types.
  1169.  
  1170.   Revision 4.8  1994/07/26  18:35:51  fjc
  1171.   *** empty log message ***
  1172.  
  1173.   Revision 4.7  1994/07/23  16:02:09  fjc
  1174.   - Implemented NIL checking.
  1175.   - Changed to use new OCC.SaveRegisters() format.
  1176.  
  1177.   Revision 4.6  1994/07/22  14:10:28  fjc
  1178.   - Fixed code generated for ASSERT.
  1179.  
  1180.   Revision 4.5  1994/07/10  13:20:48  fjc
  1181.   - Commented out trace code.
  1182.   - Implemented RC.
  1183.   - Re-implemented SETCLEANUP to call OberonSys_SETCLEANUP.
  1184.   - Added optional memreqs parameter to SYSNEW.
  1185.  
  1186.   Revision 4.4  1994/07/03  14:46:46  fjc
  1187.   - Fixed bug in checking parameters for GETNAME.
  1188.  
  1189.   Revision 4.3  1994/06/17  17:57:56  fjc
  1190.   - Implemented TypTag:
  1191.     - SYSTEM procedures TAG, GETNAME, SIZETAG, NEWTAG
  1192.   - Implemented SETREG and REG.
  1193.  
  1194.   Revision 4.2  1994/06/05  22:49:24  fjc
  1195.   - Changed to use new symbol table format.
  1196.   - Removed references to defunct standard procedures.
  1197.  
  1198.   Revision 4.1  1994/06/01  09:33:44  fjc
  1199.   - Bumped version number
  1200.  
  1201. ***************************************************************************)
  1202.  
  1203.