home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 2 / goldfish_vol2_cd1.bin / files / dev / obero / oberon-a / source / oc / compiler.mod < prev    next >
Text File  |  1994-08-19  |  62KB  |  2,046 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: Compiler.mod $
  4.   Description: Recursive-descent parser
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 4.12 $
  8.       $Author: fjc $
  9.         $Date: 1994/08/19 20:02:03 $
  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 Compiler;
  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
  29.   Str := Strings, IO := StdIO, Oberon, Files, OCG, OCS, OCT, OCC, OCI,
  30.   OCE, OCP, OCH, SYS := SYSTEM;
  31.  
  32.  
  33. (* --- Exported declarations -------------------------------------------- *)
  34.  
  35.  
  36. VAR
  37.   newSF * : BOOLEAN;
  38.   forceCode * : BOOLEAN;
  39.  
  40.  
  41. (* --- Local declarations ----------------------------------------------- *)
  42.  
  43.  
  44. CONST
  45.  
  46.   NofCases = 128; RecDescSize = 8; AdrSize = OCG.PtrSize;
  47.   ProcSize = OCG.ProcSize; PtrSize = OCG.PtrSize; ParOrg = 2 * AdrSize;
  48.   LParOrg = 3 * AdrSize; XParOrg = 3 * AdrSize; ProcVarSize = 32768;
  49.  
  50.   ModNameLen = 26; (* Max. module name length, imposed by AmigaDOS *)
  51.  
  52. (* Symbols *)
  53.  
  54.   null    = OCS.null;    times  = OCS.times;  slash     = OCS.slash;
  55.   div     = OCS.div;     mod    = OCS.mod;    and       = OCS.and;
  56.   plus    = OCS.plus;    minus  = OCS.minus;  or        = OCS.or;
  57.   eql     = OCS.eql;     neq    = OCS.neq;    lss       = OCS.lss;
  58.   leq     = OCS.leq;     gtr    = OCS.gtr;    geq       = OCS.geq;
  59.   in      = OCS.in;      is     = OCS.is;     arrow     = OCS.arrow;
  60.   period  = OCS.period;  comma  = OCS.comma;  colon     = OCS.colon;
  61.   upto    = OCS.upto;    rparen = OCS.rparen; rbrak     = OCS.rbrak;
  62.   rbrace  = OCS.rbrace;  of     = OCS.of;     then      = OCS.then;
  63.   do      = OCS.do;      to     = OCS.to;     lparen    = OCS.lparen;
  64.   lbrak   = OCS.lbrak;   lbrace = OCS.lbrace; not       = OCS.not;
  65.   becomes = OCS.becomes; number = OCS.number; nil       = OCS.nil;
  66.   string  = OCS.string;  ident  = OCS.ident;  semicolon = OCS.semicolon;
  67.   bar     = OCS.bar;     end    = OCS.end;    else      = OCS.else;
  68.   elsif   = OCS.elsif;   until  = OCS.until;  if        = OCS.if;
  69.   case    = OCS.case;    while  = OCS.while;  repeat    = OCS.repeat;
  70.   loop    = OCS.loop;    with   = OCS.with;   exit      = OCS.exit;
  71.   return  = OCS.return;  array  = OCS.array;  record    = OCS.record;
  72.   pointer = OCS.pointer; begin  = OCS.begin;  const     = OCS.const;
  73.   type    = OCS.type;    var    = OCS.var;    procedure = OCS.procedure;
  74.   import  = OCS.import;  module = OCS.module; eof       = OCS.eof;
  75.   cpointer = OCS.cpointer; bpointer = OCS.bpointer; libcall = OCS.libcall;
  76.   for = OCS.for; by = OCS.by;
  77.  
  78. (* object modes *)
  79.   Var = OCG.Var; VarR = OCG.VarR; Ind = OCG.Ind; IndR = OCG.IndR;
  80.   Con = OCG.Con; Reg = OCG.Reg; Fld = OCG.Fld; Typ = OCG.Typ;
  81.   LProc = OCG.LProc; XProc = OCG.XProc; SProc = OCG.SProc;
  82.   TProc = OCG.TProc; FProc = OCG.FProc; Mod = OCG.Mod; Abs = OCG.Abs;
  83.   VarArg = OCG.VarArg;
  84.  
  85. (* object modes for language extensions *)
  86.   LibCall = OCG.LibCall;
  87.  
  88. (* structure forms *)
  89.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  90.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  91.   LReal = OCT.LReal; BSet = OCT.BSet; WSet = OCT.WSet; Set = OCT.Set;
  92.   String = OCT.String; NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp;
  93.   PtrTyp = OCT.PtrTyp; CPtrTyp = OCT.CPtrTyp; BPtrTyp = OCT.BPtrTyp;
  94.   Pointer = OCT.Pointer; CPointer = OCT.CPointer; BPointer = OCT.BPointer;
  95.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  96.   Record = OCT.Record;
  97.  
  98.   intSet    = {SInt, Int, LInt};
  99.   ptrSet    = {Pointer, CPointer, BPointer};
  100.   uptrSet   = {CPointer, BPointer};
  101.   labeltyps = {Char, SInt, Int, LInt};
  102.  
  103.   NumLoopLevels = 16; MaxLoopLevel = NumLoopLevels - 1;
  104.  
  105. VAR
  106.  
  107.   sym, procNo : INTEGER;
  108.   LoopLevel, ExitNo : INTEGER;
  109.   LoopExit : ARRAY NumLoopLevels OF INTEGER;
  110.  
  111. (* CONST mname = "Compiler"; *)
  112.  
  113. (* --- Procedure declarations ------------------------------------------- *)
  114.  
  115.  
  116. (*----------------------------------)-*)
  117. PROCEDURE^ Type (VAR typ : OCT.Struct);
  118. PROCEDURE^ Expression (VAR x : OCT.Item);
  119. PROCEDURE^ Block
  120.   (proc : OCT.Object; VAR dsize : LONGINT; VAR retList : INTEGER);
  121.  
  122. (*------------------------------------*)
  123. PROCEDURE CheckSym (s : INTEGER);
  124.  
  125. BEGIN (* CheckSym *)
  126.   IF sym = s THEN OCS.Get (sym) ELSE OCS.Mark (s) END
  127. END CheckSym;
  128.  
  129. (*------------------------------------*)
  130. PROCEDURE qualident (VAR x : OCT.Item; allocDesc : BOOLEAN);
  131.  
  132.   (* CONST pname = "qualident"; *)
  133.  
  134.   VAR mnolev : INTEGER; obj : OCT.Object; desc : OCT.Desc; b : BOOLEAN;
  135.  
  136. BEGIN (* qualident *)
  137.   (* OCG.TraceIn (mname, pname); *)
  138.   (* sym = ident *)
  139.   OCT.Find (obj, mnolev); IF obj = NIL THEN OCS.Mark (0) END; OCS.Get (sym);
  140.   IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  141.     OCS.Get (sym); mnolev := SHORT (-obj.a0);
  142.     IF sym = ident THEN
  143.       OCT.FindImport (obj, obj); IF obj = NIL THEN OCS.Mark (0) END;
  144.       OCS.Get (sym)
  145.     ELSE
  146.       OCS.Mark (10); obj := NIL
  147.     END;
  148.   END;
  149.   x.lev := mnolev; x.obj := obj;
  150.   IF obj # NIL THEN
  151.     x.mode := obj.mode; x.typ := obj.typ; x.a0 := obj.a0;
  152.     x.a1 := obj.a1; x.a2 := obj.a2; x.symbol := obj.symbol;
  153.     x.rdOnly := (mnolev < 0) & (obj.visible = OCT.RdOnly);
  154.     (*
  155.     IF mnolev < 0 THEN
  156.       b := (obj.visible = OCT.RdOnly); x.rdOnly := b
  157.     ELSE x.rdOnly := FALSE
  158.     END;
  159.     *)
  160.     IF
  161.       allocDesc & (x.mode IN {Var, Ind}) & (x.typ # NIL)
  162.       & (x.typ.form = DynArr)
  163.     THEN
  164.       desc := OCT.AllocDesc (); desc.mode := Var; desc.lev := x.lev;
  165.       desc.a0 := x.a0; desc.a1 := 0; desc.a2 := 0; x.desc := desc
  166.     ELSE
  167.       x.desc := NIL
  168.     END
  169.   ELSE
  170.     x.mode := Var; x.typ := OCT.undftyp; x.a0 := 0; x.obj := NIL;
  171.     x.rdOnly := FALSE; x.desc := NIL
  172.   END
  173.   (* ;OCG.TraceOut (mname, pname); *)
  174. END qualident;
  175.  
  176. (*------------------------------------*)
  177. PROCEDURE ConstExpression (VAR x : OCT.Item);
  178.  
  179.   (* CONST pname = "ConstExpression"; *)
  180.  
  181.   CONST
  182.     ConstTypes = {Undef .. NilTyp, CPtrTyp, BPtrTyp, CPointer, BPointer};
  183.  
  184. BEGIN (* ConstExpression *)
  185.   (* OCG.TraceIn (mname, pname); *)
  186.   Expression (x);
  187.   IF (x.mode # Con) OR ~(x.typ.form IN ConstTypes) THEN
  188.     OCS.Mark (50); x.mode := Con; x.typ := OCT.inttyp; x.a0 := 1;
  189.   END;
  190.   (* ;OCG.TraceOut (mname, pname); *)
  191. END ConstExpression;
  192.  
  193. (*------------------------------------*)
  194. PROCEDURE NewStr (form : INTEGER) : OCT.Struct;
  195.  
  196.   (* CONST pname = "NewStr"; *)
  197.  
  198.   VAR typ : OCT.Struct;
  199.  
  200. BEGIN (* NewStr *)
  201.   (* OCG.TraceIn (mname, pname); *)
  202.   typ := OCT.AllocStruct ();
  203.   typ.form := form; typ.mno := 0; typ.size := 4; typ.ref := 0;
  204.   typ.BaseTyp := OCT.undftyp; typ.strobj := NIL; typ.link := NIL;
  205.   (* ;OCG.TraceOut (mname, pname); *)
  206.   RETURN typ
  207. END NewStr;
  208.  
  209. (*------------------------------------*)
  210. PROCEDURE CheckMark (VAR mk : SHORTINT; readOnly : BOOLEAN);
  211.  
  212.   (* CONST pname = "CheckMark"; *)
  213.  
  214. BEGIN (* CheckMark *)
  215.   (* OCG.TraceIn (mname, pname); *)
  216.   OCS.Get (sym);
  217.   IF sym = times THEN
  218.     IF OCC.level = 0 THEN mk := OCT.Exp
  219.     ELSE mk := OCT.NotExp; OCS.Mark (46)
  220.     END;
  221.     OCS.Get (sym)
  222.   ELSIF sym = minus THEN
  223.     IF (OCC.level = 0) & readOnly THEN mk := OCT.RdOnly
  224.     ELSE mk := OCT.NotExp; OCS.Mark (47)
  225.     END;
  226.     OCS.Get (sym)
  227.   ELSE
  228.     mk := OCT.NotExp
  229.   END
  230.   (* ;OCG.TraceOut (mname, pname); *)
  231. END CheckMark;
  232.  
  233. (*------------------------------------*)
  234. PROCEDURE CheckUndefPointerTypes ();
  235.  
  236.   (* CONST pname = "CheckUndefPointerTypes"; *)
  237.  
  238.   (*------------------------------------*)
  239.   PROCEDURE CheckObj (obj : OCT.Object);
  240.  
  241.   BEGIN (* CheckObj *)
  242.     IF obj # NIL THEN
  243.       IF obj.mode = Undef THEN OCS.Mark (48) END;
  244.       CheckObj (obj.left); CheckObj (obj.right)
  245.     END
  246.   END CheckObj;
  247.  
  248. BEGIN (* CheckUndefPointerTypes *)
  249.   (* OCG.TraceIn (mname, pname); *)
  250.   CheckObj (OCT.topScope.link)
  251.   (* ;OCG.TraceOut (mname, pname); *)
  252. END CheckUndefPointerTypes;
  253.  
  254. (*------------------------------------*)
  255. PROCEDURE CheckForwardProcs ();
  256.  
  257.   (* CONST pname = "CheckForwardProcs"; *)
  258.  
  259.   (*------------------------------------*)
  260.   PROCEDURE CheckObj ( obj : OCT.Object );
  261.  
  262.     (*------------------------------------*)
  263.     PROCEDURE CheckTyp ( typ : OCT.Struct );
  264.       VAR fld : OCT.Object;
  265.     BEGIN (* CheckTyp *)
  266.       IF (typ # NIL) & (typ.form = Record) THEN
  267.         fld := typ.link;
  268.         WHILE fld # NIL DO
  269.           IF (fld.mode = TProc) & (fld.a2 < 0) THEN OCS.Mark (129) END;
  270.           fld := fld.left
  271.         END
  272.       END
  273.     END CheckTyp;
  274.  
  275.   BEGIN (* CheckObj *)
  276.     IF obj # NIL THEN
  277.       IF obj.mode IN {XProc, LProc} THEN
  278.         IF obj.a2 < 0 THEN OCS.Mark (129) END
  279.       ELSIF obj.mode = Typ THEN
  280.         CheckTyp (obj.typ)
  281.       END;
  282.       CheckObj (obj.left); CheckObj (obj.right)
  283.     END
  284.   END CheckObj;
  285.  
  286. BEGIN (* CheckForwardProcs *)
  287.   (* OCG.TraceIn (mname, pname); *)
  288.   CheckObj (OCT.topScope.link)
  289.   (* ;OCG.TraceOut (mname, pname); *)
  290. END CheckForwardProcs;
  291.  
  292. (*------------------------------------*)
  293. PROCEDURE RecordType (VAR typ : OCT.Struct);
  294.  
  295.   (* CONST pname = "RecordType"; *)
  296.  
  297.   VAR
  298.     adr, size : LONGINT;
  299.     fld, fld0, fld1, fld2 : OCT.Object;
  300.     ftyp : OCT.Struct;
  301.     base : OCT.Item;
  302.  
  303. BEGIN (* RecordType *)
  304.   (* OCG.TraceIn (mname, pname); *)
  305.   typ := NewStr (Record); typ.BaseTyp := NIL; typ.n := 0; adr := 0;
  306.   IF sym = lparen THEN
  307.     OCS.Get (sym); (* record extension *)
  308.     IF sym = ident THEN
  309.       qualident (base, FALSE);
  310.       IF (base.mode = Typ) & (base.typ.form = Record) THEN
  311.         typ.BaseTyp := base.typ; typ.n := base.typ.n + 1;
  312.         adr := base.typ.size
  313.       ELSE
  314.         OCS.Mark (52)
  315.       END;
  316.     ELSE
  317.       OCS.Mark (10)
  318.     END;
  319.     CheckSym (rparen)
  320.   END;
  321.   OCT.OpenScope (0); fld := NIL; fld1 := OCT.AllocObj(); fld2 := NIL;
  322.   LOOP
  323.     (* OCG.TraceIn (mname, "LOOP1"); *)
  324.     IF sym = ident THEN
  325.       LOOP
  326.         (* OCG.TraceIn (mname, "LOOP2"); *)
  327.         IF sym = ident THEN
  328.           IF typ.BaseTyp # NIL THEN
  329.             OCT.FindField (typ.BaseTyp, fld0);
  330.             IF fld0 # NIL THEN OCS.Mark (1) END
  331.           END;
  332.           OCT.Insert (OCS.name, fld, Fld); CheckMark (fld.visible, TRUE);
  333.           IF (fld # fld2) & (fld.link = NIL) THEN
  334.             IF fld2 = NIL THEN fld1.link := fld; OCT.topScope.right := fld
  335.             ELSE fld2.link := fld
  336.             END;
  337.             fld2 := fld
  338.           END;
  339.         ELSE
  340.           OCS.Mark (10)
  341.         END;
  342.         IF sym = comma THEN
  343.           OCS.Get (sym)
  344.         ELSIF sym = ident THEN
  345.           OCS.Mark (19)
  346.         ELSE
  347.           (* ;OCG.TraceOut (mname, "LOOP2"); *)
  348.           EXIT
  349.         END;
  350.         (* ;OCG.TraceOut (mname, "LOOP2"); *)
  351.       END; (* LOOP *)
  352.       CheckSym (colon); Type (ftyp);
  353.       IF ftyp.form = DynArr THEN ftyp := OCT.undftyp; OCS.Mark (325) END;
  354.       size := ftyp.size;
  355.       IF size > 1 THEN
  356.         INC (adr, adr MOD 2); INC (size, size MOD 2) (* word align *)
  357.       END;
  358.       WHILE fld1.link # NIL DO
  359.         (* OCG.TraceIn (mname, "WHILE1"); *)
  360.         fld1 := fld1.link; fld1.typ := ftyp;
  361.         fld1.a0 := adr; INC (adr, size)
  362.         (* ;OCG.TraceOut (mname, "WHILE1"); *)
  363.       END;
  364.     END; (* IF *)
  365.     IF sym = semicolon THEN
  366.       OCS.Get (sym)
  367.     ELSIF sym = ident THEN
  368.       OCS.Mark (38)
  369.     ELSE
  370.       (* ;OCG.TraceOut (mname, "LOOP1"); *)
  371.       EXIT
  372.     END;
  373.     (* ;OCG.TraceOut (mname, "LOOP1"); *)
  374.   END; (* LOOP *)
  375.   typ.size := adr + (adr MOD 2); typ.link := OCT.topScope.right;
  376.   CheckUndefPointerTypes ();
  377.   fld0 := OCT.topScope.right;
  378.   WHILE fld0 # NIL DO
  379.     (* OCG.TraceIn (mname, "WHILE2"); *)
  380.     fld1 := fld0.link; fld0.link := NIL;
  381.     fld0.left := fld1; fld0.right := NIL;
  382.     fld0 := fld1
  383.     (* ;OCG.TraceOut (mname, "WHILE2"); *)
  384.   END;
  385.   OCT.CloseScope ();
  386.   (* ;OCG.TraceOut (mname, pname); *)
  387. END RecordType;
  388.  
  389. (*------------------------------------*)
  390. PROCEDURE ArrayType (VAR typ : OCT.Struct);
  391.  
  392.   (* CONST pname = "ArrayType"; *)
  393.  
  394.   VAR x : OCT.Item; f, n : INTEGER;
  395.  
  396. BEGIN (* ArrayType *)
  397.   (* OCG.TraceIn (mname, pname); *)
  398.   IF sym # of THEN
  399.     typ := NewStr (Array); ConstExpression (x); f := x.typ.form;
  400.     IF f IN intSet THEN
  401.       IF (x.a0 > 0) & (x.a0 <= MAX (INTEGER)) THEN n := SHORT (x.a0)
  402.       ELSE n := 1; OCS.Mark (68)
  403.       END
  404.     ELSE
  405.       OCS.Mark (51); n := 1
  406.     END;
  407.     typ.n := n;
  408.     IF sym = of THEN OCS.Get (sym); Type (typ.BaseTyp)
  409.     ELSIF sym = comma THEN OCS.Get (sym); ArrayType (typ.BaseTyp)
  410.     ELSE OCS.Mark (34)
  411.     END;
  412.     IF typ.BaseTyp.form = DynArr THEN
  413.       typ.BaseTyp := OCT.undftyp; OCS.Mark (325)
  414.     END;
  415.     typ.size := n * typ.BaseTyp.size;
  416.     INC (typ.size, typ.size MOD 2); (* keep word alignment *)
  417.   ELSE
  418.     typ := NewStr (DynArr); OCS.Get (sym); Type (typ.BaseTyp);
  419.     IF typ.BaseTyp.form = DynArr THEN
  420.       typ.size := typ.BaseTyp.size + 4; typ.adr := typ.BaseTyp.adr + 4
  421.     ELSE
  422.       typ.size := 8; typ.adr := 4
  423.     END
  424.   END
  425.   (* ;OCG.TraceOut (mname, pname); *)
  426. END ArrayType;
  427.  
  428. (*------------------------------------*)
  429. (*
  430.   $  FormalParameters  =  "(" [FPSection {";" FPSection}] ")"
  431.   $    [":" qualident].
  432.   $  FPSection  =  [VAR] ident [RegSpec] {"," ident [RegSpec]}
  433.   $    ":" Type.
  434.   $  RegSpec = "{" ConstExpression "}" [".."].
  435. *)
  436. PROCEDURE FormalParameters (
  437.   VAR resTyp : OCT.Struct; VAR psize : LONGINT; regPars : BOOLEAN);
  438.  
  439.   (* CONST pname = "FormalParameters"; *)
  440.   CONST
  441.     D0 = 0; A5 = 13;
  442.  
  443.   VAR
  444.     mode : SHORTINT; gotUpto : BOOLEAN;
  445.     adr, size : LONGINT; res, reg : OCT.Item;
  446.     par, par1, par2: OCT.Object; typ : OCT.Struct;
  447.  
  448. BEGIN (* FormalParameters *)
  449.   (* OCG.TraceIn (mname, pname); *)
  450.   adr := 0; gotUpto := FALSE;
  451.   (* Make allowance for the receiver of type-bound and libcall procedures *)
  452.   IF OCT.topScope.right # NIL THEN
  453.     par1 := OCT.topScope.right; adr := par1.a0
  454.   ELSE
  455.     par1 := OCT.AllocObj()
  456.   END;
  457.   par2 := par1;
  458.   IF (sym = ident) OR (sym = var) THEN
  459.     LOOP
  460.       IF sym = var THEN
  461.         OCS.Get (sym); IF regPars THEN mode := IndR ELSE mode := Ind END
  462.       ELSIF regPars THEN mode := VarR
  463.       ELSE mode := Var
  464.       END;
  465.       LOOP
  466.         IF sym = ident THEN
  467.           OCT.Insert (OCS.name, par, mode); OCS.Get (sym);
  468.           IF OCT.topScope.right = NIL THEN OCT.topScope.right := par END;
  469.           IF (par # par2) & (par.link = NIL) THEN
  470.             par2.link := par;
  471.             IF par1.link = NIL THEN par1.link := par END;
  472.           END;
  473.           par2 := par
  474.         ELSE OCS.Mark (10)
  475.         END;
  476.  
  477.         IF sym = lbrak THEN (* Register specification *)
  478.           OCS.Get (sym); ConstExpression (reg);
  479.           IF reg.typ.form IN intSet THEN
  480.             IF (reg.a0 >= D0) & (reg.a0 <= A5) THEN par.a0 := reg.a0;
  481.             ELSE OCS.Mark (903)
  482.             END
  483.           ELSE OCS.Mark (902)
  484.           END;
  485.           CheckSym (rbrak);
  486.           IF ~regPars THEN OCS.Mark (901); par.mode := Var; par.a0 := 0 END
  487.         ELSIF regPars THEN OCS.Mark (340)
  488.         END;
  489.  
  490.         IF sym = upto THEN
  491.           IF mode = VarR THEN par.mode := VarArg ELSE OCS.Mark (336) END;
  492.           gotUpto := TRUE; OCS.Get (sym)
  493.         END;
  494.  
  495.         IF sym = comma THEN OCS.Get (sym)
  496.         ELSIF sym = ident THEN OCS.Mark (19)
  497.         ELSIF sym = var THEN OCS.Mark (19); OCS.Get (sym)
  498.         ELSE EXIT
  499.         END;
  500.       END; (* LOOP *)
  501.       CheckSym (colon); Type (typ);
  502.     (*IF (mode = VarArg) & (typ.size > PtrSize) THEN OCS.Mark (338) END;*)
  503.  
  504.       IF ~regPars THEN
  505.         IF mode = Ind  THEN (* VAR param *)
  506.           IF typ.form = Record THEN size := RecDescSize
  507.           ELSIF typ.form = DynArr THEN size := typ.size
  508.           ELSE size := AdrSize
  509.           END
  510.         ELSE
  511.           size := typ.size; IF ODD (size) THEN INC (size) END;
  512.         END;
  513.         WHILE par1.link # NIL DO
  514.           par1 := par1.link; par1.typ := typ;
  515.           DEC (adr, size); par1.a0 := adr
  516.         END;
  517.       ELSE
  518.         WHILE par1.link # NIL DO par1 := par1.link; par1.typ := typ END
  519.       END;
  520.       IF sym = semicolon THEN OCS.Get (sym)
  521.       ELSIF sym = ident THEN OCS.Mark (38)
  522.       ELSE EXIT
  523.       END;
  524.       IF gotUpto THEN OCS.Mark (337) END
  525.     END; (* LOOP *)
  526.   END; (* IF *)
  527.  
  528.   IF ~regPars THEN
  529.     psize := psize - adr;
  530.     IF psize > OCG.ParLimit THEN OCS.Mark (209); psize := 0 END;
  531.     par := OCT.topScope.right;
  532.     WHILE par # NIL DO INC (par.a0, psize); par := par.link END;
  533.   END;
  534.  
  535.   CheckSym (rparen);
  536.   IF sym = colon THEN
  537.     OCS.Get (sym); resTyp := OCT.undftyp;
  538.     IF sym = ident THEN
  539.       qualident (res, FALSE);
  540.       IF res.mode = Typ THEN
  541.         IF res.typ.form <= ProcTyp THEN
  542.           resTyp := res.typ
  543.         ELSE
  544.           OCS.Mark (54)
  545.         END
  546.       ELSE
  547.         OCS.Mark (52)
  548.       END
  549.     ELSE
  550.       OCS.Mark (10)
  551.     END;
  552.   ELSE
  553.     resTyp := OCT.notyp
  554.   END;
  555.   (* ;OCG.TraceOut (mname, pname); *)
  556. END FormalParameters;
  557.  
  558. (*------------------------------------*)
  559. PROCEDURE ProcType (VAR typ : OCT.Struct);
  560.  
  561.   (* CONST pname = "ProcType"; *)
  562.  
  563.   VAR psize : LONGINT;
  564.  
  565. BEGIN (* ProcType *)
  566.   (* OCG.TraceIn (mname, pname); *)
  567.   typ := NewStr (ProcTyp); typ.size := ProcSize;
  568.   IF sym = lparen THEN
  569.     OCS.Get (sym); OCT.OpenScope (OCC.level); psize := ParOrg;
  570.     FormalParameters (typ.BaseTyp, psize, FALSE);
  571.     typ.link := OCT.topScope.right; OCT.CloseScope ();
  572.   ELSE
  573.     typ.BaseTyp := OCT.notyp; typ.link := NIL
  574.   END;
  575.   (* ;OCG.TraceOut (mname, pname); *)
  576. END ProcType;
  577.  
  578. (*------------------------------------*)
  579. PROCEDURE SetPtrBase (ptyp, btyp : OCT.Struct);
  580.  
  581.   (* CONST pname = "SetPtrBase"; *)
  582.  
  583. BEGIN (* SetPtrBase *)
  584.   (* OCG.TraceIn (mname, pname); *)
  585.   ptyp.symbol := OCT.OberonSysPtr;
  586.   IF (ptyp.form IN {CPointer, BPointer}) THEN
  587.     IF btyp.form = DynArr THEN
  588.       ptyp.BaseTyp := OCT.undftyp; OCS.Mark (326)
  589.     ELSE
  590.       ptyp.BaseTyp := btyp
  591.     END
  592.   ELSIF btyp.form IN {Record, Array, DynArr} THEN
  593.     ptyp.BaseTyp := btyp;
  594.     IF btyp.form = DynArr THEN
  595.       ptyp.size := btyp.size; OCC.AllocTypDesc (ptyp)
  596.     END
  597.   ELSE
  598.     ptyp.BaseTyp := OCT.undftyp; OCS.Mark (57)
  599.   END
  600.   (* ;OCG.TraceOut (mname, pname); *)
  601. END SetPtrBase;
  602.  
  603. (*------------------------------------*)
  604. (*
  605.   $  type  =  qualident | ArrayType | RecordType | StructType| PointerType |
  606.   $    ProcedureType.
  607. *)
  608. PROCEDURE Type (VAR typ : OCT.Struct);
  609.  
  610.   (* CONST pname = "Type"; *)
  611.  
  612.   VAR lev : INTEGER; obj : OCT.Object; x : OCT.Item;
  613.  
  614. BEGIN (* Type *)
  615.   (* OCG.TraceIn (mname, pname); *)
  616.   typ := OCT.undftyp;
  617.   IF sym < lparen THEN
  618.     OCS.Mark (12); REPEAT OCS.Get (sym) UNTIL sym >= lparen
  619.   END;
  620.   IF sym = ident THEN
  621.     qualident (x, FALSE);
  622.     IF x.mode = Typ THEN
  623.       typ := x.typ; IF typ = OCT.notyp THEN OCS.Mark (58) END
  624.     ELSE
  625.       OCS.Mark (52)
  626.     END
  627.   ELSIF sym = array THEN
  628.     OCS.Get (sym); ArrayType (typ)
  629.   ELSIF sym = record THEN
  630.     OCS.Get (sym); (*IF ~OCS.createObj THEN OCS.Mark (917) END;*)
  631.     RecordType (typ); OCC.AllocTypDesc (typ); CheckSym (end)
  632.   ELSIF (sym = pointer) OR (sym = cpointer) OR (sym = bpointer) THEN
  633.     typ := NewStr (Pointer);
  634.     IF sym = cpointer THEN
  635.       IF OCS.portableCode THEN OCS.Mark (915) END;
  636.       typ.form := CPointer
  637.     ELSIF sym = bpointer THEN
  638.       IF OCS.portableCode THEN OCS.Mark (915) END;
  639.       typ.form := BPointer
  640.     END;
  641.     OCS.Get (sym); typ.link := NIL; typ.size := PtrSize; CheckSym (to);
  642.     IF sym = ident THEN
  643.       OCT.Find (obj, lev);
  644.       IF obj = NIL THEN (* forward reference *)
  645.         OCT.Insert (OCS.name, obj, Undef); typ.BaseTyp := OCT.undftyp;
  646.         obj.typ := typ; OCS.Get (sym)
  647.       ELSE
  648.         qualident (x, FALSE);
  649.         IF x.mode = Typ THEN SetPtrBase (typ, x.typ)
  650.         ELSE typ.BaseTyp := OCT.undftyp; OCS.Mark (52)
  651.         END
  652.       END
  653.     ELSE Type (x.typ); SetPtrBase (typ, x.typ)
  654.     END
  655.   ELSIF sym = procedure THEN
  656.     OCS.Get (sym); ProcType (typ)
  657.   ELSE
  658.     OCS.Mark (12)
  659.   END;
  660.   IF (sym # semicolon) & (sym # rparen) & (sym # end) THEN
  661.     OCS.Mark (15);
  662.     WHILE (sym < ident) OR (else < sym) & (sym < begin) DO
  663.       OCS.Get (sym)
  664.     END
  665.   END
  666.   (* ;OCG.TraceOut (mname, pname); *)
  667. END Type;
  668.  
  669. (*------------------------------------*)
  670. (*
  671.   $  designator  =  qualident
  672.   $    {"." ident | "[" ExpList "]" | "(" qualident ")" | "^" }.
  673.        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  674.   $  ExpList  =  expression {"," expression}.
  675. *)
  676. PROCEDURE selector (VAR x, rcvr : OCT.Item);
  677.  
  678.   (* CONST pname = "selector"; *)
  679.  
  680.   VAR fld : OCT.Object; y : OCT.Item; t : OCT.Struct; f : INTEGER;
  681.  
  682. BEGIN (* selector *)
  683.   (* OCG.TraceIn (mname, pname); *)
  684.   rcvr.mode := Undef;
  685.   LOOP
  686.     IF sym = lbrak THEN
  687.       OCS.Get (sym);
  688.       LOOP
  689.         IF (x.typ # NIL) & (x.typ.form IN ptrSet) THEN OCE.DeRef (x) END;
  690.         Expression (y); OCE.Index (x, y);
  691.         IF sym = comma THEN OCS.Get (sym) ELSE EXIT END
  692.       END;
  693.       CheckSym (rbrak)
  694.     ELSIF sym = period THEN
  695.       OCS.Get (sym);
  696.       IF sym = ident THEN
  697.         IF x.typ # NIL THEN
  698.           t := x.typ; f := t.form; IF f IN ptrSet THEN t := t.BaseTyp END;
  699.           IF (t.form = Record) THEN
  700.             OCT.FindField (t, fld);
  701.             IF fld # NIL THEN
  702.               IF fld.mode = Fld THEN
  703.                 IF f IN ptrSet THEN OCE.DeRef (x) END; OCE.Field (x, fld)
  704.               ELSIF fld.mode = TProc THEN
  705.                 rcvr := x; x.mode := TProc; x.a0 := fld.a0; x.a2 := 0;
  706.                 x.obj := fld; x.typ := fld.typ; x.symbol := fld.symbol
  707.               ELSIF fld.mode = LibCall THEN
  708.                 rcvr := x; x.mode := LibCall; x.a0 := fld.a0;
  709.                 x.obj := fld; x.typ := fld.typ
  710.               END
  711.             ELSE
  712.               OCS.Mark (83); x.typ := OCT.undftyp; x.mode := Var;
  713.               x.rdOnly := FALSE
  714.             END
  715.           ELSE
  716.             OCS.Mark (53)
  717.           END;
  718.         ELSE
  719.           OCS.Mark (52) (* ? *)
  720.         END;
  721.         OCS.Get (sym)
  722.       ELSE
  723.         OCS.Mark (10)
  724.       END;
  725.     ELSIF sym = arrow THEN
  726.       IF x.mode = TProc THEN
  727.         IF (rcvr.mode IN {Var,Ind}) & (rcvr.a2 < 0) THEN
  728.           OCT.SuperCall (x.a0, rcvr.typ, fld);
  729.           IF fld # NIL THEN
  730.             x.a2 := -1; x.obj := fld; x.symbol := fld.symbol
  731.           ELSE OCS.Mark (333)
  732.           END
  733.         ELSE OCS.Mark (332)
  734.         END;
  735.         OCS.Get (sym)
  736.       ELSE
  737.         OCS.Get (sym); OCE.DeRef (x)
  738.       END
  739.     ELSIF (sym = lparen) & (x.mode < Typ) & (x.typ.form # ProcTyp) THEN
  740.       OCS.Get (sym);
  741.       IF sym = ident THEN
  742.         qualident (y, FALSE);
  743.         IF y.mode = Typ THEN OCE.TypTest (x, y, FALSE)
  744.         ELSE OCS.Mark (52)
  745.         END
  746.       ELSE
  747.         OCS.Mark (10)
  748.       END;
  749.       CheckSym (rparen)
  750.     ELSE
  751.       EXIT
  752.     END;
  753.   END; (* LOOP *)
  754.   (* ;OCG.TraceOut (mname, pname); *)
  755. END selector;
  756.  
  757. (*------------------------------------*)
  758. PROCEDURE IsParam (obj : OCT.Object) : BOOLEAN;
  759.  
  760. BEGIN (* IsParam *)
  761.   RETURN (obj # NIL) & (obj.mode <= IndR) & (obj.a0 >= 0)
  762. END IsParam;
  763.  
  764. (*------------------------------------*)
  765. PROCEDURE VarArgs
  766.   ( VAR apar : OCT.Item; fpar : OCT.Object;
  767.     VAR stackload : LONGINT; load : BOOLEAN );
  768.  
  769.   VAR x : OCT.Item;
  770.  
  771. BEGIN (* VarArgs *)
  772.   IF sym = comma THEN
  773.     OCS.Get (sym); Expression (x); VarArgs (x, fpar, stackload, FALSE)
  774.   END;
  775.   OCH.VarArg (apar, fpar, stackload, load)
  776. END VarArgs;
  777.  
  778. (*------------------------------------*)
  779. (*
  780.   $  ActualParameters  =  "(" [ExpList] ")" .
  781.   $  ExpList  =  expression {"," expression}.
  782. *)
  783. PROCEDURE ActualParameters (fpar: OCT.Object; VAR stackload : LONGINT);
  784.  
  785.   (* CONST pname = "ActualParameters"; *)
  786.  
  787.   VAR apar : OCT.Item; R : SET;
  788.  
  789. BEGIN (* ActualParameters *)
  790.   (* OCG.TraceIn (mname, pname); *)
  791.   IF sym # rparen THEN
  792.     R := OCC.RegSet;
  793.     LOOP
  794.       Expression (apar);
  795.       IF IsParam (fpar) THEN
  796.         IF fpar.mode = VarArg THEN VarArgs (apar, fpar, stackload, TRUE)
  797.         ELSE OCH.Param (apar, fpar)
  798.         END;
  799.         fpar := fpar.link
  800.       ELSE
  801.         OCS.Mark (64)
  802.       END;
  803.       IF sym = comma THEN OCS.Get (sym)
  804.       ELSIF (lparen <= sym) & (sym <= ident) THEN OCS.Mark (19)
  805.       ELSE EXIT
  806.       END
  807.     END;
  808.     OCC.FreeRegs (R);
  809.   END;
  810.   IF IsParam (fpar) THEN OCS.Mark (65) END
  811.   (* ;OCG.TraceOut (mname, pname); *)
  812. END ActualParameters;
  813.  
  814. (*------------------------------------*)
  815. PROCEDURE StandProcCall (VAR x : OCT.Item);
  816.  
  817.   (* CONST pname = "StandProcCall"; *)
  818.  
  819.   VAR y : OCT.Item; m, n : INTEGER; R : SET;
  820.  
  821. BEGIN (* StandProcCall *)
  822.   (* OCG.TraceIn (mname, pname); *)
  823.   m := SHORT (x.a0); n := 0; R := {};
  824.   IF (sym = lparen) THEN
  825.     OCS.Get (sym);
  826.     IF sym # rparen THEN
  827.       LOOP
  828.         IF m = OCT.pINLINE THEN
  829.           Expression (x); OCP.Inline (x);
  830.         ELSIF n = 0 THEN
  831.           Expression (x); OCP.StPar1 (x, m, R); n := 1
  832.         ELSIF m = OCT.pNEW THEN
  833.           Expression (y); OCP.NewPar (x, y, n); INC (n)
  834.         ELSIF n = 1 THEN
  835.           Expression (y); OCP.StPar2 (x, y, m, R); n := 2;
  836.         ELSIF n = 2 THEN
  837.           Expression (y); OCP.StPar3 (x, y, m, R); n := 3;
  838.         ELSE
  839.           OCS.Mark (64); Expression (y);
  840.         END;
  841.         IF sym = comma THEN
  842.           OCS.Get (sym)
  843.         ELSIF (lparen <= sym) & (sym <= ident) THEN
  844.           OCS.Mark (19)
  845.         ELSE
  846.           EXIT
  847.         END;
  848.       END; (* LOOP *)
  849.       CheckSym (rparen)
  850.     ELSE
  851.       OCS.Get (sym)
  852.     END;
  853.     OCP.StFct (x, m, n, R)
  854.   ELSIF m = OCT.pGC THEN
  855.     OCP.StFct (x, m, n, R)
  856.   ELSE
  857.     OCS.Mark (29)
  858.   END;
  859.   (* ;OCG.TraceOut (mname, pname); *)
  860. END StandProcCall;
  861.  
  862. (*------------------------------------*)
  863. (*
  864.   $  element  =  expression [".." expression].
  865. *)
  866. PROCEDURE Element (VAR x : OCT.Item);
  867.  
  868.   (* CONST pname = "Element"; *)
  869.  
  870.   VAR e1, e2 : OCT.Item;
  871.  
  872. BEGIN (* Element *)
  873.   (* OCG.TraceIn (mname, pname); *)
  874.   Expression (e1);
  875.   IF sym = upto THEN
  876.     OCS.Get (sym); Expression (e2); OCE.Set1 (x, e1, e2)
  877.   ELSE
  878.     OCE.Set0 (x, e1)
  879.   END;
  880.   (* ;OCG.TraceOut (mname, pname); *)
  881. END Element;
  882.  
  883. (*------------------------------------*)
  884. (*
  885.   $  set  =  "{" [element {"," element}] "}".
  886. *)
  887. PROCEDURE Sets (VAR x : OCT.Item);
  888.  
  889.   (* CONST pname = "Sets"; *)
  890.  
  891.   VAR y : OCT.Item;
  892.  
  893. BEGIN (* Sets *)
  894.   (* OCG.TraceIn (mname, pname); *)
  895.   x.typ := OCT.settyp; y.typ := OCT.settyp;
  896.   IF sym # rbrace THEN
  897.     Element (x);
  898.     LOOP
  899.       IF sym = comma THEN
  900.         OCS.Get (sym)
  901.       ELSIF (lparen <= sym) & (sym <= ident) THEN
  902.         OCS.Mark (19)
  903.       ELSE
  904.         EXIT
  905.       END;
  906.       Element (y); OCE.Op (plus, x, y, TRUE) (* x := x + y *)
  907.     END; (* LOOP *)
  908.   ELSE
  909.     x.mode := Con; x.a0 := 0
  910.   END;
  911.   CheckSym (rbrace);
  912.   (* ;OCG.TraceOut (mname, pname); *)
  913. END Sets;
  914.  
  915. (*------------------------------------*)
  916. (*
  917.   $  factor  =  number | CharConstant | string | NIL | set |
  918.   $    designator [ActualParameters] | "(" expression ")" | "~" factor.
  919. *)
  920. PROCEDURE Factor (VAR x : OCT.Item);
  921.  
  922.   (* CONST pname = "Factor"; *)
  923.  
  924.   VAR
  925.     fpar : OCT.Object; rcvr : OCT.Item; R, mask : SET;
  926.     stackload : LONGINT;
  927.  
  928. BEGIN (* Factor *)
  929.   (* OCG.TraceIn (mname, pname); *)
  930.   IF sym < lparen THEN
  931.     OCS.Mark (13);
  932.     REPEAT OCS.Get (sym) UNTIL sym >= lparen
  933.   END;
  934.   x.desc := NIL;
  935.   IF sym = ident THEN
  936.     qualident (x, TRUE); selector (x, rcvr);
  937.     IF x.mode = SProc THEN
  938.       StandProcCall (x)
  939.     ELSIF sym = lparen THEN
  940.       OCH.PrepCall (x, fpar, mask); OCC.SaveRegisters (R, x, mask);
  941.       IF x.mode = TProc THEN OCH.Receiver (rcvr, x.obj.link) END;
  942.       OCS.Get (sym); stackload := 0; ActualParameters (fpar, stackload);
  943.       IF x.mode = LibCall THEN OCH.CallLibCall (x, rcvr, stackload)
  944.       ELSIF x.mode = TProc THEN OCH.CallTypeBound (x, rcvr)
  945.       ELSE OCH.Call (x)
  946.       END;
  947.       OCC.RestoreRegisters (R, x);
  948.       CheckSym (rparen)
  949.     END;
  950.   ELSIF sym = number THEN
  951.     OCS.Get (sym); x.mode := Con;
  952.     CASE OCS.numtyp OF
  953.       1 : x.typ := OCT.chartyp; x.a0 := OCS.intval
  954.       |
  955.       2 : x.a0 := OCS.intval; OCE.SetIntType (x)
  956.       |
  957.       3 : x.typ := OCT.realtyp; OCE.AssReal (x, OCS.realval)
  958.       |
  959.       4 : x.typ := OCT.lrltyp; OCE.AssLReal (x, OCS.lrlval)
  960.       |
  961.     END; (* CASE OCS.numtyp *)
  962.   ELSIF sym = string THEN
  963.     x.typ := OCT.stringtyp; x.mode := Con;
  964.     OCC.AllocString (OCS.name, OCS.intval, x); OCS.Get (sym);
  965.     IF ~OCS.portableCode THEN
  966.       WHILE sym = string DO
  967.         OCC.ConcatString (OCS.name, OCS.intval, x); OCS.Get (sym)
  968.       END
  969.     END
  970.   ELSIF sym = nil THEN
  971.     OCS.Get (sym); x.typ := OCT.niltyp; x.mode := Con; x.a0 := 0
  972.   ELSIF sym = lparen THEN
  973.     OCS.Get (sym); Expression (x); CheckSym (rparen)
  974.   ELSIF sym = lbrak THEN
  975.     OCS.Get (sym); OCS.Mark (29); Expression (x); CheckSym (rparen)
  976.   ELSIF sym = lbrace THEN
  977.     OCS.Get (sym); Sets (x)
  978.   ELSIF sym = not THEN
  979.     OCS.Get (sym); Factor (x); OCE.MOp (not, x)
  980.   ELSE
  981.     OCS.Mark (13); OCS.Get (sym); x.typ := OCT.undftyp; x.mode := Var;
  982.     x.a0 := 0
  983.   END;
  984.   (* ;OCG.TraceOut (mname, pname); *)
  985. END Factor;
  986.  
  987. (*------------------------------------*)
  988. (*
  989.   $  term  =  factor {MulOperator factor}.
  990.   $  MulOperator  =  "*" | "/" | DIV | MOD | "&" .
  991. *)
  992. PROCEDURE Term (VAR x : OCT.Item);
  993.  
  994.   (* CONST pname = "Term"; *)
  995.  
  996.   VAR
  997.     y : OCT.Item; mulop : INTEGER;
  998.  
  999. BEGIN (* Term *)
  1000.   (* OCG.TraceIn (mname, pname); *)
  1001.   Factor (x);
  1002.   WHILE (times <= sym) & (sym <= and) DO
  1003.     mulop := sym; OCS.Get (sym);
  1004.     IF mulop = and THEN OCE.MOp (and, x)  END;
  1005.     Factor (y); OCE.Op (mulop, x, y, TRUE);
  1006.   END;
  1007.   (* ;OCG.TraceOut (mname, pname); *)
  1008. END Term;
  1009.  
  1010. (*------------------------------------*)
  1011. (*
  1012.   $  SimpleExpression  =  ["+"|"-"] term {AddOperator term}.
  1013.   $  AddOperator  =  "+" | "-" | OR .
  1014. *)
  1015. PROCEDURE SimpleExpression (VAR x : OCT.Item);
  1016.  
  1017.   (* CONST pname = "SimpleExpression"; *)
  1018.  
  1019.   VAR y : OCT.Item; addop : INTEGER;
  1020.  
  1021. BEGIN (* SimpleExpression *)
  1022.   (* OCG.TraceIn (mname, pname); *)
  1023.   IF sym = minus THEN OCS.Get (sym); Term (x); OCE.MOp (minus, x)
  1024.   ELSIF sym = plus THEN OCS.Get (sym); Term (x); OCE.MOp (plus, x)
  1025.   ELSE Term (x)
  1026.   END;
  1027.   WHILE (plus <= sym) & (sym <= or) DO
  1028.     addop := sym; OCS.Get (sym); IF addop = or THEN OCE.MOp (or, x) END;
  1029.     Term (y); OCE.Op (addop, x, y, TRUE);
  1030.   END;
  1031.   (* ;OCG.TraceOut (mname, pname); *)
  1032. END SimpleExpression;
  1033.  
  1034. (*------------------------------------*)
  1035. (*
  1036.   $  expression  =  SimpleExpression [relation SimpleExpression].
  1037.   $  relation  =  "=" | "#" | "<" | "<=" | ">" | ">=" | IN | IS.
  1038. *)
  1039. PROCEDURE Expression (VAR x : OCT.Item);
  1040.  
  1041.   (* CONST pname = "Expression"; *)
  1042.  
  1043.   VAR
  1044.     y : OCT.Item; relation : INTEGER;
  1045.  
  1046. BEGIN (* Expression *)
  1047.   (* OCG.TraceIn (mname, pname); *)
  1048.   SimpleExpression (x);
  1049.   IF (eql <= sym) & (sym <= geq) THEN
  1050.     relation := sym; OCS.Get (sym);
  1051.     IF x.typ = OCT.booltyp THEN OCE.MOp (relation, x) END;
  1052.     SimpleExpression (y); OCE.Op (relation, x, y, TRUE)
  1053.   ELSIF sym = in THEN
  1054.     OCS.Get (sym); SimpleExpression (y); OCE.In (x, y)
  1055.   ELSIF sym = is THEN
  1056.     IF x.mode >= Typ THEN OCS.Mark (112) END;
  1057.     OCS.Get (sym);
  1058.     IF sym = ident THEN
  1059.       qualident (y, FALSE);
  1060.       IF y.mode = Typ THEN OCE.TypTest (x, y, TRUE) ELSE OCS.Mark (52) END
  1061.     ELSE
  1062.       OCS.Mark (10)
  1063.     END;
  1064.   END;
  1065.   (* ;OCG.TraceOut (mname, pname); *)
  1066. END Expression;
  1067.  
  1068. (*------------------------------------*)
  1069. PROCEDURE Receiver (VAR rtyp : OCT.Struct; libCall : BOOLEAN);
  1070.  
  1071.   (* CONST pname = "Receiver"; *)
  1072.  
  1073.   VAR
  1074.     mode : SHORTINT; mnolev : INTEGER; recvr, obj : OCT.Object;
  1075.     typ : OCT.Struct;
  1076.  
  1077. BEGIN (* Receiver *)
  1078.   (* OCG.TraceIn (mname, pname); *)
  1079.   recvr := NIL; rtyp := OCT.undftyp;
  1080.   IF sym = var THEN mode := Ind; OCS.Get (sym)
  1081.   ELSE mode := Var
  1082.   END;
  1083.   IF sym = ident THEN
  1084.     OCT.Insert (OCS.name, recvr, mode); OCS.Get (sym);
  1085.     OCT.topScope.right := recvr
  1086.   ELSE
  1087.     recvr := OCT.AllocObj (); OCS.Mark (10)
  1088.   END;
  1089.   recvr.typ := OCT.undftyp; recvr.a2 := -1; CheckSym (colon);
  1090.   IF sym = ident THEN
  1091.     OCT.Find (obj, mnolev); IF obj = NIL THEN OCS.Mark (0) END;
  1092.     OCS.Get (sym);
  1093.     IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  1094.       OCS.Get (sym);
  1095.       IF sym = ident THEN
  1096.         OCT.FindImport (obj, obj); IF obj = NIL THEN OCS.Mark (0) END;
  1097.         OCS.Get (sym)
  1098.       ELSE
  1099.         OCS.Mark (10); obj := NIL
  1100.       END;
  1101.       OCS.Mark (305)
  1102.     END;
  1103.     IF (obj # NIL) & (obj.mode = Typ) THEN
  1104.       typ := obj.typ; IF typ = NIL THEN typ := OCT.undftyp END;
  1105.       IF typ = OCT.undftyp THEN OCS.Mark (58)
  1106.       ELSIF (mode = Ind) & (typ.form # Record) THEN
  1107.         OCS.Mark (307); typ := OCT.undftyp
  1108.       ELSIF (mode = Var) THEN
  1109.         IF libCall THEN
  1110.           IF typ.form # CPointer THEN OCS.Mark (308); typ := OCT.undftyp END
  1111.         ELSE
  1112.           IF typ.form # Pointer THEN OCS.Mark (306); typ := OCT.undftyp END
  1113.         END;
  1114.       END;
  1115.       IF typ.form IN ptrSet THEN rtyp := typ.BaseTyp ELSE rtyp := typ END;
  1116.       recvr.typ := typ;
  1117.       IF libCall THEN recvr.a0 := 0
  1118.       ELSIF mode = Var THEN recvr.a0 := -AdrSize
  1119.       ELSE recvr.a0 := -RecDescSize
  1120.       END
  1121.     ELSE
  1122.       OCS.Mark (52)
  1123.     END;
  1124.   ELSE
  1125.     OCS.Mark (10)
  1126.   END;
  1127.   CheckSym (rparen);
  1128.   (* ;OCG.TraceOut (mname, pname); *)
  1129. END Receiver;
  1130.  
  1131. (*------------------------------------*)
  1132. (*
  1133.   $  LibCallDeclaration = LIBCALL identdef ["*"] LibCallSpec
  1134.   $    [FormalParameters]
  1135.   $  LibCallSpec = "{" identdef "," ConstExpression "}"
  1136. *)
  1137. PROCEDURE LibCallDeclaration ();
  1138.  
  1139.   (* CONST pname = "LibCallDeclaration"; *)
  1140.  
  1141.   VAR
  1142.     proc, par : OCT.Object;
  1143.     psize, dsize : LONGINT;
  1144.     rtyp : OCT.Struct;
  1145.  
  1146. BEGIN (* LibCallDeclaration *)
  1147.   (* OCG.TraceIn (mname, pname); *)
  1148.   IF OCS.portableCode THEN OCS.Mark (915) END;
  1149.   rtyp := OCT.undftyp;
  1150.   IF sym = lparen THEN
  1151.     OCT.OpenScope (OCC.level + 1); OCS.Get (sym); Receiver (rtyp, TRUE)
  1152.   ELSE OCS.Mark (303)
  1153.   END;
  1154.   IF sym = ident THEN
  1155.     (* See if there is a forward declaration already *)
  1156.     OCT.FindField (rtyp, proc);
  1157.     IF proc # NIL THEN (* multiple definition *) OCS.Mark (1) END;
  1158.     proc := OCT.AllocObj(); proc.name := OCT.InsertName (OCS.name);
  1159.     IF rtyp # OCT.undftyp THEN
  1160.       proc.left := rtyp.link; rtyp.link := proc
  1161.     END;
  1162.     CheckMark (proc.visible, FALSE);
  1163.     proc.mode := LibCall; proc.typ := OCT.notyp; proc.link := NIL;
  1164.     proc.a0 := 0; proc.a1 := 0;
  1165.     INC (OCC.level);
  1166.     IF sym = lparen THEN (* Get formal parameters *)
  1167.       psize := 0; OCS.Get (sym); FormalParameters (proc.typ, psize, TRUE);
  1168.       proc.link := OCT.topScope.right
  1169.     END;
  1170.     CheckSym (semicolon);
  1171.     IF sym = minus THEN OCS.Get (sym) END;
  1172.     IF sym = number THEN proc.a0 := -OCS.intval; OCS.Get (sym)
  1173.     ELSE OCS.Mark (17)
  1174.     END;
  1175.     DEC (OCC.level); OCT.CloseScope ()
  1176.   END; (* IF *)
  1177.   (* ;OCG.TraceOut (mname, pname); *)
  1178. END LibCallDeclaration;
  1179.  
  1180. (*------------------------------------*)
  1181. (*
  1182.   $  ProcedureDeclaration  =  ProcedureHeading ";" ProcedureBody ident.
  1183.   $  ProcedureHeading  =  PROCEDURE ["*"] identdef [FormalParameters].
  1184.   $  ForwardDeclaration  =  PROCEDURE "^" identdef [FormalParameters].
  1185. *)
  1186. PROCEDURE ProcedureDeclaration ();
  1187.  
  1188.   (* CONST pname = "ProcedureDeclaration"; *)
  1189.  
  1190.   VAR
  1191.     proc, proc1, par : OCT.Object;
  1192.     rtyp : OCT.Struct;
  1193.     retList, L1 : INTEGER; mode : SHORTINT;
  1194.     body, forward : BOOLEAN;
  1195.     psize, dsize : LONGINT;
  1196.     x : OCT.Item;
  1197.     symbol : OCT.Symbol;
  1198.  
  1199. BEGIN (* ProcedureDeclaration *)
  1200.   (* OCG.TraceIn (mname, pname); *)
  1201.   dsize := 0; proc := NIL; body := TRUE; forward := FALSE; mode := LProc;
  1202.   IF (sym # ident) & (OCC.level = 0) THEN
  1203.     (* Process specifier after procedure symbol *)
  1204.     IF sym = times THEN mode := XProc; OCS.Get (sym)
  1205.     ELSIF sym = arrow THEN forward := TRUE; body := FALSE; OCS.Get (sym)
  1206.     END;
  1207.     IF sym = lparen THEN (* Type-bound procedure *)
  1208.       mode := TProc; OCS.Get (sym); OCT.OpenScope (OCC.level + 1);
  1209.       Receiver (rtyp, FALSE)
  1210.     ELSIF sym # ident THEN OCS.Mark (10)
  1211.     END;
  1212.   END;
  1213.  
  1214.   IF sym = ident THEN
  1215.     IF mode = TProc THEN
  1216.       (*
  1217.         We must be aware of two possibilities for type-bound procedures:
  1218.         - There is a forward declaration for the *same* type
  1219.           (proc1.a1 = rtyp.n) & (proc1.a2 = -1);
  1220.         - It is a redefinition of a procedure from a base type
  1221.           (proc1.a1 # rtyp.n) & (proc1.a2 = 0).
  1222.       *)
  1223.       OCT.FindField (rtyp, proc1);
  1224.       IF proc1 # NIL THEN
  1225.         IF proc1.mode # TProc THEN (* Name used for a record field *)
  1226.           OCS.Mark (329); proc1 := NIL
  1227.         ELSIF (proc1.a1 = rtyp.n) & (proc1.a2 = 0) THEN
  1228.           (* Procedure already declared *)
  1229.           OCS.Mark (1); proc1 := NIL
  1230.         END
  1231.       END;
  1232.       proc := OCT.AllocObj (); proc.name := OCT.InsertName (OCS.name);
  1233.       CheckMark (proc.visible, FALSE);
  1234.       (* Assign a procedure number *)
  1235.       IF proc1 # NIL THEN proc.a0 := proc1.a0
  1236.       ELSE proc.a0 := OCT.NextProc (rtyp)
  1237.       END;
  1238.       (* Note the type level *)
  1239.       proc.a1 := rtyp.n;
  1240.       (* Prepare to parse the parameters *)
  1241.       INC (OCC.level);
  1242.       IF (proc.visible = OCT.Exp) & ~OCS.longVars THEN
  1243.         (* return address + frame ptr + global var base *)
  1244.         psize := XParOrg
  1245.       ELSE
  1246.         (* return address + frame ptr *)
  1247.         psize := ParOrg
  1248.       END
  1249.     ELSE
  1250.       (* See if there is a forward declaration already *)
  1251.       IF OCC.level = 0 THEN OCT.Find (proc1, L1) ELSE proc1 := NIL END;
  1252.       IF (proc1 # NIL) & (proc1.a2 < 0) THEN
  1253.         (* there exists a corresponding forward declaration *)
  1254.         proc := OCT.AllocObj (); CheckMark (proc.visible, FALSE);
  1255.         IF proc.visible = OCT.Exp THEN mode := XProc END;
  1256.       ELSE
  1257.         IF proc1 # NIL THEN OCS.Mark (1); proc1 := NIL END;
  1258.         OCT.Insert (OCS.name, proc, mode); CheckMark (proc.visible, FALSE);
  1259.         IF (proc.visible = OCT.Exp) & (mode = LProc) THEN mode := XProc END;
  1260.         IF (proc.visible # OCT.Exp) & (OCC.level > 0) THEN
  1261.           proc.a0 := procNo; INC (procNo)
  1262.         ELSE
  1263.           proc.a0 := 0
  1264.         END
  1265.       END;
  1266.  
  1267.       INC (OCC.level); OCT.OpenScope (OCC.level);
  1268.       (* work out offset of procedure parameters *)
  1269.       IF (mode = LProc) & (OCC.level > 1) THEN
  1270.         psize := LParOrg (* return address + frame ptr + static link *)
  1271.       ELSIF (mode = XProc) & ~OCS.longVars THEN
  1272.         psize := XParOrg (* return address + frame ptr + global var base *)
  1273.       ELSE
  1274.         psize := ParOrg  (* return address + frame ptr *)
  1275.       END;
  1276.     END;
  1277.  
  1278.     IF sym = lbrak THEN (* Foreign procedure *)
  1279.       IF mode = TProc THEN OCS.Mark (344)
  1280.       ELSIF forward THEN OCS.Mark (343); forward := FALSE
  1281.       END;
  1282.       mode := FProc; body := FALSE; OCS.Get (sym);
  1283.       IF sym = string THEN
  1284.         NEW (symbol, Str.Length (OCS.name) + 1); COPY (OCS.name, symbol^);
  1285.         OCS.Get (sym)
  1286.       ELSE OCS.Mark (342); symbol := NIL
  1287.       END;
  1288.       CheckSym (rbrak);
  1289.     END;
  1290.  
  1291.     proc.mode := mode; proc.typ := OCT.notyp;
  1292.     IF forward THEN proc.a2 := -1 ELSE proc.a2 := 0 END;
  1293.  
  1294.     IF sym = lparen THEN (* Get formal parameters *)
  1295.       OCS.Get (sym); FormalParameters (proc.typ, psize, (mode = FProc));
  1296.     ELSIF mode = TProc THEN (* fixup receiver parameter *)
  1297.       par := OCT.topScope.right;
  1298.       IF par # NIL THEN
  1299.         par.a0 := psize;
  1300.         IF par.mode = Ind THEN INC (psize, RecDescSize)
  1301.         ELSE INC (psize, AdrSize)
  1302.         END
  1303.       END
  1304.     END;
  1305.     proc.link := OCT.topScope.right;
  1306.  
  1307.     IF proc1 # NIL THEN
  1308.       IF mode = TProc THEN (* forward declaration or redefinition *)
  1309.         IF
  1310.           (proc1.a2 = 0) & (rtyp.strobj.visible = OCT.Exp)
  1311.           & (proc1.visible = OCT.Exp) & (proc.visible # OCT.Exp)
  1312.         THEN (* Redefined procedure must be exported *)
  1313.           OCS.Mark (330)
  1314.         END;
  1315.         OCH.CompareParLists (proc.link.link, proc1.link.link);
  1316.       ELSE (* forward declaration *)
  1317.         OCH.CompareParLists (proc.link, proc1.link);
  1318.       END;
  1319.       IF proc.typ # proc1.typ THEN OCS.Mark (118) END;
  1320.       IF proc1.a2 < 0 THEN (* forward declaration *)
  1321.         proc.link := NIL; OCT.FreeObj (proc);
  1322.         proc := proc1; OCT.FreeObj (proc.link);
  1323.         proc.link := OCT.topScope.right
  1324.       END
  1325.     END;
  1326.     IF forward OR (proc.a2 = 0) THEN
  1327.       IF mode = TProc THEN
  1328.         IF rtyp # OCT.undftyp THEN
  1329.           proc.left := rtyp.link; rtyp.link := proc;
  1330.           OCT.MakeTProcSymbol (rtyp.symbol, proc)
  1331.         END
  1332.       ELSIF mode = FProc THEN
  1333.         proc.symbol := symbol
  1334.       ELSE
  1335.         OCT.MakeProcSymbol (proc)
  1336.       END
  1337.     END;
  1338.     IF ~forward THEN proc.a2 := 0 END;
  1339.  
  1340.     IF body THEN
  1341.       CheckSym (semicolon); OCT.topScope.typ := proc.typ;
  1342.  
  1343.       OCH.StartProcedure (proc);
  1344.       Block (proc, dsize, retList);
  1345.       proc.link := OCT.topScope.right; (* update *)
  1346.       OCH.EndProcBody (proc, SHORT (psize), retList, dsize # 0);
  1347.       OCS.ResetProcSwitches ();
  1348.  
  1349.       (* Check size of local variables *)
  1350.       IF dsize > ProcVarSize THEN OCS.Mark (209); dsize := 0 END;
  1351.  
  1352.       (* Check name at end of procedure *)
  1353.       IF sym = ident THEN
  1354.         IF OCT.InsertName (OCS.name) # proc.name THEN OCS.Mark (4) END;
  1355.         OCS.Get (sym)
  1356.       ELSE
  1357.         OCS.Mark (10)
  1358.       END;
  1359.     END; (* IF *)
  1360.  
  1361.     IF proc.link # NIL THEN
  1362.       par := proc.link; WHILE IsParam (par.link) DO par := par.link END;
  1363.       (*OCT.FreeObj (par.link);*) par.link := NIL
  1364.     END;
  1365.     DEC (OCC.level); OCT.CloseScope ()
  1366.   END; (* IF *)
  1367.   (* ;OCG.TraceOut (mname, pname); *)
  1368. END ProcedureDeclaration;
  1369.  
  1370. (*------------------------------------*)
  1371. (*
  1372.   $  CaseLabelList  =  CaseLabels {"," CaseLabels}.
  1373.   $  CaseLabels  =  ConstExpression [".." ConstExpression].
  1374. *)
  1375. PROCEDURE CaseLabelList (
  1376.   LabelForm : INTEGER; VAR n : INTEGER; VAR tab : ARRAY OF OCH.LabelRange);
  1377.  
  1378.   (* CONST pname = "CaseLabelList"; *)
  1379.  
  1380.   VAR
  1381.     x, y : OCT.Item; i, f, g : INTEGER;
  1382.  
  1383. BEGIN (* CaseLabelList *)
  1384.   (* OCG.TraceIn (mname, pname); *)
  1385.   IF ~(LabelForm IN labeltyps) THEN OCS.Mark (61) END;
  1386.   LOOP
  1387.     ConstExpression (x); f := x.typ.form;
  1388.     IF (f = String) & (x.a1 <= 2) THEN
  1389.       x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  1390.     END;
  1391.     IF f IN intSet THEN
  1392.       IF LabelForm < f THEN OCS.Mark (60) END
  1393.     ELSIF f # LabelForm THEN
  1394.       OCS.Mark (60)
  1395.     END;
  1396.     IF sym = upto THEN
  1397.       OCS.Get (sym); ConstExpression (y); g := y.typ.form;
  1398.       IF (g = String) & (y.a1 <= 2) THEN
  1399.         y.a0 := y.a2; y.typ := OCT.chartyp; g := Char
  1400.       END;
  1401.       IF (g # f) & ~((f IN intSet) & (g IN intSet)) THEN
  1402.         OCS.Mark (60)
  1403.       END;
  1404.       IF y.a0 < x.a0 THEN OCS.Mark (63); y.a0 := x.a0 END
  1405.     ELSE
  1406.       y := x
  1407.     END;
  1408.     (* enter label range into ordered table *)
  1409.     i := n;
  1410.     IF i < NofCases THEN
  1411.       LOOP
  1412.         IF i = 0 THEN EXIT END;
  1413.         IF tab [i-1].low <= y.a0 THEN
  1414.           IF tab[i-1].high >= x.a0 THEN OCS.Mark (62) END;
  1415.           EXIT
  1416.         END;
  1417.         tab [i] := tab[i-1]; DEC (i)
  1418.       END; (* LOOP *)
  1419.       tab [i].low := SHORT (x.a0); tab[i].high := SHORT (y.a0);
  1420.       tab[i].label := OCC.pc; INC (n)
  1421.     ELSE
  1422.       OCS.Mark (213)
  1423.     END;
  1424.     IF sym = comma THEN
  1425.       OCS.Get (sym)
  1426.     ELSIF (sym = number) OR (sym = ident) THEN
  1427.       OCS.Mark (19)
  1428.     ELSE
  1429.       EXIT
  1430.     END;
  1431.   END; (* LOOP *)
  1432.   (* ;OCG.TraceOut (mname, pname); *)
  1433. END CaseLabelList;
  1434.  
  1435. (*------------------------------------*)
  1436. (*
  1437.   $  StatementSequence  =  statement {";" statement}.
  1438.  
  1439.   $  statement  =  [assignment | ProcedureCall |
  1440.   $    IfStatement | CaseStatement | WhileStatement | RepeatStatement |
  1441.   $    LoopStatement | WithStatement | EXIT | RETURN [expression] ].
  1442.  
  1443.   $  assignment  =  designator ":=" expression.
  1444.  
  1445.   $  ProcedureCall  =  designator [ActualParameters].
  1446.  
  1447.   $  IfStatement  =  IF expression THEN StatementSequence
  1448.   $    {ELSIF expression THEN StatementSequence}
  1449.   $    [ELSE StatementSequence]
  1450.   $    END.
  1451.  
  1452.   $  CaseStatement  =  CASE expression OF case {"|" case}
  1453.   $    [ELSE StatementSequence] END.
  1454.   $  case  =  [CaseLabelList ":" StatementSequence].
  1455.  
  1456.   $  WhileStatement  =  WHILE expression DO StatementSequence END.
  1457.  
  1458.   $  RepeatStatement  =   REPEAT StatementSequence UNTIL expression.
  1459.  
  1460.   $  LoopStatement  =  LOOP StatementSequence END.
  1461.  
  1462.   $  WithStatement  =  WITH qualident ":" qualident DO
  1463.   $    StatementSequence END.
  1464. *)
  1465. PROCEDURE StatSeq (VAR retList : INTEGER);
  1466.  
  1467.   (* CONST pname = "StatSeq"; *)
  1468.  
  1469.   VAR
  1470.     fpar : OCT.Object; xtyp : OCT.Struct; stackload : LONGINT;
  1471.     x, rcvr, y, z, step : OCT.Item; L0, L1, ExitIndex : INTEGER;
  1472.     R, R1, mask : SET;
  1473.  
  1474.   (*------------------------------------*)
  1475.   PROCEDURE CasePart ();
  1476.  
  1477.     (* CONST pname = "CasePart"; *)
  1478.  
  1479.     VAR
  1480.       x : OCT.Item; n, L0, L1, L2 : INTEGER;
  1481.       tab : ARRAY NofCases OF OCH.LabelRange;
  1482.  
  1483.   BEGIN (* CasePart *)
  1484.     (* OCG.TraceIn (mname, pname); *)
  1485.     n := 0; L1 := 0;
  1486.     Expression (x); OCH.CaseIn (x, L0); CheckSym (of);
  1487.     LOOP
  1488.       IF sym < bar THEN
  1489.         CaseLabelList (x.typ.form, n, tab);
  1490.         CheckSym (colon); StatSeq (retList); OCH.FJ (L1)
  1491.       END;
  1492.       IF sym = bar THEN OCS.Get (sym) ELSE EXIT END
  1493.     END; (* LOOP *)
  1494.     L2 := OCC.pc;
  1495.     IF sym = else THEN
  1496.       OCS.Get (sym); StatSeq (retList); OCH.FJ (L1)
  1497.     ELSE
  1498.       IF OCS.caseCheck THEN OCC.Trap (OCC.CaseCheck)
  1499.       ELSE OCH.FJ (L1)
  1500.       END
  1501.     END;
  1502.     OCH.CaseOut (x, L0, L1, L2, n, tab)
  1503.     (* ;OCG.TraceOut (mname, pname); *)
  1504.   END CasePart;
  1505.  
  1506. BEGIN (* StatSeq *)
  1507.   (* OCG.TraceIn (mname, pname); *)
  1508.   R := OCC.RegSet;
  1509.   LOOP
  1510.     IF sym < ident THEN (* illegal symbol *)
  1511.       OCS.Mark (14);
  1512.       REPEAT OCS.Get (sym) UNTIL sym >= ident;
  1513.     END;
  1514.  
  1515.     IF sym = ident THEN (* assignment or procedure call *)
  1516.       qualident (x, TRUE); selector (x, rcvr);
  1517.       IF sym = becomes THEN (* assignment *)
  1518.         OCS.Get (sym); Expression (y); OCH.Assign (x, y, FALSE)
  1519.       ELSIF sym = eql THEN (* typo ? *)
  1520.         OCS.Mark (33); OCS.Get (sym); Expression (y);
  1521.         OCH.Assign (x, y, FALSE)
  1522.       ELSIF x.mode = SProc THEN (* standard procedure call *)
  1523.         StandProcCall (x); IF x.typ # OCT.notyp THEN OCS.Mark (55) END
  1524.       ELSE (* procedure call *)
  1525.         OCH.PrepCall (x, fpar, mask); OCC.SaveRegisters (R1, x, mask);
  1526.         IF x.mode = TProc THEN OCH.Receiver (rcvr, x.obj.link) END;
  1527.         stackload := 0;
  1528.         IF sym = lparen THEN
  1529.           OCS.Get (sym); ActualParameters (fpar, stackload);
  1530.           CheckSym (rparen);
  1531.         ELSIF IsParam (fpar) THEN (* parameters missing *)
  1532.           OCS.Mark (65)
  1533.         END;
  1534.         IF x.mode = LibCall THEN OCH.CallLibCall (x, rcvr, stackload)
  1535.         ELSIF x.mode = TProc THEN OCH.CallTypeBound (x, rcvr)
  1536.         ELSE OCH.Call (x)
  1537.         END;
  1538.         OCC.RestoreRegisters (R1, x);
  1539.         IF x.typ # OCT.notyp THEN OCS.Mark (55) END;
  1540.       END;
  1541.       (*OCT.FreeDesc (x.desc);*)
  1542.  
  1543.     ELSIF sym = if THEN (* if statement *)
  1544.       OCS.Get (sym); Expression (x); OCH.CFJ (x, L0); OCC.FreeRegs (R);
  1545.       CheckSym (then); StatSeq (retList); L1 := 0;
  1546.       WHILE sym = elsif DO
  1547.         OCS.Get (sym); OCH.FJ (L1); OCC.FixLink (L0);
  1548.         Expression (x); OCH.CFJ (x, L0); OCC.FreeRegs (R);
  1549.         CheckSym (then); StatSeq (retList)
  1550.       END;
  1551.       IF sym = else THEN
  1552.         OCS.Get (sym); OCH.FJ (L1); OCC.FixLink (L0);
  1553.         StatSeq (retList)
  1554.       ELSE
  1555.         OCC.FixLink (L0)
  1556.       END;
  1557.       OCC.FixLink (L1); CheckSym (end)
  1558.  
  1559.     ELSIF sym = case THEN (* case statement *)
  1560.       OCS.Get (sym); CasePart (); CheckSym (end)
  1561.  
  1562.     ELSIF sym = while THEN (* while statement *)
  1563.       OCS.Get (sym); L1 := OCC.pc;
  1564.       Expression (x); OCH.CFJ (x, L0); OCC.FreeRegs (R);
  1565.       CheckSym (do); StatSeq (retList); OCH.BJ (L1); OCC.FixLink (L0);
  1566.       CheckSym (end)
  1567.  
  1568.     ELSIF sym = repeat THEN (* repeat statement *)
  1569.       OCS.Get (sym); L0 := OCC.pc; StatSeq (retList);
  1570.       IF sym = until THEN
  1571.         OCS.Get (sym); Expression (x); OCH.CBJ (x, L0)
  1572.       ELSE
  1573.         OCS.Mark (43)
  1574.       END;
  1575.  
  1576.     ELSIF sym = for THEN
  1577.       OCS.Get (sym);
  1578.       IF sym = ident THEN
  1579.         qualident (x, FALSE);
  1580.         IF x.lev < 0 THEN OCS.Mark (327)
  1581.         ELSIF ~(x.typ.form IN intSet) THEN OCS.Mark (314)
  1582.         END;
  1583.         CheckSym (becomes); Expression (y);
  1584.         IF ~(y.typ.form IN intSet) THEN OCS.Mark (315) END;
  1585.         CheckSym (to); Expression (z);
  1586.         IF ~(z.typ.form IN intSet) THEN OCS.Mark (315) END;
  1587.         IF sym = by THEN OCS.Get (sym); ConstExpression (step);
  1588.           IF ~(step.typ.form IN intSet) THEN OCS.Mark (17)
  1589.           ELSIF step.a0 = 0 THEN OCS.Mark (316); step.a0 := 1
  1590.           END;
  1591.         ELSE step.mode := Con; step.a0 := 1; step.typ := OCT.sinttyp
  1592.         END;
  1593.         OCH.BeginFor (x, y, z, step, L0, L1); OCC.FreeRegs (R);
  1594.         IF z.mode = Reg THEN OCC.ReserveReg (SHORT (z.a0)) END;
  1595.         CheckSym (do); StatSeq (retList); OCH.EndFor (x, step, L0, L1);
  1596.         IF z.mode = Reg THEN OCC.UnReserveReg (SHORT (z.a0)) END;
  1597.         CheckSym (end)
  1598.       ELSE OCS.Mark (10)
  1599.       END;
  1600.  
  1601.     ELSIF sym = loop THEN (* loop statement *)
  1602.       OCS.Get (sym); ExitIndex := ExitNo; INC (LoopLevel);
  1603.       L0 := OCC.pc; StatSeq (retList); OCH.BJ (L0); DEC (LoopLevel);
  1604.       WHILE ExitNo > ExitIndex DO
  1605.         DEC (ExitNo); OCC.fixup (LoopExit [ExitNo])
  1606.       END;
  1607.       CheckSym (end)
  1608.  
  1609.     ELSIF sym = with THEN (* regional type guard *)
  1610.       L1 := 0;
  1611.       REPEAT
  1612.         OCS.Get (sym); x.obj := NIL; xtyp := NIL;
  1613.         IF sym = ident THEN (* got variable OK *)
  1614.           qualident (x, FALSE); CheckSym (colon);
  1615.           IF sym = ident THEN
  1616.             qualident (y, FALSE);
  1617.             IF y.mode = Typ THEN (* got type OK *)
  1618.               IF x.obj # NIL THEN
  1619.                 xtyp := x.typ; x.obj.typ := y.typ; OCE.TypTest (x, y, TRUE)
  1620.               ELSE OCS.Mark (130) (* variable has anonymous type *)
  1621.               END
  1622.             ELSE OCS.Mark (52) (* not a type *)
  1623.             END
  1624.           ELSE OCS.Mark (10)
  1625.           END
  1626.         ELSE OCS.Mark (10)
  1627.         END;
  1628.         CheckSym (do); OCC.FreeRegs (R); OCH.CFJ (x, L0); StatSeq (retList);
  1629.         IF (sym = bar) OR (sym = else) THEN
  1630.           OCH.FJ (L1); OCC.FixLink (L0)
  1631.         END;
  1632.         IF xtyp # NIL THEN x.obj.typ := xtyp END;
  1633.       UNTIL sym # bar;
  1634.       IF sym = else THEN OCS.Get (sym); StatSeq (retList)
  1635.       ELSIF OCS.typeCheck THEN OCC.TypeTrap (L0)
  1636.       ELSE OCC.FixLink (L0)
  1637.       END;
  1638.       OCC.FixLink (L1);
  1639.       CheckSym (end);
  1640.  
  1641.     ELSIF sym = exit THEN (* Loop exit statement *)
  1642.       OCS.Get (sym); L0 := 0; OCH.FJ (L0);
  1643.       IF LoopLevel = 0 THEN OCS.Mark (45)
  1644.       ELSIF ExitNo < NumLoopLevels THEN
  1645.         LoopExit [ExitNo] := L0; INC (ExitNo)
  1646.       ELSE OCS.Mark (214)
  1647.       END;
  1648.  
  1649.     ELSIF sym = return THEN (* Procedure return statement *)
  1650.       OCS.Get (sym);
  1651.       IF OCC.level > 0 THEN (* Return from procedure *)
  1652.         IF sym < semicolon THEN
  1653.           Expression (x); OCH.Result (x, OCT.topScope.typ)
  1654.         ELSIF OCT.topScope.typ # OCT.notyp THEN (* expression missing *)
  1655.           OCS.Mark (124)
  1656.         END;
  1657.         OCH.FJ (retList)
  1658.       ELSE (* return from module body *)
  1659.         IF sym < semicolon THEN Expression (x); OCS.Mark (124) END;
  1660.         OCH.FJ (retList)
  1661.       END;
  1662.     END;
  1663.  
  1664.     OCC.FreeRegs (R);
  1665.  
  1666.     IF sym = semicolon THEN
  1667.       OCS.Get (sym)
  1668.     ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN
  1669.       OCS.Mark (38)
  1670.     ELSE
  1671.       EXIT
  1672.     END;
  1673.   END; (* LOOP *)
  1674.   (* ;OCG.TraceOut (mname, pname); *)
  1675. END StatSeq;
  1676.  
  1677. (*------------------------------------*)
  1678. (*
  1679.   $  module  =  MODULE ident ";"  [ImportList]
  1680.   $    DeclarationSequence [BEGIN StatementSequence] END ident "." .
  1681.        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  1682.  
  1683.   $  ProcedureBody  =  DeclarationSequence [BEGIN StatementSequence] END.
  1684.                        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  1685.  
  1686.   $  DeclarationSequence  =  {CONST {ConstantDeclaration ";"} |
  1687.   $      TYPE {TypeDeclaration ";"} | VAR {VariableDeclaration ";"}}
  1688.   $      {ProcedureDeclaration ";" | ForwardDeclaration ";"}.
  1689. *)
  1690. PROCEDURE Block (
  1691.   proc : OCT.Object; VAR dsize : LONGINT; VAR retList : INTEGER);
  1692.  
  1693.   (* CONST pname = "Block"; *)
  1694.  
  1695.   VAR
  1696.     typ, forward : OCT.Struct;
  1697.     obj, first, last : OCT.Object;
  1698.     x : OCT.Item;
  1699.     L0 : INTEGER;
  1700.     adr, size : LONGINT;
  1701.     mk : SHORTINT;
  1702.     id0 : ARRAY 32 OF CHAR;
  1703.  
  1704. BEGIN (* Block *)
  1705.   (* OCG.TraceIn (mname, pname); *)
  1706.   (* Calculate base address of variables *)
  1707.   IF OCC.level = 0 THEN
  1708.     (* +ve offsets from module variable base *)
  1709.     adr := dsize;
  1710.   ELSE
  1711.     (* -ve offsets from frame pointer *)
  1712.     adr := -dsize;
  1713.   END;
  1714.  
  1715.   last := OCT.topScope.right;
  1716.   IF last # NIL THEN
  1717.     WHILE last.link # NIL DO last := last.link END;
  1718.   END;
  1719.  
  1720.   LOOP
  1721.     IF sym = const THEN (* Constant declaration(s) *)
  1722.       OCS.Get (sym);
  1723.       WHILE sym = ident DO
  1724.         COPY (OCS.name, id0); CheckMark (mk, FALSE);
  1725.         IF sym = eql THEN
  1726.           OCS.Get (sym); ConstExpression (x)
  1727.         ELSIF sym = becomes THEN
  1728.           OCS.Mark (9); OCS.Get (sym); ConstExpression (x)
  1729.         ELSE
  1730.           OCS.Mark (9)
  1731.         END;
  1732.  
  1733.         (* Enforce limitation on aliasing imported string constants *)
  1734.         IF (x.lev < 0) & (x.typ = OCT.stringtyp) & (x.a1 > 2) THEN
  1735.           OCS.Mark (323)
  1736.         END;
  1737.  
  1738.         (* Insert in symbol table *)
  1739.         OCT.Insert (id0, obj, SHORT (x.mode));
  1740.         obj.typ := x.typ; obj.a0 := x.a0; obj.a1 := x.a1; obj.a2 := x.a2;
  1741.         obj.visible := mk; obj.symbol := x.symbol;
  1742.  
  1743.         CheckSym (semicolon)
  1744.       END; (* WHILE *)
  1745.     END; (* IF *)
  1746.  
  1747.     IF sym = type THEN (* Type declaration(s) *)
  1748.       OCS.Get (sym);
  1749.       WHILE sym = ident DO
  1750.         (* Insert in symbol table *)
  1751.         typ := OCT.undftyp; OCT.Insert (OCS.name, obj, Typ);
  1752.         forward := obj.typ; obj.typ := OCT.notyp;
  1753.         CheckMark (obj.visible, FALSE);
  1754.  
  1755.         IF sym = eql THEN
  1756.           OCS.Get (sym); Type (typ);
  1757.         ELSIF (sym = becomes) OR (sym = colon) THEN
  1758.           OCS.Mark (9);
  1759.           OCS.Get (sym); Type (typ);
  1760.         ELSE
  1761.           OCS.Mark (9); typ := OCT.undftyp
  1762.         END;
  1763.         IF typ.form = DynArr THEN typ := OCT.undftyp; OCS.Mark (325) END;
  1764.  
  1765.         obj.typ := typ;
  1766.         IF typ.strobj = NIL THEN typ.strobj := obj END;
  1767.         IF forward # NIL THEN (* fixup *) SetPtrBase (forward, typ) END;
  1768.  
  1769.         CheckSym (semicolon);
  1770.       END; (* WHILE *)
  1771.     END; (* IF *)
  1772.  
  1773.     IF sym = var THEN (* Variable declarations *)
  1774.       (*IF (OCC.level = 0) & ~OCS.createObj THEN OCS.Mark (918) END;*)
  1775.       OCS.Get (sym);
  1776.       WHILE sym = ident DO
  1777.         (* Insert in symbol table *)
  1778.         OCT.Insert (OCS.name, obj, Var); CheckMark (obj.visible, TRUE);
  1779.         IF (obj # last) & (obj.link = NIL) THEN
  1780.           IF last = NIL THEN OCT.topScope.right := obj
  1781.           ELSE last.link := obj
  1782.           END;
  1783.           first := obj; last := obj
  1784.         END;
  1785.  
  1786.         LOOP (* Get identifier list *)
  1787.           IF sym = comma THEN     OCS.Get (sym)
  1788.           ELSIF sym = ident THEN  OCS.Mark (19)
  1789.           ELSE                    EXIT
  1790.           END;
  1791.           IF sym = ident THEN
  1792.             OCT.Insert (OCS.name, obj, Var); CheckMark (obj.visible, TRUE);
  1793.             IF (obj # last) & (obj.link = NIL) THEN
  1794.               last.link := obj; last := obj
  1795.             END
  1796.           ELSE
  1797.             OCS.Mark (10)
  1798.           END;
  1799.         END; (* LOOP *)
  1800.  
  1801.         (* Get type *)
  1802.         CheckSym (colon); Type (typ);
  1803.         IF typ.form = DynArr THEN typ := OCT.undftyp; OCS.Mark (325) END;
  1804.         size := typ.size;
  1805.         IF (size > 1) & ODD (size) THEN INC (size) END;
  1806.  
  1807.         (* Calculate variable addresses *)
  1808.         IF OCC.level = 0 THEN (* Global variable *)
  1809.           IF (size > 1) & ODD (adr) THEN INC (adr) END; (* Word align *)
  1810.           WHILE first # NIL DO
  1811.             first.typ := typ; first.a0 := adr; INC (adr, size);
  1812.             first := first.link
  1813.           END;
  1814.         ELSE                  (* Local procedure variable *)
  1815.           IF (size > 1) & ODD (adr) THEN DEC (adr) END; (* Word align *)
  1816.           WHILE first # NIL DO
  1817.             first.typ := typ; DEC (adr, size); first.a0 := adr;
  1818.             first := first.link
  1819.           END;
  1820.         END;
  1821.  
  1822.         CheckSym (semicolon);
  1823.       END; (* WHILE *)
  1824.     END; (* IF *)
  1825.     IF (sym < const) OR (sym > var) THEN EXIT END;
  1826.   END; (* LOOP *)
  1827.  
  1828.   CheckUndefPointerTypes ();
  1829.  
  1830.   WHILE sym = libcall DO (* Library call declarations *)
  1831.     OCS.Get (sym); LibCallDeclaration (); CheckSym (semicolon)
  1832.   END;
  1833.  
  1834.   WHILE sym = procedure DO (* Procedure declarations *)
  1835.     OCS.Get (sym); ProcedureDeclaration (); CheckSym (semicolon)
  1836.   END;
  1837.  
  1838.   CheckForwardProcs ();
  1839.  
  1840.   (* Calculate data size (rounded up to even value) *)
  1841.   IF OCC.level = 0 THEN dsize := adr
  1842.   ELSE                  dsize := -adr
  1843.   END;
  1844.   IF ODD (dsize) THEN INC (dsize) END;
  1845.  
  1846.   retList := 0; (* set up list of return branches *)
  1847.   IF OCC.level = 0 THEN OCH.StartModuleBody (dsize, retList) END;
  1848.   IF sym = begin THEN (* Main body of block *)
  1849.     (*IF (OCC.level <= 1) & ~OCS.createObj THEN OCS.Mark (919) END;*)
  1850.     IF OCC.level > 0 THEN OCH.StartProcBody (proc, dsize) END;
  1851.     OCS.Get (sym); StatSeq (retList);
  1852.   END;
  1853.  
  1854.   CheckSym (end);
  1855.   (* ;OCG.TraceOut (mname, pname); *)
  1856. END Block;
  1857.  
  1858. (*------------------------------------*)
  1859. (*
  1860.   $  module  =  MODULE ident ";"  [ImportList] DeclarationSequence
  1861.   $      [BEGIN StatementSequence] END ident "." .
  1862.   $  ImportList  =  IMPORT import {"," import} ";" .
  1863.   $  import  =  identdef [":" ident].
  1864. *)
  1865. PROCEDURE CompilationUnit * ( source : Files.File);
  1866.  
  1867.   (* CONST pname = "CompilationUnit"; *)
  1868.  
  1869.   VAR
  1870.     L0, retList : INTEGER; ch : CHAR;
  1871.     time, date, key, dsize : LONGINT;
  1872.     impid : ARRAY 32 OF CHAR;
  1873.     FName : ARRAY 256 OF CHAR;
  1874.  
  1875.   (*------------------------------------*)
  1876.   (* $D- disable copying of open arrays *)
  1877.   PROCEDURE MakeFileName (
  1878.     path, module, ext : ARRAY OF CHAR;
  1879.     VAR FName : ARRAY OF CHAR);
  1880.  
  1881.   BEGIN (* MakeFileName *)
  1882.     COPY (path, FName); Str.Append (FName, module); Str.Append (FName, ext)
  1883.   END MakeFileName;
  1884.  
  1885. BEGIN (* CompilationUnit *)
  1886.   (* OCG.TraceIn (mname, pname); *)
  1887.   procNo := 1; dsize := 0; LoopLevel := 0; ExitNo := 0;
  1888.   OCC.Init (); OCT.Init (); OCS.Init (source);
  1889.  
  1890.   REPEAT OCS.Get (sym) UNTIL (sym = eof) OR (sym = module);
  1891.   IF sym # module THEN
  1892.     IO.WriteStr (" !! Err #16: MODULE keyword not found\n");
  1893.     RETURN
  1894.   END;
  1895.  
  1896.   OCS.Get (sym);
  1897.   IF sym = ident THEN
  1898.     L0 := 0; ch := OCS.name [0];
  1899.     WHILE (ch # 0X) & (L0 < ModNameLen) DO
  1900.       OCT.ModuleName [L0] := ch; INC (L0); ch := OCS.name [L0];
  1901.     END;
  1902.     OCT.ModuleName [L0] := 0X;
  1903.     IF ch # 0X THEN OCS.Mark (334) END;
  1904.  
  1905.     OCS.StartModule (OCT.ModuleName); OCT.StartModule ();
  1906.     OCT.OpenScope (0);
  1907.  
  1908.     OCS.Get (sym); CheckSym (semicolon);
  1909.  
  1910.     OCS.allowGlobalSwitches := FALSE;
  1911.     OCH.ModulePrologue ();
  1912.  
  1913.     IF sym = import THEN
  1914.       OCS.Get (sym);
  1915.  
  1916.       LOOP
  1917.         IF sym = ident THEN
  1918.           COPY (OCS.name, impid);
  1919.           OCS.Get (sym);
  1920.           MakeFileName ("", impid, ".Sym", FName);
  1921.  
  1922.           IF sym = becomes THEN
  1923.             OCS.Get (sym);
  1924.             IF sym = ident THEN
  1925.               MakeFileName ("", OCS.name, ".Sym", FName);
  1926.               OCS.Get (sym);
  1927.             ELSE
  1928.               OCS.Mark (10);
  1929.             END;
  1930.           END;
  1931.  
  1932.           OCT.Import (impid, FName);
  1933.         ELSE
  1934.           OCS.Mark (10);
  1935.         END;
  1936.  
  1937.         IF sym = comma THEN     OCS.Get (sym);
  1938.         ELSIF sym = ident THEN  OCS.Mark (19);
  1939.         ELSE                    EXIT;
  1940.         END;
  1941.       END; (* LOOP *)
  1942.  
  1943.       CheckSym (semicolon);
  1944.     END; (* IF *)
  1945.  
  1946.     IF ~OCS.scanerr THEN
  1947.       Block (NIL, dsize, retList);
  1948.       OCH.EndModuleBody (retList);
  1949.  
  1950.       IF sym = ident THEN
  1951.         IF OCS.name # OCT.ModuleName THEN OCS.Mark (4) END;
  1952.         OCS.Get (sym);
  1953.       ELSE
  1954.         OCS.Mark (10);
  1955.       END;
  1956.  
  1957.       IF sym # period THEN OCS.Mark (18) END;
  1958.  
  1959.       IF ~OCS.scanerr OR forceCode THEN
  1960.         IF ~OCS.scanerr THEN
  1961.           Oberon.GetClock (time, date);
  1962.           key := (date MOD 4000H) * 20000H + time;
  1963.           MakeFileName ("", OCT.ModuleName, ".Sym", FName);
  1964.           OCT.Export (FName, newSF, key);
  1965.           IF newSF THEN
  1966.             MakeFileName (OCT.DestPath, OCT.ModuleName, ".Sym", FName);
  1967.             IO.WriteF1 (" >> New symbol file : %s\n", SYS.ADR (FName))
  1968.           END
  1969.         END;
  1970.         IF ~OCS.scanerr OR forceCode THEN
  1971.           MakeFileName (OCT.DestPath, OCT.ModuleName, ".Obj", FName);
  1972.           IO.WriteF1 (" >> Object file : %s\n", SYS.ADR (FName));
  1973.           OCC.OutCode (FName, key, dsize);
  1974.           IO.WriteF3
  1975.             ( "    CODE: %ld, DATA: %ld, VARS: %ld",
  1976.               LONG (OCC.pc), OCC.DataSize (), dsize);
  1977.           IO.WriteF1 (", TOTAL: %ld\n", OCC.pc + dsize + OCC.DataSize ())
  1978.         END;
  1979.       END; (* IF *)
  1980.     END; (* IF *)
  1981.     OCT.CloseScope ();
  1982.     OCT.EndModule (); OCS.EndModule ();
  1983.   ELSE
  1984.     IO.WriteStr (" !! Err #10: identifier expected after MODULE\n")
  1985.   END;
  1986.  
  1987.   IF OCS.scanerr THEN IO.WriteStr (" !! Errors detected\n") END;
  1988.   (* ;OCG.TraceOut (mname, pname); *)
  1989. END CompilationUnit;
  1990.  
  1991.  
  1992. BEGIN (* Compiler *)
  1993.   newSF := FALSE; forceCode := FALSE
  1994. END Compiler.
  1995.  
  1996. (***************************************************************************
  1997.  
  1998.   $Log: Compiler.mod $
  1999.   Revision 4.12  1994/08/19  20:02:03  fjc
  2000.   - Fixed bug in FormalParameters() which caused an infinite
  2001.     loop if a parameter name was declared twice.
  2002.  
  2003.   Revision 4.10  1994/07/25  00:54:09  fjc
  2004.   - Implemented check for parameter list limit.
  2005.  
  2006.   Revision 4.9  1994/07/24  00:31:02  fjc
  2007.   - Changed to using square brackets in register parameter
  2008.     declarations, in line with Oakwood guidelines.
  2009.  
  2010.   Revision 4.8  1994/07/23  16:07:02  fjc
  2011.   - Changed to allow A5 as a legal register parameter.
  2012.   - Changed to use new formats for OCC.SaveRegisters() and
  2013.     OCH.PrepCall().
  2014.  
  2015.   Revision 4.7  1994/07/22  14:23:06  fjc
  2016.   - Added code to parse foreign procedure declarations.
  2017.   - Changed to use new procedure names in OCH.
  2018.   - Fixed bug in register parameter declarations.
  2019.  
  2020.   Revision 4.6  1994/07/10  13:33:04  fjc
  2021.   - Commented out trace code.
  2022.   - Added check for unimplemented forward declared procedures.
  2023.  
  2024.   Revision 4.5  1994/06/17  17:39:00  fjc
  2025.   - Fixed stackload bug
  2026.  
  2027.   Revision 4.4  1994/06/10  12:50:39  fjc
  2028.   - Changed Factor() to concatenate string literals.
  2029.  
  2030.   Revision 4.3  1994/06/06  18:28:42  fjc
  2031.   - Implemented varargs for LibCall procedures:
  2032.     - Created VarArgs() to push the parameters in reverse order;
  2033.     - Modified ActualParameters() to call VarArgs();
  2034.     - Modified Factor() and StatSeq() to fix up stack afterwards;
  2035.     - Modified FormalParameters() to parse the new syntax.
  2036.  
  2037.   Revision 4.2  1994/06/05  22:31:46  fjc
  2038.   - Changed to conform to new symbol table format.
  2039.   - Added forceCode option.
  2040.  
  2041.   Revision 4.1  1994/06/01  09:33:44  fjc
  2042.   - Bumped version number
  2043.  
  2044. ***************************************************************************)
  2045.  
  2046.