home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / nonfpu / opb.mod (.txt) < prev    next >
Oberon Text  |  1977-12-31  |  56KB  |  1,517 lines
  1. Syntax24b.Scn.Fnt
  2. ParcElems
  3. Alloc
  4. Syntax10.Scn.Fnt
  5. (* Amiga NonFPU *) 
  6. MODULE OPB; (* RC 6.3.89 / 5.1.93 *)
  7. (* build parse tree *)
  8.  IMPORT OPT, OPS, OPM, AmigaMathL;
  9.  CONST
  10.   (* symbol values or ops *)
  11.   times = 1; slash = 2; div = 3; mod = 4;
  12.   and = 5; plus = 6; minus = 7; or = 8; eql = 9;
  13.   neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
  14.   in = 15; is = 16; ash = 17; msk = 18; len = 19;
  15.   conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
  16.   (*SYSTEM*)
  17.   adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
  18.   (* object modes *)
  19.   Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
  20.   SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
  21.   (* Structure forms *)
  22.   Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  23.   Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  24.   Pointer = 13; ProcTyp = 14; Comp = 15;
  25.   intSet = {SInt..LInt}; realSet = {Real, LReal};
  26.   (* composite structure forms *)
  27.   Basic = 1; Array = 2; DynArr = 3; Record = 4;
  28.   (* nodes classes *)
  29.   Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
  30.   Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
  31.   Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
  32.   Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
  33.   Nreturn = 26; Nwith = 27; Ntrap = 28;
  34.   (*function number*)
  35.   assign = 0;
  36.   haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
  37.   entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
  38.   shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
  39.   inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
  40.   (*SYSTEM function number*)
  41.   adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
  42.   getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
  43.   bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
  44.   (* module visibility of objects *)
  45.   internal = 0; external = 1; externalR = 2;
  46.   (* procedure flags (conval^.setval) *)
  47.   hasBody = 1; isRedef = 2; slNeeded = 3;
  48.   AssertTrap = 0; (* default trap number *)
  49.   typSize*: PROCEDURE(typ: OPT.Struct; allocDesc: BOOLEAN);
  50.   exp: INTEGER; (*side effect of log*)
  51.   maxExp: LONGINT; (* max n in ASH(1, n) on this machine *)
  52.  PROCEDURE err(n: INTEGER);
  53.  BEGIN OPM.err(n)
  54.  END err;
  55.  PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node;
  56.   VAR node: OPT.Node;
  57.  BEGIN
  58.   CASE obj^.mode OF
  59.     Var:
  60.     node := OPT.NewNode(Nvar); node^.readonly := (obj^.vis = externalR) & (obj^.mnolev < 0)
  61.   | VarPar:
  62.     node := OPT.NewNode(Nvarpar)
  63.   | Con:
  64.     node := OPT.NewNode(Nconst); node^.conval := OPT.NewConst();
  65.     node^.conval^ := obj^.conval^ (* string is not copied, only its ref *)
  66.   | Typ:
  67.     node := OPT.NewNode(Ntype)
  68.   | LProc..IProc:
  69.     node := OPT.NewNode(Nproc)
  70.   ELSE err(127); node := OPT.NewNode(Nvar)
  71.   END ;
  72.   node^.obj := obj; node^.typ := obj^.typ;
  73.   RETURN node
  74.  END NewLeaf;
  75.  PROCEDURE Construct*(class: SHORTINT; VAR x: OPT.Node;  y: OPT.Node);
  76.   VAR node: OPT.Node;
  77.  BEGIN
  78.   node := OPT.NewNode(class); node^.typ := OPT.notyp;
  79.   node^.left := x; node^.right := y; x := node
  80.  END Construct;
  81.  PROCEDURE Link*(VAR x, last: OPT.Node; y: OPT.Node);
  82.  BEGIN
  83.   IF x = NIL THEN x := y ELSE last^.link := y END ;
  84.   WHILE y^.link # NIL DO y := y^.link END ;
  85.   last := y
  86.  END Link;
  87.  PROCEDURE BoolToInt(b: BOOLEAN): LONGINT;
  88.  BEGIN
  89.   IF b THEN RETURN 1 ELSE RETURN 0 END
  90.  END BoolToInt;
  91.  PROCEDURE IntToBool(i: LONGINT): BOOLEAN;
  92.  BEGIN
  93.   IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
  94.  END IntToBool;
  95.  PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node;
  96.   VAR x: OPT.Node;
  97.  BEGIN
  98.   x := OPT.NewNode(Nconst); x^.typ := OPT.booltyp;
  99.   x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x
  100.  END NewBoolConst;
  101.  PROCEDURE OptIf*(VAR x: OPT.Node); (* x^.link = NIL *)
  102.   VAR if, pred: OPT.Node;
  103.  BEGIN
  104.   if := x^.left;
  105.   WHILE if^.left^.class = Nconst DO
  106.    IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN
  107.    ELSIF if^.link = NIL THEN x := x^.right; RETURN
  108.    ELSE if := if^.link; x^.left := if
  109.    END
  110.   END ;
  111.   pred := if; if := if^.link;
  112.   WHILE if # NIL DO
  113.    IF if^.left^.class = Nconst THEN
  114.     IF IntToBool(if^.left^.conval^.intval) THEN
  115.      pred^.link := NIL; x^.right := if^.right; RETURN
  116.     ELSE if := if^.link; pred^.link := if
  117.     END
  118.    ELSE pred := if; if := if^.link
  119.    END
  120.   END
  121.  END OptIf;
  122.  PROCEDURE Nil*(): OPT.Node;
  123.   VAR x: OPT.Node;
  124.  BEGIN
  125.   x := OPT.NewNode(Nconst); x^.typ := OPT.niltyp;
  126.   x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x
  127.  END Nil;
  128.  PROCEDURE EmptySet*(): OPT.Node;
  129.   VAR x: OPT.Node;
  130.  BEGIN
  131.   x := OPT.NewNode(Nconst); x^.typ := OPT.settyp;
  132.   x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x
  133.  END EmptySet;
  134.  PROCEDURE SetIntType(node: OPT.Node);
  135.   VAR v: LONGINT;
  136.  BEGIN v := node^.conval^.intval;
  137.   IF (OPM.MinSInt <= v) & (v <= OPM.MaxSInt) THEN node^.typ := OPT.sinttyp
  138.   ELSIF (OPM.MinInt <= v) & (v <= OPM.MaxInt) THEN node^.typ := OPT.inttyp
  139.   ELSIF (OPM.MinLInt <= v) & (v <= OPM.MaxLInt) (*bootstrap or cross*) THEN
  140.    node^.typ := OPT.linttyp
  141.   ELSE err(203); node^.typ := OPT.sinttyp; node^.conval^.intval := 1
  142.   END
  143.  END SetIntType;
  144.  PROCEDURE NewIntConst*(intval: LONGINT): OPT.Node;
  145.   VAR x: OPT.Node;
  146.  BEGIN
  147.   x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  148.   x^.conval^.intval := intval; SetIntType(x); RETURN x
  149.  END NewIntConst;
  150.  PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node;
  151.   VAR x: OPT.Node;
  152.  BEGIN
  153.   x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  154.   x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc;
  155.   RETURN x
  156.  END NewRealConst;
  157.  PROCEDURE NewString*(VAR str: OPS.String; len: LONGINT): OPT.Node;
  158.   VAR x: OPT.Node;
  159.  BEGIN
  160.   x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp;
  161.   x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := len;
  162.   x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str;
  163.   RETURN x
  164.  END NewString;
  165.  PROCEDURE CharToString(n: OPT.Node);
  166.   VAR ch: CHAR;
  167.  BEGIN
  168.   n^.typ := OPT.stringtyp; ch := CHR(n^.conval^.intval); n^.conval^.ext := OPT.NewExt();
  169.   IF ch = 0X THEN n^.conval^.intval2 := 1 ELSE n^.conval^.intval2 := 2; n^.conval^.ext[1] := 0X END ;
  170.   n^.conval^.ext[0] := ch; n^.conval^.intval := OPM.ConstNotAlloc; n^.obj := NIL
  171.  END CharToString;
  172.  PROCEDURE BindNodes(class: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node);
  173.   VAR node: OPT.Node;
  174.  BEGIN
  175.   node := OPT.NewNode(class); node^.typ := typ;
  176.   node^.left := x; node^.right := y; x := node
  177.  END BindNodes;
  178.  PROCEDURE NotVar(x: OPT.Node): BOOLEAN;
  179.  BEGIN RETURN (x^.class >= Nconst) & ((x^.class # Nmop) OR (x^.subcl # val) OR (x^.left^.class >= Nconst))
  180.  END NotVar;
  181.  PROCEDURE DeRef*(VAR x: OPT.Node);
  182.  BEGIN
  183.   IF x^.class >= Nconst THEN err(78)
  184.   ELSIF x^.typ^.form = Pointer THEN BindNodes(Nderef, x^.typ^.BaseTyp, x, NIL)
  185.   ELSE err(84)
  186.   END
  187.  END DeRef;
  188.  PROCEDURE Index*(VAR x: OPT.Node; y: OPT.Node);
  189.   VAR f: INTEGER; typ: OPT.Struct;
  190.  BEGIN
  191.   f := y^.typ^.form;
  192.   IF x^.class >= Nconst THEN err(79)
  193.   ELSIF ~(f IN intSet) THEN err(80); y^.typ := OPT.inttyp END ;
  194.   IF x^.typ^.comp = Array THEN typ := x^.typ^.BaseTyp;
  195.    IF (y^.class = Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END
  196.   ELSIF x^.typ^.comp = DynArr THEN typ := x^.typ^.BaseTyp;
  197.    IF (y^.class = Nconst) & (y^.conval^.intval < 0) THEN err(81) END
  198.   ELSE err(82); typ := OPT.undftyp
  199.   END ;
  200.   BindNodes(Nindex, typ, x, y); x^.readonly := x^.left^.readonly
  201.  END Index;
  202.  PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object);
  203.  BEGIN (*x^.typ^.comp = Record*)
  204.   IF x^.class >= Nconst THEN err(77)
  205.   ELSIF (y # NIL) & (y^.mode IN {Fld, TProc}) THEN
  206.    BindNodes(Nfield, y^.typ, x, NIL); x^.obj := y;
  207.    x^.readonly := x^.left^.readonly OR ((y^.vis = externalR) & (y^.mnolev < 0))
  208.   ELSE err(83); x^.typ := OPT.undftyp
  209.   END
  210.  END Field;
  211.   PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN);
  212.     PROCEDURE GTT(t0, t1: OPT.Struct);
  213.       VAR node: OPT.Node; t: OPT.Struct;
  214.     BEGIN t := t0;
  215.       WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ;
  216.       IF t # t1 THEN
  217.         WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 :=
  218. t1^.BaseTyp END ;
  219.         IF t1 = t0 THEN
  220.           IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly :=
  221. x^.left^.readonly
  222.           ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  223.             node^.obj := obj; x := node
  224.           END
  225.         ELSE err(85)
  226.         END
  227.         ELSIF t0 # t1 THEN err(85)    (* prevent down guard *)
  228.       ELSIF ~guard THEN
  229.         IF x^.class = Nguard THEN  (* cannot skip guard *)
  230.           node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  231.           node^.obj := obj; x := node
  232.         ELSE x := NewBoolConst(TRUE)
  233.         END
  234.       END
  235.     END GTT;
  236.   BEGIN
  237.     IF NotVar(x) THEN err(112)
  238.     ELSIF x^.typ^.form = Pointer THEN
  239.       IF x^.typ^.BaseTyp^.comp # Record THEN err(85)
  240.       ELSIF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp,
  241. obj^.typ^.BaseTyp)
  242.       ELSE err(86)
  243.       END
  244.     ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp =
  245. Record) THEN
  246.       GTT(x^.typ, obj^.typ)
  247.     ELSE err(87)
  248.     END ;
  249.     IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END
  250.   END TypTest;
  251.  PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node);
  252.   VAR f: INTEGER; k: LONGINT;
  253.  BEGIN f := x^.typ^.form;
  254.   IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  255.   ELSIF (f IN intSet) & (y^.typ^.form = Set) THEN
  256.    IF x^.class = Nconst THEN
  257.     k := x^.conval^.intval;
  258.     IF (k < 0) OR (k > OPM.MaxSet) THEN err(202)
  259.     ELSIF y^.class = Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL
  260.     ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  261.     END
  262.    ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  263.    END
  264.   ELSE err(92)
  265.   END ;
  266.   x^.typ := OPT.booltyp
  267.  END In;
  268.  PROCEDURE log(x: LONGINT): LONGINT;
  269.  BEGIN exp := 0;
  270.   IF x > 0 THEN
  271.    WHILE ~ODD(x) DO x := x DIV 2; INC(exp) END
  272.   END ;
  273.   RETURN x
  274.  END log;
  275.  PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const);
  276.   VAR min, max, r: LONGREAL;Dummy: REAL;
  277.  BEGIN
  278.   IF f = Real THEN 
  279.       AmigaMathL.Long(OPM.MinReal,min);(* min := OPM.MinReal; *)
  280.       AmigaMathL.Long(OPM.MaxReal,max);(* max := OPM.MaxReal; *)
  281.   ELSE min := OPM.MinLReal; max := OPM.MaxLReal
  282.   END ;
  283.   AmigaMathL.Abs(x^.realval,r);
  284. (*  r := ABS(x^.realval);*)
  285.   IF (AmigaMathL.Cmp(r,max)>0) OR (AmigaMathL.Cmp(r,min)<0) THEN
  286. (*  IF (r > max) OR (r < min) THEN*)
  287.     err(nr); x^.realval := 1(*.0*)
  288.   ELSIF f = Real THEN
  289.    AmigaMathL.Short(x^.realval, Dummy);
  290.    AmigaMathL.Long(Dummy, x^.realval);
  291. (*   x^.realval := SHORT(x^.realval) (* single precision only *)*)
  292.   END ;
  293.   x^.intval := OPM.ConstNotAlloc
  294.  END CheckRealType;
  295.  PROCEDURE MOp*(op: SHORTINT; VAR x: OPT.Node);
  296.   VAR f: INTEGER; typ: OPT.Struct;
  297.   PROCEDURE NewOp;
  298.    VAR node: OPT.Node;
  299.   BEGIN
  300.    node := OPT.NewNode(Nmop); node^.subcl := op; node^.typ := typ;
  301.    node^.left := x; x := node
  302.   END NewOp;
  303.  BEGIN
  304.   IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  305.   ELSE typ := x^.typ; f := typ^.form;
  306.    CASE op OF
  307.      not:
  308.      IF f = Bool THEN
  309.       IF x^.class = Nconst THEN
  310.        x^.conval^.intval := BoolToInt(~IntToBool(x^.conval^.intval)); x^.obj := NIL
  311.       ELSE NewOp
  312.       END
  313.      ELSE err(98)
  314.      END
  315.    | plus:
  316.      IF ~(f IN intSet + realSet) THEN err(96) END
  317.    | minus:
  318.      IF f IN intSet + realSet +{Set}THEN
  319.       IF x^.class = Nconst THEN
  320.        IF f IN intSet THEN
  321.         IF x^.conval^.intval = MIN(LONGINT) THEN err(203)
  322.         ELSE x^.conval^.intval := -x^.conval^.intval; SetIntType(x)
  323.         END
  324.        ELSIF f IN realSet THEN
  325.         AmigaMathL.Neg(x^.conval^.realval, x^.conval^.realval);
  326.         (* x^.conval^.realval := -x^.conval^.realval *)
  327.        ELSE x^.conval^.setval := -x^.conval^.setval
  328.        END ;
  329.        x^.obj := NIL
  330.       ELSE NewOp
  331.       END
  332.      ELSE err(97)
  333.      END
  334.    | abs:
  335.      IF f IN intSet + realSet THEN
  336.       IF x^.class = Nconst THEN
  337.        IF f IN intSet THEN
  338.         IF x^.conval^.intval = MIN(LONGINT) THEN err(203)
  339.         ELSE x^.conval^.intval := ABS(x^.conval^.intval); SetIntType(x)
  340.         END
  341.        ELSE 
  342.         AmigaMathL.Abs(x^.conval^.realval, x^.conval^.realval);
  343.         (* x^.conval^.realval := ABS(x^.conval^.realval) *)
  344.        END ;
  345.        x^.obj := NIL
  346.       ELSE NewOp
  347.       END
  348.      ELSE err(111)
  349.      END
  350.    | cap:
  351.      IF f = Char THEN
  352.       IF x^.class = Nconst THEN
  353.        x^.conval^.intval := ORD(CAP(CHR(x^.conval^.intval))); x^.obj := NIL
  354.       ELSE NewOp
  355.       END
  356.      ELSE err(111); x^.typ := OPT.chartyp
  357.      END
  358.    | odd:
  359.      IF f IN intSet THEN
  360.       IF x^.class = Nconst THEN
  361.        x^.conval^.intval := BoolToInt(ODD(x^.conval^.intval)); x^.obj := NIL
  362.       ELSE NewOp
  363.       END
  364.      ELSE err(111)
  365.      END ;
  366.      x^.typ := OPT.booltyp
  367.    | adr: (*SYSTEM.ADR*)
  368.      IF (x^.class < Nconst) OR (f = String) THEN NewOp
  369.      ELSE err(127)
  370.      END ;
  371.      x^.typ := OPT.linttyp
  372.    | cc: (*SYSTEM.CC*)
  373.      IF (f IN intSet) & (x^.class = Nconst) THEN
  374.       IF (0 <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxCC) THEN NewOp ELSE err(219) END
  375.      ELSE err(69)
  376.      END ;
  377.      x^.typ := OPT.booltyp
  378.    END
  379.   END
  380.  END MOp;
  381.  PROCEDURE CheckPtr(x, y: OPT.Node);
  382.   VAR g: INTEGER; p, q, t: OPT.Struct;
  383.  BEGIN g := y^.typ^.form;
  384.   IF g = Pointer THEN
  385.    p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp;
  386.    IF (p^.comp = Record) & (q^.comp = Record) THEN
  387.     IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ;
  388.     WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ;
  389.     IF p = NIL THEN err(100) END
  390.    ELSE err(100)
  391.    END
  392.   ELSIF g # NilTyp THEN err(100)
  393.   END
  394.  END CheckPtr;
  395.  PROCEDURE CheckParameters*(fp, ap: OPT.Object; checkNames: BOOLEAN);
  396.   VAR ft, at: OPT.Struct;
  397.  BEGIN
  398.   WHILE fp # NIL DO
  399.    IF ap # NIL THEN
  400.     ft := fp^.typ; at := ap^.typ;
  401.     WHILE (ft^.comp = DynArr) & (at^.comp = DynArr) DO
  402.      ft := ft^.BaseTyp; at := at^.BaseTyp
  403.     END ;
  404.     IF ft # at THEN
  405.      IF (ft^.form = ProcTyp) & (at^.form = ProcTyp) THEN
  406.       IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.BaseTyp^.link, at^.BaseTyp^.link, FALSE)
  407.       ELSE err(117)
  408.       END
  409.      ELSE err(115)
  410.      END
  411.     END ;
  412.     IF (fp^.mode # ap^.mode) OR checkNames & (fp^.name # ap^.name) THEN err(115) END ;
  413.     ap := ap^.link
  414.    ELSE err(116)
  415.    END ;
  416.    fp := fp^.link
  417.   END ;
  418.   IF ap # NIL THEN err(116) END
  419.  END CheckParameters;
  420.  PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object); (* proc var x := proc y, check compatibility *)
  421.  BEGIN
  422.   IF y^.mode IN {XProc, IProc, LProc} THEN
  423.    IF y^.mode = LProc THEN
  424.     IF y^.mnolev = 0 THEN y^.mode := XProc
  425.     ELSE err(73)
  426.     END
  427.    END ;
  428.    IF x^.BaseTyp = y^.typ THEN CheckParameters(x^.link, y^.link, FALSE)
  429.    ELSE err(117)
  430.    END
  431.   ELSE err(113)
  432.   END
  433.  END CheckProc;
  434.  PROCEDURE ConstOp(op: INTEGER; x, y: OPT.Node);
  435.   VAR f, g: INTEGER; xval, yval: OPT.Const; xv, yv: LONGINT;
  436.     temp: BOOLEAN; (* temp avoids err 215 *)
  437.     LDummy, xAbs, yAbs: LONGREAL;
  438.   PROCEDURE ConstCmp(): INTEGER;
  439.    VAR res: INTEGER;
  440.   BEGIN
  441.    CASE f OF
  442.      Undef:
  443.      res := eql
  444.    | Byte, Char..LInt:
  445.      IF xval^.intval < yval^.intval THEN res := lss
  446.      ELSIF xval^.intval > yval^.intval THEN res := gtr
  447.      ELSE res := eql
  448.      END
  449.    | Real, LReal:
  450.      IF AmigaMathL.Cmp(xval^.realval, yval^.realval)<0 THEN res := lss
  451.      ELSIF AmigaMathL.Cmp(xval^.realval, yval^.realval)>0 THEN res := gtr
  452.      ELSE res := eql
  453.      END
  454. (*     IF xval^.realval < yval^.realval THEN res := lss
  455.      ELSIF xval^.realval > yval^.realval THEN res := gtr
  456.      ELSE res := eql
  457.      END *)
  458.    | Bool:
  459.      IF xval^.intval # yval^.intval THEN res := neq
  460.      ELSE res := eql
  461.      END
  462.    | Set:
  463.      IF xval^.setval # yval^.setval THEN res := neq
  464.      ELSE res := eql
  465.      END
  466.    | String:
  467.      IF xval^.ext^ < yval^.ext^ THEN res := lss
  468.      ELSIF xval^.ext^ > yval^.ext^ THEN res := gtr
  469.      ELSE res := eql
  470.      END
  471.    | NilTyp, Pointer, ProcTyp:
  472.      IF xval^.intval # yval^.intval THEN res := neq
  473.      ELSE res := eql
  474.      END
  475.    END ;
  476.    x^.typ := OPT.booltyp; RETURN res
  477.   END ConstCmp;
  478.  BEGIN
  479.   f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval;
  480.   IF f # g THEN
  481.    CASE f OF
  482.      Char:
  483.      IF g = String THEN CharToString(x)
  484.      ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  485.      END ;
  486.    | SInt:
  487.      IF g IN intSet THEN x^.typ := y^.typ
  488.      ELSIF g = Real THEN
  489.       x^.typ := OPT.realtyp;
  490.       AmigaMathL.IntToReal(xval^.intval, xval^.realval); (*xval^.realval := xval^.intval*)
  491.      ELSIF g = LReal THEN
  492.       x^.typ := OPT.lrltyp;
  493.       AmigaMathL.IntToReal(xval^.intval, xval^.realval); (*xval^.realval := xval^.intval*)
  494.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  495.      END
  496.    | Int:
  497.      IF g = SInt THEN y^.typ := OPT.inttyp
  498.      ELSIF g IN intSet THEN x^.typ := y^.typ
  499.      ELSIF g = Real THEN x^.typ := OPT.realtyp;
  500.       AmigaMathL.IntToReal(xval^.intval, xval^.realval); (*xval^.realval := xval^.intval*)
  501.      ELSIF g = LReal THEN x^.typ := OPT.lrltyp;
  502.       AmigaMathL.IntToReal(xval^.intval, xval^.realval); (*xval^.realval := xval^.intval*)
  503.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  504.      END
  505.    | LInt:
  506.      IF g IN intSet THEN y^.typ := OPT.linttyp
  507.      ELSIF g = Real THEN x^.typ := OPT.realtyp;
  508.       AmigaMathL.IntToReal(xval^.intval, xval^.realval); (*xval^.realval := xval^.intval*)
  509.      ELSIF g = LReal THEN x^.typ := OPT.lrltyp;
  510.       AmigaMathL.IntToReal(xval^.intval, xval^.realval); (*xval^.realval := xval^.intval*)
  511.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  512.      END
  513.    | Real:
  514.      IF g IN intSet THEN y^.typ := x^.typ;
  515.       AmigaMathL.IntToReal(yval^.intval, yval^.realval); (*yval^.realval := yval^.intval*)
  516.      ELSIF g = LReal THEN x^.typ := OPT.lrltyp
  517.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  518.      END
  519.    | LReal:
  520.      IF g IN intSet THEN y^.typ := x^.typ;
  521.       AmigaMathL.IntToReal(yval^.intval, yval^.realval); (*yval^.realval := yval^.intval*)
  522.      ELSIF g = Real THEN y^.typ := OPT.lrltyp
  523.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  524.      END
  525.    | String:
  526.      IF g = Char THEN CharToString(y); g := String
  527.      ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  528.      END ;
  529.    | NilTyp:
  530.      IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  531.    | Pointer:
  532.      CheckPtr(x, y)
  533.    | ProcTyp:
  534.      IF g # NilTyp THEN err(100) END
  535.    ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  536.    END ;
  537.    f := x^.typ^.form
  538.   END ; (* {x^.typ = y^.typ} *)
  539.   CASE op OF
  540.     times:
  541.     IF f IN intSet THEN xv := xval^.intval; yv := yval^.intval;
  542.      IF (xv = 0) OR (yv = 0) OR (* division with negative numbers is not defined *)
  543.       (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR
  544.       (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR
  545.       (xv < 0) & (yv > 0) & (xv >= MIN(LONGINT) DIV yv) OR
  546.       (xv < 0) & (yv < 0) & (xv # MIN(LONGINT)) & (yv # MIN(LONGINT)) & (-xv <= MAX(LONGINT) DIV (-yv)) THEN
  547.       xval^.intval := xv * yv; SetIntType(x)
  548.      ELSE err(204)
  549.      END
  550.     ELSIF f IN realSet THEN
  551.      AmigaMathL.Abs(yval^.realval, yAbs);AmigaMathL.Abs(xval^.realval, xAbs);
  552.      temp:=AmigaMathL.Cmp(yAbs, 1) <= 0;
  553.      AmigaMathL.Div(MAX(LONGREAL), yAbs, LDummy);
  554.      IF temp OR (AmigaMathL.Cmp(xAbs, LDummy) <= 0) THEN
  555.      (* temp := ABS(yval^.realval) <= 1(*.0*);
  556.      IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN*)
  557.       AmigaMathL.Mul(xval^.realval, yval^.realval, xval^.realval);
  558.       (* xval^.realval := xval^.realval * yval^.realval; *)
  559.       CheckRealType(f, 204, xval)
  560.      ELSE err(204)
  561.      END
  562.     ELSIF f = Set THEN
  563.       xval^.setval := xval^.setval * yval^.setval
  564.     ELSIF f # Undef THEN err(101)
  565.     END
  566.   | slash:
  567.     IF f IN intSet THEN
  568.      IF yval^.intval # 0 THEN
  569.       AmigaMathL.IntToReal(xval^.intval, xAbs);
  570.       AmigaMathL.IntToReal(yval^.intval, yAbs);
  571.       AmigaMathL.Div(xAbs, yAbs, xval^.realval);
  572.       (* xval^.realval := xval^.intval / yval^.intval; *)
  573.       CheckRealType(Real, 205, xval)
  574.      ELSE err(205); AmigaMathL.IntToReal(1, xval^.realval); (*xval^.realval := 1(*.0*)*)
  575.      END ;
  576.      x^.typ := OPT.realtyp
  577.     ELSIF f IN realSet THEN
  578.      AmigaMathL.Abs(yval^.realval, yAbs);AmigaMathL.Abs(xval^.realval, xAbs);
  579.      temp:=AmigaMathL.Cmp(yAbs, 1) >= 0;  (* !?!?! *)
  580.      AmigaMathL.Mul(MAX(LONGREAL), yAbs, LDummy);
  581.      IF temp OR (AmigaMathL.Cmp(xAbs, LDummy) <= 0) THEN
  582.      (* temp := ABS(yval^.realval) >= 1(*.0*);
  583.      IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN*)
  584.       AmigaMathL.Div(xval^.realval, yval^.realval, xval^.realval);
  585.       (* xval^.realval := xval^.realval / yval^.realval; *)
  586.       CheckRealType(f, 205, xval)
  587.      ELSE err(205)
  588.      END
  589.     ELSIF f = Set THEN
  590.      xval^.setval := xval^.setval / yval^.setval
  591.     ELSIF f # Undef THEN err(102)
  592.     END
  593.   | div:
  594.     IF f IN intSet THEN
  595.      IF yval^.intval # 0 THEN
  596.       xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x)
  597.      ELSE err(205)
  598.      END
  599.     ELSIF f # Undef THEN err(103)
  600.     END
  601.   | mod:
  602.     IF f IN intSet THEN
  603.      IF yval^.intval # 0 THEN
  604.       xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x)
  605.      ELSE err(205)
  606.      END
  607.     ELSIF f # Undef THEN err(104)
  608.     END
  609.   | and:
  610.     IF f = Bool THEN
  611.      xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval))
  612.     ELSE err(94)
  613.     END
  614.   | plus:
  615.     IF f IN intSet THEN
  616.      temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval);
  617.      IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN
  618.        INC(xval^.intval, yval^.intval); SetIntType(x)
  619.      ELSE err(206)
  620.      END
  621.     ELSIF f IN realSet THEN
  622.      AmigaMathL.Sub(MAX(LONGREAL), yval^.realval, LDummy);
  623.      temp := (AmigaMathL.Tst(yval^.realval) >= 0) & (AmigaMathL.Cmp(xval^.realval, LDummy) <= 0);
  624.      AmigaMathL.Sub(-MAX(LONGREAL), yval^.realval, LDummy);
  625.      IF temp OR (AmigaMathL.Tst(yval^.realval) < 0 ) & (AmigaMathL.Cmp(xval^.realval, LDummy) >= 0) THEN
  626.      (* temp := (yval^.realval >= 0(*.0*)) & (xval^.realval <= MAX(LONGREAL) - yval^.realval);
  627.      IF temp OR (yval^.realval < 0(*.0*)) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN*) 
  628.        AmigaMathL.Add(xval^.realval, yval^.realval, xval^.realval); CheckRealType(f, 206, xval)
  629.        (* xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval) *)
  630.      ELSE err(206)
  631.      END
  632.     ELSIF f = Set THEN
  633.      xval^.setval := xval^.setval + yval^.setval
  634.     ELSIF f # Undef THEN err(105)
  635.     END
  636.   | minus:
  637.     IF f IN intSet THEN
  638.      IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR
  639.       (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN
  640.        DEC(xval^.intval, yval^.intval); SetIntType(x)
  641.      ELSE err(207)
  642.      END
  643.     ELSIF f IN realSet THEN
  644.      AmigaMathL.Add(-MAX(LONGREAL), yval^.realval, LDummy);
  645.      temp := (AmigaMathL.Tst(yval^.realval) >= 0) & (AmigaMathL.Cmp(xval^.realval, LDummy) >= 0);
  646.      AmigaMathL.Add(MAX(LONGREAL), yval^.realval, LDummy);
  647.      IF temp OR (AmigaMathL.Tst(yval^.realval) < 0) & (AmigaMathL.Cmp(xval^.realval, LDummy) <= 0) THEN
  648.      (* temp := (yval^.realval >= 0(*.0*)) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval);
  649.      IF temp OR (yval^.realval < 0(*.0*)) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN *)
  650.        AmigaMathL.Sub(xval^.realval, yval^.realval, xval^.realval); CheckRealType(f, 207, xval)
  651.        (* xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval) *)
  652.      ELSE err(207)
  653.      END
  654.     ELSIF f = Set THEN
  655.      xval^.setval := xval^.setval - yval^.setval
  656.     ELSIF f # Undef THEN err(106)
  657.     END
  658.   | or:
  659.     IF f = Bool THEN
  660.      xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval))
  661.     ELSE err(95)
  662.     END
  663.   | eql:
  664.     xval^.intval := BoolToInt(ConstCmp() = eql)
  665.   | neq:
  666.     xval^.intval := BoolToInt(ConstCmp() # eql)
  667.   | lss:
  668.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  669.     ELSE xval^.intval := BoolToInt(ConstCmp() = lss)
  670.     END
  671.   | leq:
  672.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  673.     ELSE xval^.intval := BoolToInt(ConstCmp() # gtr)
  674.     END
  675.   | gtr:
  676.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  677.     ELSE xval^.intval := BoolToInt(ConstCmp() = gtr)
  678.     END
  679.   | geq:
  680.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  681.     ELSE xval^.intval := BoolToInt(ConstCmp() # lss)
  682.     END
  683.   END
  684.  END ConstOp;
  685.  PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct);
  686.   VAR node: OPT.Node; f, g: INTEGER; k: LONGINT; r: LONGREAL; Max, Min: LONGREAL;
  687.  BEGIN f := x^.typ^.form; g := typ^.form;
  688.   IF x^.class = Nconst THEN
  689.    IF f IN intSet THEN
  690.     IF g IN intSet THEN
  691.      IF f > g THEN SetIntType(x);
  692.       IF x^.typ^.form > g THEN err(203); x^.conval^.intval := 1 END
  693.      END
  694.     ELSIF g IN realSet THEN
  695.      AmigaMathL.IntToReal(x^.conval^.intval, x^.conval^.realval);
  696.      (* x^.conval^.realval := x^.conval^.intval; *)
  697.      x^.conval^.intval := OPM.ConstNotAlloc
  698.     ELSE (*g = Char*) k := x^.conval^.intval;
  699.      IF (0 > k) OR (k > 0FFH) THEN err(220) END
  700.     END
  701.    ELSIF f IN realSet THEN
  702.     IF g IN realSet THEN CheckRealType(g, 203, x^.conval)
  703.     ELSE (*g = LInt*)
  704.      r := x^.conval^.realval;
  705.      AmigaMathL.IntToReal(MIN(LONGINT), Min);
  706.      AmigaMathL.IntToReal(MAX(LONGINT), Max);
  707.      IF (AmigaMathL.Cmp(r, Min) < 0) OR (AmigaMathL.Cmp(r, Max) > 0) THEN err(203); r := 1 END ;
  708.      (* IF (r < MIN(LONGINT)) OR (r > MAX(LONGINT)) THEN err(203); r := 1 END ;*)
  709.      x^.conval^.intval := AmigaMathL.Entier(r); SetIntType(x)
  710.      (* x^.conval^.intval := ENTIER(r); SetIntType(x) *)
  711.     END
  712.    ELSE (* (f IN {Char, Byte}) & (g IN {Byte} + intSet) OR (f = Undef) *)
  713.    END ;
  714.    x^.obj := NIL
  715.   ELSIF (x^.class = Nmop) & (x^.subcl = conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN
  716.    (* don't create new node *)
  717.    IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END
  718.   ELSE node := OPT.NewNode(Nmop); node^.subcl := conv; node^.left := x; x := node
  719.   END ;
  720.   x^.typ := typ
  721.  END Convert;
  722.  PROCEDURE Op*(op: SHORTINT; VAR x: OPT.Node; y: OPT.Node);
  723.   VAR f, g: INTEGER; t: OPT.Node; typ: OPT.Struct; do: BOOLEAN; val: LONGINT;
  724.   PROCEDURE NewOp;
  725.    VAR node: OPT.Node;
  726.   BEGIN
  727.    node := OPT.NewNode(Ndop); node^.subcl := op; node^.typ := typ;
  728.    node^.left := x; node^.right := y; x := node
  729.   END NewOp;
  730.   PROCEDURE strings(): BOOLEAN;
  731.    VAR ok, xCharArr, yCharArr: BOOLEAN;
  732.   BEGIN
  733.    xCharArr := ((x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form=Char)) OR (f=String);
  734.    yCharArr := (((y^.typ^.comp IN {Array, DynArr}) & (y^.typ^.BaseTyp^.form=Char)) OR (g=String));
  735.    IF xCharArr & (g = Char) & (y^.class = Nconst) THEN CharToString(y); g := String; yCharArr := TRUE END ;
  736.    IF yCharArr & (f = Char) & (x^.class = Nconst) THEN CharToString(x); f := String; xCharArr := TRUE END ;
  737.    ok := xCharArr & yCharArr;
  738.    IF ok THEN (* replace ""-string compare with 0X-char compare, if possible *)
  739.     IF (f=String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *)
  740.      x^.typ := OPT.chartyp; x^.conval^.intval := 0;
  741.      Index(y, NewIntConst(0))
  742.     ELSIF (g=String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *)
  743.      y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  744.      Index(x, NewIntConst(0))
  745.     END
  746.    END ;
  747.    RETURN ok
  748.   END strings;
  749.  BEGIN
  750.   IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  751.   ELSIF (x^.class = Nconst) & (y^.class = Nconst) THEN ConstOp(op, x, y); x^.obj := NIL
  752.   ELSE
  753.    IF x^.typ # y^.typ THEN
  754.     g := y^.typ^.form;
  755.     CASE x^.typ^.form OF
  756.        SInt:
  757.       IF g IN intSet + realSet THEN Convert(x, y^.typ)
  758.       ELSE  err(100)
  759.       END
  760.     | Int:
  761.       IF g = SInt THEN Convert(y, x^.typ)
  762.       ELSIF g IN intSet + realSet THEN Convert(x, y^.typ)
  763.       ELSE  err(100)
  764.       END
  765.     | LInt:
  766.       IF g IN intSet THEN Convert(y, x^.typ)
  767.       ELSIF g IN realSet THEN Convert(x, y^.typ)
  768.       ELSE  err(100)
  769.       END
  770.     | Real:
  771.       IF g IN intSet THEN Convert(y, x^.typ)
  772.       ELSIF g IN realSet THEN Convert(x, y^.typ)
  773.       ELSE  err(100)
  774.       END
  775.     | LReal:
  776.       IF g IN intSet + realSet THEN Convert(y, x^.typ)
  777.       ELSIF g IN realSet THEN Convert(y, x^.typ)
  778.       ELSE  err(100)
  779.       END
  780.     | NilTyp:
  781.       IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  782.     | Pointer:
  783.       CheckPtr(x, y)
  784.     | ProcTyp:
  785.       IF g # NilTyp THEN err(100) END
  786.     | String:
  787.     | Comp:
  788.       IF x^.typ^.comp = Record THEN err(100) END
  789.     ELSE err(100)
  790.     END
  791.    END ; (* {x^.typ = y^.typ} *)
  792.    typ := x^.typ; f := typ^.form; g := y^.typ^.form;
  793.    CASE op OF
  794.      times:
  795.      do := TRUE;
  796.      IF f IN intSet THEN
  797.       IF x^.class = Nconst THEN val := x^.conval^.intval;
  798.        IF val = 1 THEN do := FALSE; x := y
  799.        ELSIF val = 0 THEN do := FALSE
  800.        ELSIF log(val) = 1 THEN
  801.         t := y; y := x; x := t;
  802.         op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  803.        END
  804.       ELSIF y^.class = Nconst THEN val := y^.conval^.intval;
  805.        IF val = 1 THEN do := FALSE
  806.        ELSIF val = 0 THEN do := FALSE; x := y
  807.        ELSIF log(val) = 1 THEN
  808.         op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  809.        END
  810.       END
  811.      ELSIF ~(f IN {Undef, Real..Set}) THEN err(105); typ := OPT.undftyp
  812.      END ;
  813.      IF do THEN NewOp END
  814.    | slash:
  815.      IF f IN intSet THEN
  816.       IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN err(205) END ;
  817.       Convert(x, OPT.realtyp); Convert(y, OPT.realtyp);
  818.       typ := OPT.realtyp
  819.      ELSIF f IN realSet THEN
  820.       IF (y^.class = Nconst) & (AmigaMathL.Tst(y^.conval^.realval) = 0) THEN err(205) END
  821.       (* IF (y^.class = Nconst) & (y^.conval^.realval = 0(*.0*)) THEN err(205) END*)
  822.      ELSIF (f # Set) & (f # Undef) THEN err(102); typ := OPT.undftyp
  823.      END ;
  824.      NewOp
  825.    | div:
  826.      do := TRUE;
  827.      IF f IN intSet THEN
  828.       IF y^.class = Nconst THEN val := y^.conval^.intval;
  829.        IF val = 0 THEN err(205)
  830.        ELSIF val = 1 THEN do := FALSE
  831.        ELSIF log(val) = 1 THEN
  832.         op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL
  833.        END
  834.       END
  835.      ELSIF f # Undef THEN err(103); typ := OPT.undftyp
  836.      END ;
  837.      IF do THEN NewOp END
  838.    | mod:
  839.      IF f IN intSet THEN
  840.       IF y^.class = Nconst THEN
  841.        IF y^.conval^.intval = 0 THEN err(205)
  842.        ELSIF log(y^.conval^.intval) = 1 THEN
  843.         op := msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL
  844.        END
  845.       END
  846.      ELSIF f # Undef THEN err(104); typ := OPT.undftyp
  847.      END ;
  848.      NewOp
  849.    | and:
  850.      IF f = Bool THEN
  851.       IF x^.class = Nconst THEN
  852.        IF IntToBool(x^.conval^.intval) THEN x := y END
  853.       ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize x & TRUE -> x *)
  854.     (* ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN
  855.        don't optimize x & FALSE -> FALSE: side effects possible *)
  856.       ELSE NewOp
  857.       END
  858.      ELSIF f # Undef THEN err(94); x^.typ := OPT.undftyp
  859.      END
  860.    | plus:
  861.      IF ~(f IN {Undef, SInt..Set}) THEN err(105); typ := OPT.undftyp END ;
  862.      do := TRUE;
  863.      IF f IN intSet THEN
  864.       IF (x^.class = Nconst) & (x^.conval^.intval = 0) THEN do := FALSE; x := y END ;
  865.       IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END
  866.      END ;
  867.      IF do THEN NewOp END
  868.    | minus:
  869.      IF ~(f IN {Undef, SInt..Set}) THEN err(106); typ := OPT.undftyp END ;
  870.      IF ~(f IN intSet) OR (y^.class # Nconst) OR (y^.conval^.intval # 0) THEN NewOp END
  871.    | or:
  872.      IF f = Bool THEN
  873.       IF x^.class = Nconst THEN
  874.        IF ~IntToBool(x^.conval^.intval) THEN x := y END
  875.       ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize x OR FALSE -> x *)
  876.     (* ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN
  877.        don't optimize x OR TRUE -> TRUE: side effects possible *)
  878.       ELSE NewOp
  879.       END
  880.      ELSIF f # Undef THEN err(95); x^.typ := OPT.undftyp
  881.      END
  882.    | eql, neq:
  883.      IF (f IN {Undef..Set, NilTyp, Pointer, ProcTyp}) OR strings() THEN typ := OPT.booltyp
  884.      ELSE err(107); typ := OPT.undftyp
  885.      END ;
  886.      NewOp
  887.    | lss, leq, gtr, geq:
  888.      IF (f IN {Undef, Char..LReal}) OR strings() THEN typ := OPT.booltyp
  889.      ELSE err(108); typ := OPT.undftyp
  890.      END ;
  891.      NewOp
  892.    END
  893.   END
  894.  END Op;
  895.  PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node);
  896.   VAR k, l: LONGINT;
  897.  BEGIN
  898.   IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  899.   ELSIF (x^.typ^.form IN intSet) & (y^.typ^.form IN intSet) THEN
  900.    IF x^.class = Nconst THEN
  901.     k := x^.conval^.intval;
  902.     IF (0 > k) OR (k > OPM.MaxSet) THEN err(202) END
  903.    END ;
  904.    IF y^.class = Nconst THEN
  905.     l := y^.conval^.intval;
  906.     IF (0 > l) OR (l > OPM.MaxSet) THEN err(202) END
  907.    END ;
  908.    IF (x^.class = Nconst) & (y^.class = Nconst) THEN
  909.     IF k <= l THEN
  910.      x^.conval^.setval := {k..l}
  911.     ELSE err(201); x^.conval^.setval := {l..k}
  912.     END ;
  913.     x^.obj := NIL
  914.    ELSE BindNodes(Nupto, OPT.settyp, x, y)
  915.    END
  916.   ELSE err(93)
  917.   END ;
  918.   x^.typ := OPT.settyp
  919.  END SetRange;
  920.  PROCEDURE SetElem*(VAR x: OPT.Node);
  921.   VAR k: LONGINT;
  922.  BEGIN
  923.   IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  924.   ELSIF ~(x^.typ^.form IN intSet) THEN err(93)
  925.   ELSIF x^.class = Nconst THEN
  926.    k := x^.conval^.intval;
  927.    IF (0 <= k) & (k <= OPM.MaxSet) THEN x^.conval^.setval := {k}
  928.    ELSE err(202)
  929.    END ;
  930.    x^.obj := NIL
  931.   ELSE Convert(x, OPT.settyp)
  932.   END ;
  933.   x^.typ := OPT.settyp
  934.  END SetElem;
  935.  PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node); (* x := y *)
  936.   VAR f, g: INTEGER; y, p, q: OPT.Struct;
  937.  BEGIN
  938.   y := ynode^.typ; f := x^.form; g := y^.form;
  939.   IF (ynode^.class = Ntype) OR (ynode^.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
  940.   CASE f OF
  941.     Undef:
  942.   | Byte:
  943.     IF ~(g IN {Byte, Char, SInt}) THEN err(113) END
  944.   | Bool, Char, SInt, Set:
  945.     IF g # f THEN err(113) END
  946.   | Int:
  947.     IF ~(g IN {SInt, Int}) THEN err(113) END
  948.   | LInt:
  949.     IF ~(g IN intSet) THEN err(113) END
  950.   | Real:
  951.     IF ~(g IN {SInt..Real}) THEN err(113) END
  952.   | LReal:
  953.     IF ~(g IN {SInt..LReal}) THEN err(113) END
  954.   | Pointer:
  955.     IF (x = y) OR (g = NilTyp) OR (x = OPT.sysptrtyp) & (g = Pointer) THEN (* ok *)
  956.     ELSIF g = Pointer THEN
  957.      p := x^.BaseTyp; q := y^.BaseTyp;
  958.      IF (p^.comp = Record) & (q^.comp = Record) THEN
  959.       WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  960.       IF q = NIL THEN err(113) END
  961.      ELSE err(113)
  962.      END
  963.     ELSE err(113)
  964.     END
  965.   | ProcTyp:
  966.     IF ynode^.class = Nproc THEN CheckProc(x, ynode^.obj)
  967.     ELSIF (x = y) OR (g = NilTyp) THEN (* ok *)
  968.     ELSE err(113)
  969.     END
  970.   | NoTyp, NilTyp:
  971.     err(113)
  972.   | Comp:
  973.     IF x^.comp = Array THEN
  974.      IF (ynode^.class = Nconst) & (g = Char) THEN CharToString(ynode); y := ynode^.typ; g := String END ;
  975.      IF x = y THEN (* ok *)
  976.      ELSIF (g = String) & (x^.BaseTyp = OPT.chartyp) THEN (*check length of string*)
  977.       IF ynode^.conval^.intval2 > x^.n THEN err(114) END ;
  978.      ELSE err(113)
  979.      END
  980.     ELSIF x^.comp = Record THEN
  981.      IF x = y THEN (* ok *)
  982.      ELSIF y^.comp = Record THEN
  983.       q := y^.BaseTyp;
  984.       WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  985.       IF q = NIL THEN err(113) END
  986.      ELSE err(113)
  987.      END
  988.     ELSE (*DynArr*) err(113)
  989.     END
  990.   END ;
  991.   IF (ynode^.class = Nconst) & (g < f) & (g IN {SInt..Real}) & (f IN {Int..LReal}) THEN
  992.    Convert(ynode, x)
  993.   END
  994.  END CheckAssign;
  995.  PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN);
  996.  BEGIN
  997.   IF (x^.class = Nmop) & (x^.subcl = val) THEN x := x^.left END ;
  998.   IF x^.class = Nguard THEN x := x^.left END ; (* skip last (and unique) guard *)
  999.   IF (x^.class = Nvar) & (dynArrToo OR (x^.typ^.comp # DynArr)) THEN x^.obj^.leaf := FALSE END
  1000.  END CheckLeaf;
  1001.  PROCEDURE StPar0*(VAR par0: OPT.Node; fctno: INTEGER); (* par0: first param of standard proc *)
  1002.   VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node; Dummy:LONGREAL;
  1003.  BEGIN x := par0; f := x^.typ^.form;
  1004.   CASE fctno OF
  1005.     haltfn: (*HALT*)
  1006.     IF (f IN intSet) & (x^.class = Nconst) THEN
  1007.      IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  1008.       BindNodes(Ntrap, OPT.notyp, x, x)
  1009.      ELSE err(218)
  1010.      END
  1011.     ELSE err(69)
  1012.     END ;
  1013.     x^.typ := OPT.notyp
  1014.   | newfn: (*NEW*)
  1015.     typ := OPT.notyp;
  1016.     IF NotVar(x) THEN err(112)
  1017.     ELSIF f = Pointer THEN
  1018.      IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
  1019.      IF x^.readonly THEN err(76) END ;
  1020.      f := x^.typ^.BaseTyp^.comp;
  1021.      IF f IN {Record, DynArr, Array} THEN
  1022.       IF f = DynArr THEN typ := x^.typ^.BaseTyp END ;
  1023.       BindNodes(Nassign, OPT.notyp, x, NIL); x^.subcl := newfn
  1024.      ELSE err(111)
  1025.      END
  1026.     ELSE err(111)
  1027.     END ;
  1028.     x^.typ := typ
  1029.   | absfn: (*ABS*)
  1030.     MOp(abs, x)
  1031.   | capfn: (*CAP*)
  1032.     MOp(cap, x)
  1033.   | ordfn: (*ORD*)
  1034.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1035.     ELSIF f = Char THEN Convert(x, OPT.inttyp)
  1036.     ELSE err(111)
  1037.     END ;
  1038.     x^.typ := OPT.inttyp
  1039.   | entierfn: (*ENTIER*)
  1040.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1041.     ELSIF f IN realSet THEN Convert(x, OPT.linttyp)
  1042.     ELSE err(111)
  1043.     END ;
  1044.     x^.typ := OPT.linttyp
  1045.   | oddfn: (*ODD*)
  1046.     MOp(odd, x)
  1047.   | minfn: (*MIN*)
  1048.     IF x^.class = Ntype THEN
  1049.      CASE f OF
  1050.        Bool:  x := NewBoolConst(FALSE)
  1051.      | Char:  x := NewIntConst(0); x^.typ := OPT.chartyp
  1052.      | SInt:  x := NewIntConst(OPM.MinSInt)
  1053.      | Int:   x := NewIntConst(OPM.MinInt)
  1054.      | LInt:  x := NewIntConst(OPM.MinLInt)
  1055.      | Set:   x := NewIntConst(0); x^.typ := OPT.inttyp
  1056.      | Real:  
  1057.          AmigaMathL.Long(OPM.MinReal, Dummy);
  1058.          x := NewRealConst(Dummy, OPT.realtyp)
  1059.          (* x := NewRealConst(OPM.MinReal, OPT.realtyp) *)
  1060.      | LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp)
  1061.      ELSE err(111)
  1062.      END
  1063.     ELSE err(110)
  1064.     END
  1065.   | maxfn: (*MAX*)
  1066.     IF x^.class = Ntype THEN
  1067.      CASE f OF
  1068.        Bool:  x := NewBoolConst(TRUE)
  1069.      | Char:  x := NewIntConst(0FFH); x^.typ := OPT.chartyp
  1070.      | SInt:  x := NewIntConst(OPM.MaxSInt)
  1071.      | Int:   x := NewIntConst(OPM.MaxInt)
  1072.      | LInt:  x := NewIntConst(OPM.MaxLInt)
  1073.      | Set:   x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp
  1074.      | Real:  
  1075.         AmigaMathL.Long(OPM.MaxReal, Dummy);
  1076.          x := NewRealConst(Dummy, OPT.realtyp)
  1077.          (* x := NewRealConst(OPM.MaxReal, OPT.realtyp) *)
  1078.      | LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp)
  1079.      ELSE err(111)
  1080.      END
  1081.     ELSE err(110)
  1082.     END
  1083.   | chrfn: (*CHR*)
  1084.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1085.     ELSIF f IN {Undef, SInt..LInt} THEN Convert(x, OPT.chartyp)
  1086.     ELSE err(111); x^.typ := OPT.chartyp
  1087.     END
  1088.   | shortfn: (*SHORT*)
  1089.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1090.     ELSIF f = Int THEN Convert(x, OPT.sinttyp)
  1091.     ELSIF f = LInt THEN Convert(x, OPT.inttyp)
  1092.     ELSIF f = LReal THEN Convert(x, OPT.realtyp)
  1093.     ELSE err(111)
  1094.     END
  1095.   | longfn: (*LONG*)
  1096.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1097.     ELSIF f = SInt THEN Convert(x, OPT.inttyp)
  1098.     ELSIF f = Int THEN Convert(x, OPT.linttyp)
  1099.     ELSIF f = Real THEN Convert(x, OPT.lrltyp)
  1100.     ELSIF f = Char THEN Convert(x, OPT.linttyp)
  1101.     ELSE err(111)
  1102.     END
  1103.   | incfn, decfn: (*INC, DEC*)
  1104.     IF NotVar(x) THEN err(112)
  1105.     ELSIF ~(f IN intSet) THEN err(111)
  1106.     ELSIF x^.readonly THEN err(76)
  1107.     END
  1108.   | inclfn, exclfn: (*INCL, EXCL*)
  1109.     IF NotVar(x) THEN err(112)
  1110.     ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp
  1111.     ELSIF x^.readonly THEN err(76)
  1112.     END
  1113.   | lenfn: (*LEN*)
  1114.     IF ~(x^.typ^.comp IN {DynArr, Array}) THEN err(131) END
  1115.   | copyfn: (*COPY*)
  1116.     IF (x^.class = Nconst) & (f = Char) THEN CharToString(x); f := String END ;
  1117.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1118.     ELSIF (~(x^.typ^.comp IN {DynArr, Array}) OR (x^.typ^.BaseTyp^.form # Char))
  1119.       & (f # String) THEN err(111)
  1120.     END
  1121.   | ashfn: (*ASH*)
  1122.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1123.     ELSIF f IN intSet THEN
  1124.      IF f # LInt THEN Convert(x, OPT.linttyp) END
  1125.     ELSE err(111); x^.typ := OPT.linttyp
  1126.     END
  1127.   | adrfn: (*SYSTEM.ADR*)
  1128.     CheckLeaf(x, FALSE); MOp(adr, x)
  1129.   | sizefn: (*SIZE*)
  1130.     IF x^.class # Ntype THEN err(110); x := NewIntConst(1)
  1131.     ELSIF (f IN {Byte..Set, Pointer, ProcTyp}) OR (x^.typ^.comp IN {Array, Record}) THEN
  1132.      typSize(x^.typ, FALSE); x := NewIntConst(x^.typ^.size)
  1133.     ELSE err(111); x := NewIntConst(1)
  1134.     END
  1135.   | ccfn: (*SYSTEM.CC*)
  1136.     MOp(cc, x)
  1137.   | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1138.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1139.     ELSIF ~(f IN intSet + {Byte, Char, Set}) THEN err(111)
  1140.     END
  1141.   | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*)
  1142.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1143.     ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1144.     ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1145.     END
  1146.   | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
  1147.     IF (f IN intSet) & (x^.class = Nconst) THEN
  1148.      IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END
  1149.     ELSE err(69)
  1150.     END
  1151.   | valfn: (*SYSTEM.VAL*)
  1152.     IF x^.class # Ntype THEN err(110)
  1153.     ELSIF (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(111)
  1154.     END
  1155.   | sysnewfn: (*SYSTEM.NEW*)
  1156.     IF NotVar(x) THEN err(112)
  1157.     ELSIF f = Pointer THEN
  1158.      IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END
  1159.     ELSE err(111)
  1160.     END
  1161.   | assertfn: (*ASSERT*)
  1162.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := NewBoolConst(FALSE)
  1163.     ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE)
  1164.     ELSE MOp(not, x)
  1165.     END
  1166.   END ;
  1167.   par0 := x
  1168.  END StPar0;
  1169.  PROCEDURE StPar1*(VAR par0: OPT.Node; x: OPT.Node; fctno: SHORTINT); (* x: second parameter of standard proc *)
  1170.   VAR f, L: INTEGER; typ: OPT.Struct; p, t: OPT.Node;
  1171.   PROCEDURE NewOp(class: SHORTINT);
  1172.    VAR node: OPT.Node;
  1173.   BEGIN
  1174.    node := OPT.NewNode(class);
  1175.    node^.left := p; node^.right := x; p := node
  1176.   END NewOp;
  1177.  BEGIN p := par0; f := x^.typ^.form;
  1178.   CASE fctno OF
  1179.     incfn, decfn: (*INC DEC*)
  1180.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); p^.typ := OPT.notyp
  1181.     ELSE
  1182.      IF x^.typ # p^.typ THEN
  1183.       IF (x^.class = Nconst) & (f IN intSet) THEN Convert(x, p^.typ)
  1184.       ELSE err(111)
  1185.       END
  1186.      END ;
  1187.      NewOp(Nassign); p^.subcl := fctno;
  1188.      p^.typ := OPT.notyp
  1189.     END
  1190.   | inclfn, exclfn: (*INCL, EXCL*)
  1191.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1192.     ELSIF f IN intSet THEN
  1193.      IF (x^.class = Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202)
  1194.      END ;
  1195.      NewOp(Nassign); p^.subcl := fctno
  1196.     ELSE err(111)
  1197.     END ;
  1198.     p^.typ := OPT.notyp
  1199.   | lenfn: (*LEN*)
  1200.     IF ~(f IN intSet) OR (x^.class # Nconst) THEN err(69)
  1201.     ELSIF f = SInt THEN
  1202.      L := SHORT(x^.conval^.intval); typ := p^.typ;
  1203.      WHILE (L > 0) & (typ^.comp IN {DynArr, Array}) DO typ := typ^.BaseTyp; DEC(L) END ;
  1204.      IF (L # 0) OR ~(typ^.comp IN {DynArr, Array}) THEN err(132)
  1205.      ELSE x^.obj := NIL;
  1206.       IF typ^.comp = DynArr THEN
  1207.        WHILE p^.class = Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *)
  1208.        NewOp(Ndop); p^.subcl := len; p^.typ := OPT.linttyp
  1209.       ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p)
  1210.       END
  1211.      END
  1212.     ELSE err(132)
  1213.     END
  1214.   | copyfn: (*COPY*)
  1215.     IF NotVar(x) THEN err(112)
  1216.     ELSIF (x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form = Char) THEN
  1217.      IF x^.readonly THEN err(76) END ;
  1218.      t := x; x := p; p := t; NewOp(Nassign); p^.subcl := copyfn
  1219.     ELSE err(111)
  1220.     END ;
  1221.     p^.typ := OPT.notyp
  1222.   | ashfn: (*ASH*)
  1223.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1224.     ELSIF f IN intSet THEN
  1225.      IF (p^.class = Nconst) & (x^.class = Nconst) THEN
  1226.       IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1
  1227.       ELSIF x^.conval^.intval >= 0 THEN
  1228.        IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN
  1229.         p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval)
  1230.        ELSE err(208); p^.conval^.intval := 1
  1231.        END
  1232.       ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval)
  1233.       END ;
  1234.       p^.obj := NIL
  1235.      ELSE NewOp(Ndop); p^.subcl := ash; p^.typ := OPT.linttyp
  1236.      END
  1237.     ELSE err(111)
  1238.     END
  1239.   | newfn: (*NEW(p, x...)*)
  1240.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1241.     ELSIF p^.typ^.comp = DynArr THEN
  1242.      IF f IN intSet THEN
  1243.       IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END
  1244.      ELSE err(111)
  1245.      END ;
  1246.      p^.right := x; p^.typ := p^.typ^.BaseTyp
  1247.     ELSE err(64)
  1248.     END
  1249.   | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1250.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1251.     ELSIF ~(f IN intSet) THEN err(111)
  1252.     ELSE NewOp(Ndop); p^.typ := p^.left^.typ;
  1253.      IF fctno = lshfn THEN p^.subcl := lsh ELSE p^.subcl := rot END
  1254.     END
  1255.   | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*)
  1256.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1257.     ELSIF f IN {Undef..Set, Pointer, ProcTyp} THEN
  1258.      IF (fctno = getfn) OR (fctno = getrfn) THEN
  1259.       IF NotVar(x) THEN err(112) END ;
  1260.       t := x; x := p; p := t
  1261.      END ;
  1262.      NewOp(Nassign); p^.subcl := fctno
  1263.     ELSE err(111)
  1264.     END ;
  1265.     p^.typ := OPT.notyp
  1266.   | bitfn: (*SYSTEM.BIT*)
  1267.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1268.     ELSIF f IN intSet THEN
  1269.      NewOp(Ndop); p^.subcl := bit
  1270.     ELSE err(111)
  1271.     END ;
  1272.     p^.typ := OPT.booltyp
  1273.   | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *)
  1274.     IF (x^.class = Ntype) OR (x^.class = Nproc) OR
  1275.      (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(126)
  1276.     END ;
  1277.     IF (x^.class >= Nconst) OR ((f IN realSet) # (p^.typ^.form IN realSet)) THEN
  1278.      t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t
  1279.     ELSE x^.readonly := FALSE
  1280.     END ;
  1281.     x^.typ := p^.typ; p := x
  1282.   | sysnewfn: (*SYSTEM.NEW*)
  1283.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1284.     ELSIF f IN intSet THEN
  1285.      NewOp(Nassign); p^.subcl := sysnewfn
  1286.     ELSE err(111)
  1287.     END ;
  1288.     p^.typ := OPT.notyp
  1289.   | movefn: (*SYSTEM.MOVE*)
  1290.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1291.     ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1292.     ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1293.     END ;
  1294.     p^.link := x
  1295.   | assertfn: (*ASSERT*)
  1296.     IF (f IN intSet) & (x^.class = Nconst) THEN
  1297.      IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  1298.       BindNodes(Ntrap, OPT.notyp, x, x);
  1299.       x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1300.       Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1301.       Construct(Nifelse, p, NIL); OptIf(p);
  1302.       IF p = NIL THEN (* ASSERT(TRUE) *)
  1303.       ELSIF p^.class = Ntrap THEN err(99)
  1304.       ELSE p^.subcl := assertfn
  1305.       END
  1306.      ELSE err(218)
  1307.      END
  1308.     ELSE err(69)
  1309.     END
  1310.   ELSE err(64)
  1311.   END ;
  1312.   par0 := p
  1313.  END StPar1;
  1314.  PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER); (* x: n+1-th param of standard proc *)
  1315.   VAR node: OPT.Node; f: INTEGER; p: OPT.Node;
  1316.  BEGIN p := par0; f := x^.typ^.form;
  1317.   IF fctno = newfn THEN (*NEW(p, ..., x...*)
  1318.    IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1319.    ELSIF p^.typ^.comp # DynArr THEN err(64)
  1320.    ELSIF f IN intSet THEN
  1321.     IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ;
  1322.     node := p^.right; WHILE node^.link # NIL DO node := node^.link END;
  1323.     node^.link := x; p^.typ := p^.typ^.BaseTyp
  1324.    ELSE err(111)
  1325.    END
  1326.   ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*)
  1327.    IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1328.    ELSIF f IN intSet THEN
  1329.     node := OPT.NewNode(Nassign); node^.subcl := movefn; node^.right := p;
  1330.     node^.left := p^.link; p^.link := x; p := node
  1331.    ELSE err(111)
  1332.    END ;
  1333.    p^.typ := OPT.notyp
  1334.   ELSE err(64)
  1335.   END ;
  1336.   par0 := p
  1337.  END StParN;
  1338.  PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER);
  1339.   VAR dim: INTEGER; x, p: OPT.Node;
  1340.  BEGIN p := par0;
  1341.   IF fctno <= ashfn THEN
  1342.    IF (fctno = newfn) & (p^.typ # OPT.notyp) THEN
  1343.     IF p^.typ^.comp = DynArr THEN err(65) END ;
  1344.     p^.typ := OPT.notyp
  1345.    ELSIF fctno <= sizefn THEN (* 1 param *)
  1346.     IF parno < 1 THEN err(65) END
  1347.    ELSE (* more than 1 param *)
  1348.     IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*)
  1349.      BindNodes(Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno
  1350.     ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
  1351.      IF p^.typ^.comp = DynArr THEN dim := 0;
  1352.       WHILE p^.class = Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *)
  1353.       BindNodes(Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := len
  1354.      ELSE
  1355.       p := NewIntConst(p^.typ^.n)
  1356.      END
  1357.     ELSIF parno < 2 THEN err(65)
  1358.     END
  1359.    END
  1360.   ELSIF fctno = assertfn THEN
  1361.    IF parno = 1 THEN x := NIL;
  1362.     BindNodes(Ntrap, OPT.notyp, x, NewIntConst(AssertTrap));
  1363.     x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1364.     Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1365.     Construct(Nifelse, p, NIL); OptIf(p);
  1366.     IF p = NIL THEN (* ASSERT(TRUE) *)
  1367.     ELSIF p^.class = Ntrap THEN err(99)
  1368.     ELSE p^.subcl := assertfn
  1369.     END
  1370.    ELSIF parno < 1 THEN err(65)
  1371.    END
  1372.   ELSE (*SYSTEM*)
  1373.    IF (parno < 1) OR
  1374.     (fctno > ccfn) & (parno < 2) OR
  1375.     (fctno = movefn) & (parno < 3) THEN err(65)
  1376.    END
  1377.   END ;
  1378.   par0 := p
  1379.  END StFct;
  1380.  PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN);
  1381.   VAR f: INTEGER;
  1382.  BEGIN (* ftyp^.comp = DynArr *)
  1383.   f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1384.   IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *)
  1385.    IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..SInt}) THEN err(-301) END (* ... warning 301 *)
  1386.   ELSIF f IN {Array, DynArr} THEN
  1387.    IF ftyp^.comp = DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar)
  1388.    ELSIF ftyp # atyp THEN
  1389.     IF ~fvarpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN
  1390.      ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1391.      IF (ftyp^.comp = Record) & (atyp^.comp = Record) THEN
  1392.       WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ;
  1393.       IF atyp = NIL THEN err(113) END
  1394.      ELSE err(66)
  1395.      END
  1396.     ELSE err(66)
  1397.     END
  1398.    END ;
  1399.   ELSE err(67)
  1400.   END
  1401.  END DynArrParCheck;
  1402.  PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object);
  1403.  BEGIN
  1404.   IF fp^.typ^.form = Pointer THEN
  1405.    IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = Record*) err(71) END
  1406.   END
  1407.  END CheckReceiver;
  1408.  PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object);
  1409.  BEGIN
  1410.   IF (x^.obj # NIL) & (x^.obj^.mode IN {LProc, XProc, TProc, CProc}) THEN
  1411.    fpar := x^.obj^.link;
  1412.    IF x^.obj^.mode = TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END
  1413.   ELSIF (x^.class # Ntype) & (x^.typ # NIL) & (x^.typ^.form = ProcTyp) THEN
  1414.    fpar := x^.typ^.link
  1415.   ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp
  1416.   END
  1417.  END PrepCall;
  1418.  PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object);
  1419.   VAR q: OPT.Struct;
  1420.  BEGIN
  1421.   IF fp.typ.form # Undef THEN
  1422.    IF fp^.mode = VarPar THEN
  1423.     IF NotVar(ap) THEN err(122)
  1424.     ELSE CheckLeaf(ap, FALSE)
  1425.     END ;
  1426.     IF ap^.readonly THEN err(76) END ;
  1427.     IF fp^.typ^.comp = DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE)
  1428.     ELSIF (fp^.typ^.comp = Record) & (ap^.typ^.comp = Record) THEN
  1429.      q := ap^.typ;
  1430.      WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  1431.      IF q = NIL THEN err(111) END
  1432.     ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = Pointer) THEN (* ok *)
  1433.     ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = Byte) & (ap^.typ^.form IN {Char, SInt})) THEN err(123)
  1434.     END
  1435.    ELSIF fp^.typ^.comp = DynArr THEN
  1436.     IF (ap^.class = Nconst) & (ap^.typ^.form = Char) THEN CharToString(ap) END ;
  1437.     IF (ap^.typ^.form = String) & (fp^.typ^.BaseTyp^.form = Char) THEN (* ok *)
  1438.     ELSIF ap^.class >= Nconst THEN err(59)
  1439.     ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE)
  1440.     END
  1441.    ELSE CheckAssign(fp^.typ, ap)
  1442.    END
  1443.   END
  1444.  END Param;
  1445.  PROCEDURE StaticLink*(dlev: SHORTINT);
  1446.   VAR scope: OPT.Object;
  1447.  BEGIN
  1448.   scope := OPT.topScope;
  1449.   WHILE dlev > 0 DO DEC(dlev);
  1450.    INCL(scope^.link^.conval^.setval, slNeeded);
  1451.    scope := scope^.left
  1452.   END
  1453.  END StaticLink;
  1454.  PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object);
  1455.   VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT;
  1456.  BEGIN
  1457.   IF x^.class = Nproc THEN typ := x^.typ;
  1458.    lev := x^.obj^.mnolev;
  1459.    IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ;
  1460.    IF x^.obj^.mode = IProc THEN err(121) END
  1461.   ELSIF (x^.class = Nfield) & (x^.obj^.mode = TProc) THEN typ := x^.typ;
  1462.    x^.class := Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link
  1463.   ELSE typ := x^.typ^.BaseTyp
  1464.   END ;
  1465.   BindNodes(Ncall, typ, x, apar); x^.obj := fp
  1466.  END Call;
  1467.  PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object);
  1468.   VAR x: OPT.Node;
  1469.  BEGIN
  1470.   x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc;
  1471.   x^.left := procdec; x^.right := stat; procdec := x
  1472.  END Enter;
  1473.  PROCEDURE Return*(VAR x: OPT.Node; proc: OPT.Object);
  1474.   VAR node: OPT.Node;
  1475.  BEGIN
  1476.   IF proc = NIL THEN (* return from module *)
  1477.    IF x # NIL THEN err(124) END
  1478.   ELSE
  1479.    IF x # NIL THEN CheckAssign(proc^.typ, x)
  1480.    ELSIF proc^.typ # OPT.notyp THEN err(124)
  1481.    END
  1482.   END ;
  1483.   node := OPT.NewNode(Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node
  1484.  END Return;
  1485.  PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node);
  1486.   VAR z: OPT.Node;
  1487.  BEGIN
  1488.   IF x^.class >= Nconst THEN err(56) END ;
  1489.   CheckAssign(x^.typ, y);
  1490.   IF x^.readonly THEN err(76) END ;
  1491.   IF x^.typ^.comp = Record THEN
  1492.    IF x^.class = Nguard THEN z := x^.left ELSE z := x END ;
  1493.    IF (z^.class = Nderef) & (z^.left^.class = Nguard) THEN
  1494.     z^.left := z^.left^.left (* skip guard before dereferencing *)
  1495.    END ;
  1496.    IF (x^.typ^.strobj # NIL) & ((z^.class = Nderef) OR (z^.class = Nvarpar)) THEN
  1497.     BindNodes(Neguard, x^.typ, z, NIL); x := z
  1498.    END
  1499.   ELSIF (x^.typ^.comp = Array) & (x^.typ^.BaseTyp = OPT.chartyp) &
  1500.     (y^.typ^.form = String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *)
  1501.    y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  1502.    Index(x, NewIntConst(0))
  1503.   END ;
  1504.   BindNodes(Nassign, OPT.notyp, x, y); x^.subcl := assign
  1505.  END Assign;
  1506.  PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct);
  1507.   VAR node: OPT.Node;
  1508.  BEGIN
  1509.   node := OPT.NewNode(Ninittd); node^.typ := typ;
  1510.   node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos;
  1511.   IF inittd = NIL THEN inittd := node ELSE last^.link := node END ;
  1512.   last := node
  1513.  END Inittd;
  1514. BEGIN
  1515.  maxExp := log(MAX(LONGINT) DIV 2 + 1); maxExp := exp
  1516. END OPB.
  1517.