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