diff --git a/src/compiler/OPB.Mod b/src/compiler/OPB.Mod index a06b1cfc..2d983795 100644 --- a/src/compiler/OPB.Mod +++ b/src/compiler/OPB.Mod @@ -3,93 +3,36 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) IMPORT OPT, OPS, OPM, SYSTEM; + CONST - (* symbol values or ops *) - times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; ash = 17; msk = 18; len = 19; - conv = 20; abs = 21; cap = 22; odd = 23; not = 33; - (*SYSTEM*) - adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; - - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* Structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; -(* Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19; - *) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - intSet = {SInt..LInt(*, Int8..Int64*)}; realSet = {Real, LReal}; - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; - Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (*function number*) - assign = 0; - haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; - entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; - shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; - - (*SYSTEM function number*) - adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; - bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* procedure flags (conval^.setval) *) - hasBody = 1; isRedef = 2; slNeeded = 3; - AssertTrap = 0; (* default trap number *) + VAR typSize*: PROCEDURE(typ: OPT.Struct); - exp: INTEGER; (*side effect of log*) - maxExp: LONGINT; (* max n in ASH(1, n) on this machine *) + exp: INTEGER; (*side effect of log*) + maxExp: LONGINT; (* max n in ASH(1, n) on this machine *) + PROCEDURE err(n: INTEGER); BEGIN OPM.err(n) END err; + PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node; VAR node: OPT.Node; BEGIN CASE obj^.mode OF - Var: - node := OPT.NewNode(Nvar); node^.readonly := (obj^.vis = externalR) & (obj^.mnolev < 0) - | VarPar: - node := OPT.NewNode(Nvarpar) - | Con: - node := OPT.NewNode(Nconst); node^.conval := OPT.NewConst(); - node^.conval^ := obj^.conval^ (* string is not copied, only its ref *) - | Typ: - node := OPT.NewNode(Ntype) - | LProc..IProc: - node := OPT.NewNode(Nproc) - ELSE err(127); node := OPT.NewNode(Nvar) + | OPM.Var: node := OPT.NewNode(OPM.Nvar); + node^.readonly := (obj^.vis = OPM.externalR) & (obj^.mnolev < 0) + | OPM.VarPar: node := OPT.NewNode(OPM.Nvarpar) + | OPM.Con: node := OPT.NewNode(OPM.Nconst); + node^.conval := OPT.NewConst(); + node^.conval^ := obj^.conval^ (* string is not copied, only its ref *) + | OPM.Typ: node := OPT.NewNode(OPM.Ntype) + | OPM.LProc + ..OPM.IProc: node := OPT.NewNode(OPM.Nproc) + ELSE node := OPT.NewNode(OPM.Nvar); err(127) END ; node^.obj := obj; node^.typ := obj^.typ; RETURN node @@ -122,7 +65,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.booltyp; + x := OPT.NewNode(OPM.Nconst); x^.typ := OPT.booltyp; x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x END NewBoolConst; @@ -130,7 +73,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) VAR if, pred: OPT.Node; BEGIN if := x^.left; - WHILE if^.left^.class = Nconst DO + WHILE if^.left^.class = OPM.Nconst DO IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN ELSIF if^.link = NIL THEN x := x^.right; RETURN ELSE if := if^.link; x^.left := if @@ -138,7 +81,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END ; pred := if; if := if^.link; WHILE if # NIL DO - IF if^.left^.class = Nconst THEN + IF if^.left^.class = OPM.Nconst THEN IF IntToBool(if^.left^.conval^.intval) THEN pred^.link := NIL; x^.right := if^.right; RETURN ELSE if := if^.link; pred^.link := if @@ -151,20 +94,21 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE Nil*(): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.niltyp; + x := OPT.NewNode(OPM.Nconst); x^.typ := OPT.niltyp; x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x END Nil; PROCEDURE EmptySet*(): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.settyp; + x := OPT.NewNode(OPM.Nconst); x^.typ := OPT.settyp; x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x END EmptySet; PROCEDURE SetIntType(node: OPT.Node); VAR v: LONGINT(*SYSTEM.INT64*); BEGIN v := node^.conval^.intval; + (* TODO: XInt set to size based type *) IF (OPM.MinSInt <= SYSTEM.VAL(LONGINT, v)) & (SYSTEM.VAL(LONGINT, v) <= OPM.MaxSInt) THEN node^.typ := OPT.sinttyp ELSIF (OPM.MinInt <= SYSTEM.VAL(LONGINT, v)) & (SYSTEM.VAL(LONGINT, v) <= OPM.MaxInt) THEN node^.typ := OPT.inttyp ELSIF (OPM.MinLInt <= v) & (v <= OPM.MaxLInt) (*bootstrap or cross*) THEN @@ -178,14 +122,14 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewIntConst*(intval: LONGINT): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); + x := OPT.NewNode(OPM.Nconst); x^.conval := OPT.NewConst(); x^.conval^.intval := intval; SetIntType(x); RETURN x END NewIntConst; PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); + x := OPT.NewNode(OPM.Nconst); x^.conval := OPT.NewConst(); x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc; RETURN x END NewRealConst; @@ -193,7 +137,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewString*(VAR str: OPS.String; len: LONGINT): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp; + x := OPT.NewNode(OPM.Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp; x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := len; x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str; RETURN x @@ -215,21 +159,21 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END BindNodes; PROCEDURE NotVar(x: OPT.Node): BOOLEAN; - BEGIN RETURN (x^.class >= Nconst) & ((x^.class # Nmop) OR (x^.subcl # val) OR (x^.left^.class >= Nconst)) + BEGIN RETURN (x^.class >= OPM.Nconst) & ((x^.class # OPM.Nmop) OR (x^.subcl # OPM.val) OR (x^.left^.class >= OPM.Nconst)) END NotVar; PROCEDURE DeRef*(VAR x: OPT.Node); VAR strobj, bstrobj: OPT.Object; typ, btyp: OPT.Struct; BEGIN typ := x^.typ; - IF x^.class >= Nconst THEN err(78) - ELSIF typ^.form = Pointer THEN + IF x^.class >= OPM.Nconst THEN err(78) + ELSIF typ^.form = OPM.Pointer THEN IF typ = OPT.sysptrtyp THEN err(57) END ; btyp := typ^.BaseTyp; strobj := typ^.strobj; bstrobj := btyp^.strobj; IF (strobj # NIL) & (strobj^.name # "") & (bstrobj # NIL) & (bstrobj^.name # "") THEN btyp^.pbused := TRUE END ; - BindNodes(Nderef, btyp, x, NIL) + BindNodes(OPM.Nderef, btyp, x, NIL) ELSE err(84) END END DeRef; @@ -238,23 +182,23 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) VAR f: INTEGER; typ: OPT.Struct; BEGIN f := y^.typ^.form; - IF x^.class >= Nconst THEN err(79) - ELSIF ~(f IN intSet) OR (y^.class IN {Nproc, Ntype}) THEN err(80); y^.typ := OPT.inttyp END ; - IF x^.typ^.comp = Array THEN typ := x^.typ^.BaseTyp; - IF (y^.class = Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END - ELSIF x^.typ^.comp = DynArr THEN typ := x^.typ^.BaseTyp; - IF (y^.class = Nconst) & (y^.conval^.intval < 0) THEN err(81) END + IF x^.class >= OPM.Nconst THEN err(79) + ELSIF ~(f IN OPM.intSet) OR (y^.class IN {OPM.Nproc, OPM.Ntype}) THEN err(80); y^.typ := OPT.inttyp END ; + IF x^.typ^.comp = OPM.Array THEN typ := x^.typ^.BaseTyp; + IF (y^.class = OPM.Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END + ELSIF x^.typ^.comp = OPM.DynArr THEN typ := x^.typ^.BaseTyp; + IF (y^.class = OPM.Nconst) & (y^.conval^.intval < 0) THEN err(81) END ELSE err(82); typ := OPT.undftyp END ; - BindNodes(Nindex, typ, x, y); x^.readonly := x^.left^.readonly + BindNodes(OPM.Nindex, typ, x, y); x^.readonly := x^.left^.readonly END Index; PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object); - BEGIN (*x^.typ^.comp = Record*) - IF x^.class >= Nconst THEN err(77) END ; - IF (y # NIL) & (y^.mode IN {Fld, TProc}) THEN - BindNodes(Nfield, y^.typ, x, NIL); x^.obj := y; - x^.readonly := x^.left^.readonly OR ((y^.vis = externalR) & (y^.mnolev < 0)) + BEGIN (*x^.typ^.comp = OPM.Record*) + IF x^.class >= OPM.Nconst THEN err(77) END ; + IF (y # NIL) & (y^.mode IN {OPM.Fld, OPM.TProc}) THEN + BindNodes(OPM.Nfield, y^.typ, x, NIL); x^.obj := y; + x^.readonly := x^.left^.readonly OR ((y^.vis = OPM.externalR) & (y^.mnolev < 0)) ELSE err(83); x^.typ := OPT.undftyp END END Field; @@ -267,17 +211,17 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ; IF t # t1 THEN WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 := t1^.BaseTyp END ; - IF (t1 = t0) OR (t0.form = Undef (*SYSTEM.PTR*)) THEN - IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly - ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x; + IF (t1 = t0) OR (t0.form = OPM.Undef (*SYSTEM.PTR*)) THEN + IF guard THEN BindNodes(OPM.Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly + ELSE node := OPT.NewNode(OPM.Nmop); node^.subcl := OPM.is; node^.left := x; node^.obj := obj; x := node END ELSE err(85) END ELSIF t0 # t1 THEN err(85) (* prevent down guard *) ELSIF ~guard THEN - IF x^.class = Nguard THEN (* cannot skip guard *) - node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x; + IF x^.class = OPM.Nguard THEN (* cannot skip guard *) + node := OPT.NewNode(OPM.Nmop); node^.subcl := OPM.is; node^.left := x; node^.obj := obj; x := node ELSE x := NewBoolConst(TRUE) END @@ -286,12 +230,12 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) BEGIN IF NotVar(x) THEN err(112) - ELSIF x^.typ^.form = Pointer THEN - IF (x^.typ^.BaseTyp^.comp # Record) & (x^.typ # OPT.sysptrtyp) THEN err(85) - ELSIF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp) + ELSIF x^.typ^.form = OPM.Pointer THEN + IF (x^.typ^.BaseTyp^.comp # OPM.Record) & (x^.typ # OPT.sysptrtyp) THEN err(85) + ELSIF obj^.typ^.form = OPM.Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp) ELSE err(86) END - ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp = Record) THEN + ELSIF (x^.typ^.comp = OPM.Record) & (x^.class = OPM.Nvarpar) & (obj^.typ^.comp = OPM.Record) THEN GTT(x^.typ, obj^.typ) ELSE err(87) END ; @@ -301,15 +245,15 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node); VAR f: INTEGER; k: LONGINT; BEGIN f := x^.typ^.form; - IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (f IN intSet) & (y^.typ^.form = Set) THEN - IF x^.class = Nconst THEN + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) OR (y^.class = OPM.Ntype) OR (y^.class = OPM.Nproc) THEN err(126) + ELSIF (f IN OPM.intSet) & (y^.typ^.form = OPM.Set) THEN + IF x^.class = OPM.Nconst THEN k := x^.conval^.intval; IF (k < 0) OR (k > OPM.MaxSet) THEN err(202) - ELSIF y^.class = Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL - ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in + ELSIF y^.class = OPM.Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL + ELSE BindNodes(OPM.Ndop, OPT.booltyp, x, y); x^.subcl := OPM.in END - ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in + ELSE BindNodes(OPM.Ndop, OPT.booltyp, x, y); x^.subcl := OPM.in END ELSE err(92) END ; @@ -327,13 +271,13 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const); VAR min, max, r: LONGREAL; BEGIN - IF f = Real THEN min := OPM.MinReal; max := OPM.MaxReal + IF f = OPM.Real THEN min := OPM.MinReal; max := OPM.MaxReal ELSE min := OPM.MinLReal; max := OPM.MaxLReal END ; r := ABS(x^.realval); IF (r > max) OR (r < min) THEN err(nr); x^.realval := 1.0 - ELSIF f = Real THEN x^.realval := SHORT(x^.realval) (* single precision only *) + ELSIF f = OPM.Real THEN x^.realval := SHORT(x^.realval) (* single precision only *) END ; x^.intval := OPM.ConstNotAlloc END CheckRealType; @@ -344,32 +288,32 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; z: OPT.Node): OPT.Node; VAR node: OPT.Node; BEGIN - node := OPT.NewNode(Nmop); node^.subcl := op; node^.typ := typ; + node := OPT.NewNode(OPM.Nmop); node^.subcl := op; node^.typ := typ; node^.left := z; RETURN node END NewOp; BEGIN z := x; - IF (z^.class = Ntype) OR (z^.class = Nproc) THEN err(126) + IF (z^.class = OPM.Ntype) OR (z^.class = OPM.Nproc) THEN err(126) ELSE typ := z^.typ; f := typ^.form; CASE op OF - not: - IF f = Bool THEN - IF z^.class = Nconst THEN + OPM.not: + IF f = OPM.Bool THEN + IF z^.class = OPM.Nconst THEN z^.conval^.intval := BoolToInt(~IntToBool(z^.conval^.intval)); z^.obj := NIL ELSE z := NewOp(op, typ, z) END ELSE err(98) END - | plus: - IF ~(f IN intSet + realSet) THEN err(96) END - | minus: - IF f IN intSet + realSet +{Set}THEN - IF z^.class = Nconst THEN - IF f IN intSet THEN + | OPM.plus: + IF ~(f IN OPM.intSet + OPM.realSet) THEN err(96) END + | OPM.minus: + IF f IN OPM.intSet + OPM.realSet +{OPM.Set}THEN + IF z^.class = OPM.Nconst THEN + IF f IN OPM.intSet THEN IF z^.conval^.intval = MIN(LONGINT) THEN err(203) ELSE z^.conval^.intval := -z^.conval^.intval; SetIntType(z) END - ELSIF f IN realSet THEN z^.conval^.realval := -z^.conval^.realval + ELSIF f IN OPM.realSet THEN z^.conval^.realval := -z^.conval^.realval ELSE z^.conval^.setval := -z^.conval^.setval END ; z^.obj := NIL @@ -377,10 +321,10 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END ELSE err(97) END - | abs: - IF f IN intSet + realSet THEN - IF z^.class = Nconst THEN - IF f IN intSet THEN + | OPM.abs: + IF f IN OPM.intSet + OPM.realSet THEN + IF z^.class = OPM.Nconst THEN + IF f IN OPM.intSet THEN IF z^.conval^.intval = MIN(LONGINT) THEN err(203) ELSE z^.conval^.intval := ABS(z^.conval^.intval); SetIntType(z) END @@ -391,33 +335,33 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END ELSE err(111) END - | cap: - IF f = Char THEN - IF z^.class = Nconst THEN + | OPM.cap: + IF f = OPM.Char THEN + IF z^.class = OPM.Nconst THEN z^.conval^.intval := ORD(CAP(CHR(z^.conval^.intval))); z^.obj := NIL ELSE z := NewOp(op, typ, z) END ELSE err(111); z^.typ := OPT.chartyp END - | odd: - IF f IN intSet THEN - IF z^.class = Nconst THEN + | OPM.odd: + IF f IN OPM.intSet THEN + IF z^.class = OPM.Nconst THEN z^.conval^.intval := BoolToInt(ODD(z^.conval^.intval)); z^.obj := NIL ELSE z := NewOp(op, typ, z) END ELSE err(111) END ; z^.typ := OPT.booltyp - | adr: (*SYSTEM.ADR*) - IF (z^.class = Nconst) & (f = Char) & (z^.conval^.intval >= 20H) THEN - CharToString(z); f := String + | OPM.adr: (*SYSTEM.ADR*) + IF (z^.class = OPM.Nconst) & (f = OPM.Char) & (z^.conval^.intval >= 20H) THEN + CharToString(z); f := OPM.String END; - IF (z^.class < Nconst) OR (f = String) THEN z := NewOp(op, typ, z) + IF (z^.class < OPM.Nconst) OR (f = OPM.String) THEN z := NewOp(op, typ, z) ELSE err(127) END ; z^.typ := OPT.linttyp - | cc: (*SYSTEM.CC*) - IF (f IN intSet) & (z^.class = Nconst) THEN + | OPM.cc: (*SYSTEM.CC*) + IF (f IN OPM.intSet) & (z^.class = OPM.Nconst) THEN IF (0 <= z^.conval^.intval) & (z^.conval^.intval <= OPM.MaxCC) THEN z := NewOp(op, typ, z) ELSE err(219) END ELSE err(69) END ; @@ -432,15 +376,15 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE CheckPtr(x, y: OPT.Node); VAR g: INTEGER; p, q, t: OPT.Struct; BEGIN g := y^.typ^.form; - IF g = Pointer THEN + IF g = OPM.Pointer THEN p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp; - IF (p^.comp = Record) & (q^.comp = Record) THEN + IF (p^.comp = OPM.Record) & (q^.comp = OPM.Record) THEN IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ; WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ; IF p = NIL THEN err(100) END ELSE err(100) END - ELSIF g # NilTyp THEN err(100) + ELSIF g # OPM.NilTyp THEN err(100) END END CheckPtr; @@ -450,11 +394,11 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) WHILE fp # NIL DO IF ap # NIL THEN ft := fp^.typ; at := ap^.typ; - WHILE (ft^.comp = DynArr) & (at^.comp = DynArr) DO + WHILE (ft^.comp = OPM.DynArr) & (at^.comp = OPM.DynArr) DO ft := ft^.BaseTyp; at := at^.BaseTyp END ; IF ft # at THEN - IF (ft^.form = ProcTyp) & (at^.form = ProcTyp) THEN + IF (ft^.form = OPM.ProcTyp) & (at^.form = OPM.ProcTyp) THEN IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.link, at^.link, FALSE) ELSE err(117) END @@ -472,9 +416,9 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object); (* proc var x := proc y, check compatibility *) BEGIN - IF y^.mode IN {XProc, IProc, LProc} THEN - IF y^.mode = LProc THEN - IF y^.mnolev = 0 THEN y^.mode := XProc + IF y^.mode IN {OPM.XProc, OPM.IProc, OPM.LProc} THEN + IF y^.mode = OPM.LProc THEN + IF y^.mnolev = 0 THEN y^.mode := OPM.XProc ELSE err(73) END END ; @@ -493,34 +437,34 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) VAR res: INTEGER; BEGIN CASE f OF - Undef: - res := eql - | Byte, Char..LInt(*,Int8..Int64*): - IF xval^.intval < yval^.intval THEN res := lss - ELSIF xval^.intval > yval^.intval THEN res := gtr - ELSE res := eql + OPM.Undef: + res := OPM.eql + | OPM.Byte, OPM.Char..OPM.LInt: + IF xval^.intval < yval^.intval THEN res := OPM.lss + ELSIF xval^.intval > yval^.intval THEN res := OPM.gtr + ELSE res := OPM.eql END - | Real, LReal: - IF xval^.realval < yval^.realval THEN res := lss - ELSIF xval^.realval > yval^.realval THEN res := gtr - ELSE res := eql + | OPM.Real, OPM.LReal: + IF xval^.realval < yval^.realval THEN res := OPM.lss + ELSIF xval^.realval > yval^.realval THEN res := OPM.gtr + ELSE res := OPM.eql END - | Bool: - IF xval^.intval # yval^.intval THEN res := neq - ELSE res := eql + | OPM.Bool: + IF xval^.intval # yval^.intval THEN res := OPM.neq + ELSE res := OPM.eql END - | Set: - IF xval^.setval # yval^.setval THEN res := neq - ELSE res := eql + | OPM.Set: + IF xval^.setval # yval^.setval THEN res := OPM.neq + ELSE res := OPM.eql END - | String: - IF xval^.ext^ < yval^.ext^ THEN res := lss - ELSIF xval^.ext^ > yval^.ext^ THEN res := gtr - ELSE res := eql + | OPM.String: + IF xval^.ext^ < yval^.ext^ THEN res := OPM.lss + ELSIF xval^.ext^ > yval^.ext^ THEN res := OPM.gtr + ELSE res := OPM.eql END - | NilTyp, Pointer, ProcTyp: - IF xval^.intval # yval^.intval THEN res := neq - ELSE res := eql + | OPM.NilTyp, OPM.Pointer, OPM.ProcTyp: + IF xval^.intval # yval^.intval THEN res := OPM.neq + ELSE res := OPM.eql END ELSE OPM.LogWStr("unhandled case in OPB.ConstCmp, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; @@ -532,56 +476,56 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval; IF f # g THEN CASE f OF - Char: - IF g = String THEN CharToString(x) + OPM.Char: + IF g = OPM.String THEN CharToString(x) ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END ; - | SInt(*, Int8*): - IF g IN intSet THEN x^.typ := y^.typ - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval + | OPM.SInt: + IF g IN OPM.intSet THEN x^.typ := y^.typ + ELSIF g = OPM.Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval + ELSIF g = OPM.LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END - | Int(*, Int16, Int32, Int64*): - IF g = SInt THEN y^.typ := OPT.inttyp - ELSIF g IN intSet THEN x^.typ := y^.typ - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval + | OPM.Int: + IF g = OPM.SInt THEN y^.typ := OPT.inttyp + ELSIF g IN OPM.intSet THEN x^.typ := y^.typ + ELSIF g = OPM.Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval + ELSIF g = OPM.LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END - | LInt: - IF g IN intSet THEN y^.typ := OPT.linttyp - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval + | OPM.LInt: + IF g IN OPM.intSet THEN y^.typ := OPT.linttyp + ELSIF g = OPM.Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval + ELSIF g = OPM.LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END - | Real: - IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp + | OPM.Real: + IF g IN OPM.intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval + ELSIF g = OPM.LReal THEN x^.typ := OPT.lrltyp ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END - | LReal: - IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval - ELSIF g = Real THEN y^.typ := OPT.lrltyp + | OPM.LReal: + IF g IN OPM.intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval + ELSIF g = OPM.Real THEN y^.typ := OPT.lrltyp ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END - | String: - IF g = Char THEN CharToString(y); g := String + | OPM.String: + IF g = OPM.Char THEN CharToString(y); g := OPM.String ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END ; - | NilTyp: - IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END - | Pointer: + | OPM.NilTyp: + IF ~(g IN {OPM.Pointer, OPM.ProcTyp}) THEN err(100) END + | OPM.Pointer: CheckPtr(x, y) - | ProcTyp: - IF g # NilTyp THEN err(100) END + | OPM.ProcTyp: + IF g # OPM.NilTyp THEN err(100) END ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END ; f := x^.typ^.form END ; (* {x^.typ = y^.typ} *) CASE op OF - times: - IF f IN intSet THEN xv := xval^.intval; yv := yval^.intval; + OPM.times: + IF f IN OPM.intSet THEN xv := xval^.intval; yv := yval^.intval; IF (xv = 0) OR (yv = 0) OR (* division with negative numbers is not defined *) (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR @@ -590,112 +534,112 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) xval^.intval := xv * yv; SetIntType(x) ELSE err(204) END - ELSIF f IN realSet THEN + ELSIF f IN OPM.realSet THEN temp := ABS(yval^.realval) <= 1.0; IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval) ELSE err(204) END - ELSIF f = Set THEN + ELSIF f = OPM.Set THEN xval^.setval := xval^.setval * yval^.setval - ELSIF f # Undef THEN err(101) + ELSIF f # OPM.Undef THEN err(101) END - | slash: - IF f IN intSet THEN + | OPM.slash: + IF f IN OPM.intSet THEN IF yval^.intval # 0 THEN - xval^.realval := xval^.intval / yval^.intval; CheckRealType(Real, 205, xval) + xval^.realval := xval^.intval / yval^.intval; CheckRealType(OPM.Real, 205, xval) ELSE err(205); xval^.realval := 1.0 END ; x^.typ := OPT.realtyp - ELSIF f IN realSet THEN + ELSIF f IN OPM.realSet THEN temp := ABS(yval^.realval) >= 1.0; IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval) ELSE err(205) END - ELSIF f = Set THEN + ELSIF f = OPM.Set THEN xval^.setval := xval^.setval / yval^.setval - ELSIF f # Undef THEN err(102) + ELSIF f # OPM.Undef THEN err(102) END - | div: - IF f IN intSet THEN + | OPM.div: + IF f IN OPM.intSet THEN IF yval^.intval # 0 THEN xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x) ELSE err(205) END - ELSIF f # Undef THEN err(103) + ELSIF f # OPM.Undef THEN err(103) END - | mod: - IF f IN intSet THEN + | OPM.mod: + IF f IN OPM.intSet THEN IF yval^.intval # 0 THEN xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x) ELSE err(205) END - ELSIF f # Undef THEN err(104) + ELSIF f # OPM.Undef THEN err(104) END - | and: - IF f = Bool THEN + | OPM.and: + IF f = OPM.Bool THEN xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval)) ELSE err(94) END - | plus: - IF f IN intSet THEN + | OPM.plus: + IF f IN OPM.intSet THEN temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval); IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN INC(xval^.intval, yval^.intval); SetIntType(x) ELSE err(206) END - ELSIF f IN realSet THEN + ELSIF f IN OPM.realSet THEN temp := (yval^.realval >= 0.0) & (xval^.realval <= MAX(LONGREAL) - yval^.realval); IF temp OR (yval^.realval < 0.0) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval) ELSE err(206) END - ELSIF f = Set THEN + ELSIF f = OPM.Set THEN xval^.setval := xval^.setval + yval^.setval - ELSIF f # Undef THEN err(105) + ELSIF f # OPM.Undef THEN err(105) END - | minus: - IF f IN intSet THEN + | OPM.minus: + IF f IN OPM.intSet THEN IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN DEC(xval^.intval, yval^.intval); SetIntType(x) ELSE err(207) END - ELSIF f IN realSet THEN + ELSIF f IN OPM.realSet THEN temp := (yval^.realval >= 0.0) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval); IF temp OR (yval^.realval < 0.0) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval) ELSE err(207) END - ELSIF f = Set THEN + ELSIF f = OPM.Set THEN xval^.setval := xval^.setval - yval^.setval - ELSIF f # Undef THEN err(106) + ELSIF f # OPM.Undef THEN err(106) END - | or: - IF f = Bool THEN + | OPM.or: + IF f = OPM.Bool THEN xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval)) ELSE err(95) END - | eql: - xval^.intval := BoolToInt(ConstCmp() = eql) - | neq: - xval^.intval := BoolToInt(ConstCmp() # eql) - | lss: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() = lss) + | OPM.eql: + xval^.intval := BoolToInt(ConstCmp() = OPM.eql) + | OPM.neq: + xval^.intval := BoolToInt(ConstCmp() # OPM.eql) + | OPM.lss: + IF f IN {OPM.Bool, OPM.Set, OPM.NilTyp, OPM.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() = OPM.lss) END - | leq: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() # gtr) + | OPM.leq: + IF f IN {OPM.Bool, OPM.Set, OPM.NilTyp, OPM.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() # OPM.gtr) END - | gtr: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() = gtr) + | OPM.gtr: + IF f IN {OPM.Bool, OPM.Set, OPM.NilTyp, OPM.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() = OPM.gtr) END - | geq: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() # lss) + | OPM.geq: + IF f IN {OPM.Bool, OPM.Set, OPM.NilTyp, OPM.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() # OPM.lss) END ELSE OPM.LogWStr("unhandled case in OPB.ConstOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; @@ -705,30 +649,30 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct); VAR node: OPT.Node; f, g: INTEGER; k: LONGINT; r: LONGREAL; BEGIN f := x^.typ^.form; g := typ^.form; - IF x^.class = Nconst THEN - IF f IN intSet THEN - IF g IN intSet THEN + IF x^.class = OPM.Nconst THEN + IF f IN OPM.intSet THEN + IF g IN OPM.intSet THEN IF f > g THEN SetIntType(x); IF x^.typ^.form > g THEN err(203); x^.conval^.intval := 1 END END - ELSIF g IN realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc - ELSE (*g = Char*) k := x^.conval^.intval; + ELSIF g IN OPM.realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc + ELSE (*g = OPM.Char*) k := x^.conval^.intval; IF (0 > k) OR (k > 0FFH) THEN err(220) END END - ELSIF f IN realSet THEN - IF g IN realSet THEN CheckRealType(g, 203, x^.conval) - ELSE (*g = LInt*) + ELSIF f IN OPM.realSet THEN + IF g IN OPM.realSet THEN CheckRealType(g, 203, x^.conval) + ELSE (*g = OPM.LInt*) r := x^.conval^.realval; IF (r < MIN(LONGINT)) OR (r > MAX(LONGINT)) THEN err(203); r := 1 END ; x^.conval^.intval := ENTIER(r); SetIntType(x) END - ELSE (* (f IN {Char, Byte}) & (g IN {Byte} + intSet) OR (f = Undef) *) + ELSE (* (f IN {OPM.Char, OPM.Byte}) & (g IN {OPM.Byte} + OPM.intSet) OR (f = OPM.Undef) *) END ; x^.obj := NIL - ELSIF (x^.class = Nmop) & (x^.subcl = conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN + ELSIF (x^.class = OPM.Nmop) & (x^.subcl = OPM.conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN (* don't create new node *) IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END - ELSE node := OPT.NewNode(Nmop); node^.subcl := conv; node^.left := x; x := node + ELSE node := OPT.NewNode(OPM.Nmop); node^.subcl := OPM.conv; node^.left := x; x := node END ; x^.typ := typ END Convert; @@ -739,23 +683,23 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node); VAR node: OPT.Node; BEGIN - node := OPT.NewNode(Ndop); node^.subcl := op; node^.typ := typ; + node := OPT.NewNode(OPM.Ndop); node^.subcl := op; node^.typ := typ; node^.left := x; node^.right := y; x := node END NewOp; PROCEDURE strings(VAR x, y: OPT.Node): BOOLEAN; VAR ok, xCharArr, yCharArr: BOOLEAN; BEGIN - xCharArr := ((x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form=Char)) OR (f=String); - yCharArr := (((y^.typ^.comp IN {Array, DynArr}) & (y^.typ^.BaseTyp^.form=Char)) OR (g=String)); - IF xCharArr & (g = Char) & (y^.class = Nconst) THEN CharToString(y); g := String; yCharArr := TRUE END ; - IF yCharArr & (f = Char) & (x^.class = Nconst) THEN CharToString(x); f := String; xCharArr := TRUE END ; + xCharArr := ((x^.typ^.comp IN {OPM.Array, OPM.DynArr}) & (x^.typ^.BaseTyp^.form=OPM.Char)) OR (f=OPM.String); + yCharArr := (((y^.typ^.comp IN {OPM.Array, OPM.DynArr}) & (y^.typ^.BaseTyp^.form=OPM.Char)) OR (g=OPM.String)); + IF xCharArr & (g = OPM.Char) & (y^.class = OPM.Nconst) THEN CharToString(y); g := OPM.String; yCharArr := TRUE END ; + IF yCharArr & (f = OPM.Char) & (x^.class = OPM.Nconst) THEN CharToString(x); f := OPM.String; xCharArr := TRUE END ; ok := xCharArr & yCharArr; IF ok THEN (* replace ""-string compare with 0X-char compare, if possible *) - IF (f=String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *) + IF (f=OPM.String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *) x^.typ := OPT.chartyp; x^.conval^.intval := 0; Index(y, NewIntConst(0)) - ELSIF (g=String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *) + ELSIF (g=OPM.String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *) y^.typ := OPT.chartyp; y^.conval^.intval := 0; Index(x, NewIntConst(0)) END @@ -765,146 +709,146 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) BEGIN z := x; - IF (z^.class = Ntype) OR (z^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (z^.class = Nconst) & (y^.class = Nconst) THEN ConstOp(op, z, y); z^.obj := NIL + IF (z^.class = OPM.Ntype) OR (z^.class = OPM.Nproc) OR (y^.class = OPM.Ntype) OR (y^.class = OPM.Nproc) THEN err(126) + ELSIF (z^.class = OPM.Nconst) & (y^.class = OPM.Nconst) THEN ConstOp(op, z, y); z^.obj := NIL ELSE IF z^.typ # y^.typ THEN g := y^.typ^.form; CASE z^.typ^.form OF - Char: - IF z^.class = Nconst THEN CharToString(z) ELSE err(100) END - | SInt(*, Int8*): - IF g IN intSet + realSet THEN Convert(z, y^.typ) + OPM.Char: + IF z^.class = OPM.Nconst THEN CharToString(z) ELSE err(100) END + | OPM.SInt(*, Int8*): + IF g IN OPM.intSet + OPM.realSet THEN Convert(z, y^.typ) ELSE err(100) END - | Int: - IF g = SInt THEN Convert(y, z^.typ) - ELSIF g IN intSet + realSet THEN Convert(z, y^.typ) + | OPM.Int: + IF g = OPM.SInt THEN Convert(y, z^.typ) + ELSIF g IN OPM.intSet + OPM.realSet THEN Convert(z, y^.typ) ELSE err(100) END - | LInt(*, Int16, Int32, Int64*): - IF g IN intSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(z, y^.typ) + | OPM.LInt: + IF g IN OPM.intSet THEN Convert(y, z^.typ) + ELSIF g IN OPM.realSet THEN Convert(z, y^.typ) ELSE err(100) END - | Real: - IF g IN intSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(z, y^.typ) + | OPM.Real: + IF g IN OPM.intSet THEN Convert(y, z^.typ) + ELSIF g IN OPM.realSet THEN Convert(z, y^.typ) ELSE err(100) END - | LReal: - IF g IN intSet + realSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(y, z^.typ) + | OPM.LReal: + IF g IN OPM.intSet + OPM.realSet THEN Convert(y, z^.typ) + ELSIF g IN OPM.realSet THEN Convert(y, z^.typ) ELSE err(100) END - | NilTyp: - IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END - | Pointer: + | OPM.NilTyp: + IF ~(g IN {OPM.Pointer, OPM.ProcTyp}) THEN err(100) END + | OPM.Pointer: CheckPtr(z, y) - | ProcTyp: - IF g # NilTyp THEN err(100) END - | String: - | Comp: - IF z^.typ^.comp = Record THEN err(100) END + | OPM.ProcTyp: + IF g # OPM.NilTyp THEN err(100) END + | OPM.String: + | OPM.Comp: + IF z^.typ^.comp = OPM.Record THEN err(100) END ELSE err(100) END END ; (* {z^.typ = y^.typ} *) typ := z^.typ; f := typ^.form; g := y^.typ^.form; CASE op OF - times: + OPM.times: do := TRUE; - IF f IN intSet THEN - IF z^.class = Nconst THEN val := z^.conval^.intval; + IF f IN OPM.intSet THEN + IF z^.class = OPM.Nconst THEN val := z^.conval^.intval; IF val = 1 THEN do := FALSE; z := y ELSIF val = 0 THEN do := FALSE ELSIF log(val) = 1 THEN t := y; y := z; z := t; - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL + op := OPM.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL END - ELSIF y^.class = Nconst THEN val := y^.conval^.intval; + ELSIF y^.class = OPM.Nconst THEN val := y^.conval^.intval; IF val = 1 THEN do := FALSE ELSIF val = 0 THEN do := FALSE; z := y ELSIF log(val) = 1 THEN - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL + op := OPM.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL END END - ELSIF ~(f IN {Undef, Real..Set}) THEN err(105); typ := OPT.undftyp + ELSIF ~(f IN {OPM.Undef, OPM.Real..OPM.Set}) THEN err(105); typ := OPT.undftyp END ; IF do THEN NewOp(op, typ, z, y) END - | slash: - IF f IN intSet THEN - IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN err(205) END ; + | OPM.slash: + IF f IN OPM.intSet THEN + IF (y^.class = OPM.Nconst) & (y^.conval^.intval = 0) THEN err(205) END ; Convert(z, OPT.realtyp); Convert(y, OPT.realtyp); typ := OPT.realtyp - ELSIF f IN realSet THEN - IF (y^.class = Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END - ELSIF (f # Set) & (f # Undef) THEN err(102); typ := OPT.undftyp + ELSIF f IN OPM.realSet THEN + IF (y^.class = OPM.Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END + ELSIF (f # OPM.Set) & (f # OPM.Undef) THEN err(102); typ := OPT.undftyp END ; NewOp(op, typ, z, y) - | div: + | OPM.div: do := TRUE; - IF f IN intSet THEN - IF y^.class = Nconst THEN val := y^.conval^.intval; + IF f IN OPM.intSet THEN + IF y^.class = OPM.Nconst THEN val := y^.conval^.intval; IF val = 0 THEN err(205) ELSIF val = 1 THEN do := FALSE ELSIF log(val) = 1 THEN - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL + op := OPM.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL END END - ELSIF f # Undef THEN err(103); typ := OPT.undftyp + ELSIF f # OPM.Undef THEN err(103); typ := OPT.undftyp END ; IF do THEN NewOp(op, typ, z, y) END - | mod: - IF f IN intSet THEN - IF y^.class = Nconst THEN + | OPM.mod: + IF f IN OPM.intSet THEN + IF y^.class = OPM.Nconst THEN IF y^.conval^.intval = 0 THEN err(205) ELSIF log(y^.conval^.intval) = 1 THEN - op := msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL + op := OPM.msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL END END - ELSIF f # Undef THEN err(104); typ := OPT.undftyp + ELSIF f # OPM.Undef THEN err(104); typ := OPT.undftyp END ; NewOp(op, typ, z, y) - | and: - IF f = Bool THEN - IF z^.class = Nconst THEN + | OPM.and: + IF f = OPM.Bool THEN + IF z^.class = OPM.Nconst THEN IF IntToBool(z^.conval^.intval) THEN z := y END - ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *) - (* ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN + ELSIF (y^.class = OPM.Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *) + (* ELSIF (y^.class = OPM.Nconst) & ~IntToBool(y^.conval^.intval) THEN don't optimize z & FALSE -> FALSE: side effects possible *) ELSE NewOp(op, typ, z, y) END - ELSIF f # Undef THEN err(94); z^.typ := OPT.undftyp + ELSIF f # OPM.Undef THEN err(94); z^.typ := OPT.undftyp END - | plus: - IF ~(f IN {Undef, SInt..Set(*, Int8..Int64*)}) THEN err(105); typ := OPT.undftyp END ; + | OPM.plus: + IF ~(f IN {OPM.Undef, OPM.SInt..OPM.Set(*, Int8..Int64*)}) THEN err(105); typ := OPT.undftyp END ; do := TRUE; - IF f IN intSet THEN - IF (z^.class = Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ; - IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END + IF f IN OPM.intSet THEN + IF (z^.class = OPM.Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ; + IF (y^.class = OPM.Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END END ; IF do THEN NewOp(op, typ, z, y) END - | minus: - IF ~(f IN {Undef, SInt..Set(*, Int8..Int64*)}) THEN err(106); typ := OPT.undftyp END ; - IF ~(f IN intSet) OR (y^.class # Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END - | or: - IF f = Bool THEN - IF z^.class = Nconst THEN + | OPM.minus: + IF ~(f IN {OPM.Undef, OPM.SInt..OPM.Set(*, Int8..Int64*)}) THEN err(106); typ := OPT.undftyp END ; + IF ~(f IN OPM.intSet) OR (y^.class # OPM.Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END + | OPM.or: + IF f = OPM.Bool THEN + IF z^.class = OPM.Nconst THEN IF ~IntToBool(z^.conval^.intval) THEN z := y END - ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *) - (* ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN + ELSIF (y^.class = OPM.Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *) + (* ELSIF (y^.class = OPM.Nconst) & IntToBool(y^.conval^.intval) THEN don't optimize z OR TRUE -> TRUE: side effects possible *) ELSE NewOp(op, typ, z, y) END - ELSIF f # Undef THEN err(95); z^.typ := OPT.undftyp + ELSIF f # OPM.Undef THEN err(95); z^.typ := OPT.undftyp END - | eql, neq: - IF (f IN {Undef..Set, NilTyp, Pointer, ProcTyp(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp + | OPM.eql, OPM.neq: + IF (f IN {OPM.Undef..OPM.Set, OPM.NilTyp, OPM.Pointer, OPM.ProcTyp(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp ELSE err(107); typ := OPT.undftyp END ; NewOp(op, typ, z, y) - | lss, leq, gtr, geq: - IF (f IN {Undef, Char..LReal(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp + | OPM.lss, OPM.leq, OPM.gtr, OPM.geq: + IF (f IN {OPM.Undef, OPM.Char..OPM.LReal(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp ELSE OPM.LogWLn; OPM.LogWStr("ELSE in Op()"); OPM.LogWLn; err(108); typ := OPT.undftyp @@ -920,23 +864,23 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node); VAR k, l: LONGINT; BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (x^.typ^.form IN intSet) & (y^.typ^.form IN intSet) THEN - IF x^.class = Nconst THEN + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) OR (y^.class = OPM.Ntype) OR (y^.class = OPM.Nproc) THEN err(126) + ELSIF (x^.typ^.form IN OPM.intSet) & (y^.typ^.form IN OPM.intSet) THEN + IF x^.class = OPM.Nconst THEN k := x^.conval^.intval; IF (0 > k) OR (k > OPM.MaxSet) THEN err(202) END END ; - IF y^.class = Nconst THEN + IF y^.class = OPM.Nconst THEN l := y^.conval^.intval; IF (0 > l) OR (l > OPM.MaxSet) THEN err(202) END END ; - IF (x^.class = Nconst) & (y^.class = Nconst) THEN + IF (x^.class = OPM.Nconst) & (y^.class = OPM.Nconst) THEN IF k <= l THEN x^.conval^.setval := {k..l} ELSE err(201); x^.conval^.setval := {l..k} END ; x^.obj := NIL - ELSE BindNodes(Nupto, OPT.settyp, x, y) + ELSE BindNodes(OPM.Nupto, OPT.settyp, x, y) END ELSE err(93) END ; @@ -946,9 +890,9 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE SetElem*(VAR x: OPT.Node); VAR k: LONGINT; BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(x^.typ^.form IN intSet) THEN err(93) - ELSIF x^.class = Nconst THEN + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF ~(x^.typ^.form IN OPM.intSet) THEN err(93) + ELSIF x^.class = OPM.Nconst THEN k := x^.conval^.intval; IF (0 <= k) & (k <= OPM.MaxSet) THEN x^.conval^.setval := {k} ELSE err(202) @@ -960,7 +904,11 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END SetElem; PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node); (* x := y *) - VAR f, g: INTEGER; y, p, q: OPT.Struct; + VAR (* x is designator (target) type *) + y: OPT.Struct; (* expression (source) type *) + f: INTEGER; (* designator (target) form *) + g: INTEGER; (* expression (source) form *) + p, q: OPT.Struct; BEGIN IF OPM.Verbose THEN OPM.LogWLn; OPM.LogWStr("PROCEDURE CheckAssign"); OPM.LogWLn; @@ -972,108 +920,76 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) OPM.LogWStr("g = "); OPM.LogWNum(g, 0); OPM.LogWLn; OPM.LogWStr("ynode.typ.syze = "); OPM.LogWNum(ynode.typ.size, 0); OPM.LogWLn; END; - IF (ynode^.class = Ntype) OR (ynode^.class = Nproc) & (f # ProcTyp) THEN err(126) END ; + IF (ynode^.class = OPM.Ntype) OR (ynode^.class = OPM.Nproc) & (f # OPM.ProcTyp) THEN err(126) END ; CASE f OF - Undef, String: - (* | Int8: - IF (ynode.typ.size > OPM.Int8Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int8"); OPM.LogWLn END; - err(113) - END - | Int16: - IF (ynode.typ.size > OPM.Int16Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int16"); OPM.LogWLn END; - err(113) - END - | Int32: - IF (ynode.typ.size > OPM.Int32Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int32"); OPM.LogWLn END; - err(113) - END - | Int64: - IF ynode.typ.size > OPM.Int64Size THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int64"); OPM.LogWLn END; - err(113) - END*) - | Byte: - IF ~(g IN {Byte, Char, SInt}) THEN err(113) END - | Bool, Char, SInt, Set: - IF g # f THEN err(113) END - | Int: - IF ~(g IN {SInt, Int}) THEN err(113) END - | LInt: - IF OPM.LIntSize = 4 THEN - IF ~(g IN {SInt, Int, LInt(*, Int8, Int16, Int32*)}) THEN err(113) END - ELSE (* assume OPM.LIntSize = 8 *) - IF ~(g IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN err(113) END - END; - | Real: - IF ~(g IN {SInt..Real}) THEN err(113) END - | LReal: - IF ~(g IN {SInt..LReal}) THEN err(113) END - | Pointer: - IF (x = y) OR (g = NilTyp) OR (x = OPT.sysptrtyp) & (g = Pointer) THEN (* ok *) - ELSIF g = Pointer THEN - p := x^.BaseTyp; q := y^.BaseTyp; - IF (p^.comp = Record) & (q^.comp = Record) THEN - WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; - IF q = NIL THEN err(113) END - ELSE err(113) - END - ELSE err(113) - END - | ProcTyp: - IF ynode^.class = Nproc THEN CheckProc(x, ynode^.obj) - ELSIF (x = y) OR (g = NilTyp) THEN (* ok *) - ELSE err(113) - END - | NoTyp, NilTyp: - err(113) - | Comp: - x^.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) - IF x^.comp = Array THEN - IF (ynode^.class = Nconst) & (g = Char) THEN CharToString(ynode); y := ynode^.typ; g := String END ; - IF x = y THEN (* ok *) - ELSIF x^.BaseTyp = OPT.chartyp THEN (* Assign to (static) ARRAY OF CHAR *) - IF g = String THEN (*check length of string*) - IF ynode^.conval^.intval2 > x^.n THEN err(114) END - ELSIF (y.comp IN {DynArr, Array}) & (y.BaseTyp = OPT.chartyp) THEN - (* Assignment from ARRAY OF CHAR is good.*) - ELSE err(113) - END - ELSE err(113) - END - ELSIF (x.comp = DynArr) & (x^.BaseTyp = OPT.chartyp) THEN (* Assign to dynamic ARRAY OF CHAR*) - IF (y.comp IN {DynArr, Array}) & (y.BaseTyp = OPT.chartyp) THEN - (* Assignment from ARRAY OF CHAR is good.*) - ELSE err(113) - END - ELSIF x^.comp = Record THEN - IF x = y THEN (* ok *) - ELSIF y^.comp = Record THEN - q := y^.BaseTyp; - WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; - IF q = NIL THEN err(113) END - ELSE err(113) - END - ELSE err(113) - END - ELSE (* In case of not estimated f it would crash -- noch *) - OPM.LogWStr("unhandled case in OPB.CheckAssign, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + OPM.Undef, + OPM.String: + | OPM.Byte: IF ~(g IN {OPM.Byte, OPM.Char, OPM.SInt}) THEN err(113) END + | OPM.Bool, + OPM.Char, + OPM.SInt, + OPM.Set: IF g # f THEN err(113) END + | OPM.Int: IF ~(g IN {OPM.SInt, OPM.Int}) THEN err(113) END + | OPM.LInt: IF ~(g IN OPM.intSet) THEN err(113) END + | OPM.Real: IF ~(g IN {OPM.SInt..OPM.Real}) THEN err(113) END + | OPM.LReal: IF ~(g IN {OPM.SInt..OPM.LReal}) THEN err(113) END + | OPM.Pointer: IF (x = y) OR (g = OPM.NilTyp) OR (x = OPT.sysptrtyp) & (g = OPM.Pointer) THEN (* ok *) + ELSIF g = OPM.Pointer THEN + p := x^.BaseTyp; q := y^.BaseTyp; + IF (p^.comp = OPM.Record) & (q^.comp = OPM.Record) THEN + WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; + IF q = NIL THEN err(113) END + ELSE err(113) + END + ELSE err(113) + END + | OPM.ProcTyp: IF ynode^.class = OPM.Nproc THEN CheckProc(x, ynode^.obj) + ELSIF (x = y) OR (g = OPM.NilTyp) THEN (* ok *) + ELSE err(113) + END + | OPM.NoTyp, + OPM.NilTyp: err(113) + | OPM.Comp: x^.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) + IF x^.comp = OPM.Array THEN + IF (ynode^.class = OPM.Nconst) & (g = OPM.Char) THEN CharToString(ynode); y := ynode^.typ; g := OPM.String END ; + IF x = y THEN (* ok *) + ELSIF x^.BaseTyp = OPT.chartyp THEN (* Assign to (static) ARRAY OF CHAR *) + IF g = OPM.String THEN (*check length of string*) + IF ynode^.conval^.intval2 > x^.n THEN err(114) END + ELSIF (y.comp IN {OPM.DynArr, OPM.Array}) & (y.BaseTyp = OPT.chartyp) THEN + (* Assignment from ARRAY OF CHAR is good.*) + ELSE err(113) + END + ELSE err(113) + END + ELSIF (x.comp = OPM.DynArr) & (x^.BaseTyp = OPT.chartyp) THEN (* Assign to dynamic ARRAY OF CHAR*) + IF (y.comp IN {OPM.DynArr, OPM.Array}) & (y.BaseTyp = OPT.chartyp) THEN + (* Assignment from ARRAY OF CHAR is good.*) + ELSE err(113) + END + ELSIF x^.comp = OPM.Record THEN + IF x = y THEN (* ok *) + ELSIF y^.comp = OPM.Record THEN + q := y^.BaseTyp; + WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; + IF q = NIL THEN err(113) END + ELSE err(113) + END + ELSE err(113) + END + ELSE OPM.LogWStr("unhandled case in OPB.CheckAssign, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; END ; - IF (ynode^.class = Nconst) & (g < f) & (g IN {SInt..Real}) & (f IN {Int..LReal}) THEN + IF (ynode^.class = OPM.Nconst) & (g < f) & (g IN {OPM.SInt..OPM.Real}) & (f IN {OPM.Int..OPM.LReal}) THEN Convert(ynode, x) END END CheckAssign; PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN); BEGIN -(* -avoid unnecessary intermediate variables in voc - - IF (x^.class = Nmop) & (x^.subcl = val) THEN x := x^.left END ; - IF x^.class = Nguard THEN x := x^.left END ; (* skip last (and unique) guard *) - IF (x^.class = Nvar) & (dynArrToo OR (x^.typ^.comp # DynArr)) THEN x^.obj^.leaf := FALSE END +(* avoid unnecessary intermediate variables in voc + IF (x^.class = OPM.Nmop) & (x^.subcl = val) THEN x := x^.left END ; + IF x^.class = OPM.Nguard THEN x := x^.left END ; (* skip last (and unique) guard *) + IF (x^.class = OPM.Nvar) & (dynArrToo OR (x^.typ^.comp # OPM.DynArr)) THEN x^.obj^.leaf := FALSE END *) END CheckLeaf; @@ -1081,174 +997,160 @@ avoid unnecessary intermediate variables in voc VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node; BEGIN x := par0; f := x^.typ^.form; CASE fctno OF - haltfn: (*HALT*) - IF (f IN intSet) & (x^.class = Nconst) THEN + OPM.haltfn: (*HALT*) + IF (f IN OPM.intSet) & (x^.class = OPM.Nconst) THEN IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN - BindNodes(Ntrap, OPT.notyp, x, x) + BindNodes(OPM.Ntrap, OPT.notyp, x, x) ELSE err(218) END ELSE err(69) END ; x^.typ := OPT.notyp - | newfn: (*NEW*) + | OPM.newfn: (*NEW*) typ := OPT.notyp; IF NotVar(x) THEN err(112) - ELSIF f = Pointer THEN + ELSIF f = OPM.Pointer THEN IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; IF x^.readonly THEN err(76) END ; f := x^.typ^.BaseTyp^.comp; - IF f IN {Record, DynArr, Array} THEN - IF f = DynArr THEN typ := x^.typ^.BaseTyp END ; - BindNodes(Nassign, OPT.notyp, x, NIL); x^.subcl := newfn + IF f IN {OPM.Record, OPM.DynArr, OPM.Array} THEN + IF f = OPM.DynArr THEN typ := x^.typ^.BaseTyp END ; + BindNodes(OPM.Nassign, OPT.notyp, x, NIL); x^.subcl := OPM.newfn ELSE err(111) END ELSE err(111) END ; x^.typ := typ - | absfn: (*ABS*) - MOp(abs, x) - | capfn: (*CAP*) - MOp(cap, x) - | ordfn: (*ORD*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = Char THEN Convert(x, OPT.inttyp) + | OPM.absfn: (*ABS*) + MOp(OPM.abs, x) + | OPM.capfn: (*CAP*) + MOp(OPM.cap, x) + | OPM.ordfn: (*ORD*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f = OPM.Char THEN Convert(x, OPT.inttyp) ELSE err(111) END ; x^.typ := OPT.inttyp - | entierfn: (*ENTIER*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN realSet THEN Convert(x, OPT.linttyp) + | OPM.entierfn: (*ENTIER*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN OPM.realSet THEN Convert(x, OPT.linttyp) ELSE err(111) END ; x^.typ := OPT.linttyp - | oddfn: (*ODD*) - MOp(odd, x) - | minfn: (*MIN*) - IF x^.class = Ntype THEN + | OPM.oddfn: (*ODD*) + MOp(OPM.odd, x) + | OPM.minfn: (*MIN*) + IF x^.class = OPM.Ntype THEN CASE f OF - Bool: x := NewBoolConst(FALSE) - | Char: x := NewIntConst(0); x^.typ := OPT.chartyp - | SInt: x := NewIntConst(OPM.MinSInt) - | Int: x := NewIntConst(OPM.MinInt) - | LInt: x := NewIntConst(OPM.MinLInt) - (* | Int8: x := NewIntConst(OPM.MinInt8) - | Int16: x := NewIntConst(OPM.MinInt16) - | Int32: x := NewIntConst(OPM.MinInt32) - | Int64: err(111)(*x := NewIntConst(OPM.MinInt64)*) (* int64 constants not implemented yet *)*) - | Set: x := NewIntConst(0); x^.typ := OPT.inttyp - | Real: x := NewRealConst(OPM.MinReal, OPT.realtyp) - | LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp) + OPM.Bool: x := NewBoolConst(FALSE) + | OPM.Char: x := NewIntConst(0); x^.typ := OPT.chartyp + | OPM.SInt: x := NewIntConst(OPM.MinSInt) + | OPM.Int: x := NewIntConst(OPM.MinInt) + | OPM.LInt: x := NewIntConst(OPM.MinLInt) + | OPM.Set: x := NewIntConst(0); x^.typ := OPT.inttyp + | OPM.Real: x := NewRealConst(OPM.MinReal, OPT.realtyp) + | OPM.LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp) ELSE err(111) END ELSE err(110) END - | maxfn: (*MAX*) - IF x^.class = Ntype THEN + | OPM.maxfn: (*MAX*) + IF x^.class = OPM.Ntype THEN CASE f OF - Bool: x := NewBoolConst(TRUE) - | Char: x := NewIntConst(0FFH); x^.typ := OPT.chartyp - | SInt: x := NewIntConst(OPM.MaxSInt) - | Int: x := NewIntConst(OPM.MaxInt) - | LInt: x := NewIntConst(OPM.MaxLInt) - (* | Int8: x := NewIntConst(OPM.MaxInt8) - | Int16: x := NewIntConst(OPM.MaxInt16) - | Int32: x := NewIntConst(OPM.MaxInt32) - | Int64: err(111); (*x := NewIntConst(OPM.MaxInt64)*) (* int64 contstants not implemented yet *)*) - | Set: x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp - | Real: x := NewRealConst(OPM.MaxReal, OPT.realtyp) - | LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp) + OPM.Bool: x := NewBoolConst(TRUE) + | OPM.Char: x := NewIntConst(0FFH); x^.typ := OPT.chartyp + | OPM.SInt: x := NewIntConst(OPM.MaxSInt) + | OPM.Int: x := NewIntConst(OPM.MaxInt) + | OPM.LInt: x := NewIntConst(OPM.MaxLInt) + | OPM.Set: x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp + | OPM.Real: x := NewRealConst(OPM.MaxReal, OPT.realtyp) + | OPM.LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp) ELSE err(111) END ELSE err(110) END - | chrfn: (*CHR*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN {Undef, SInt..LInt(*, Int8..Int64*)} THEN Convert(x, OPT.chartyp) + | OPM.chrfn: (*CHR*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN {OPM.Undef} + OPM.intSet THEN Convert(x, OPT.chartyp) ELSE err(111); x^.typ := OPT.chartyp END - | shortfn: (*SHORT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = Int THEN Convert(x, OPT.sinttyp) - ELSIF f = LInt THEN Convert(x, OPT.inttyp) - (*ELSIF f = Int64 THEN Convert(x, OPT.int32typ) - ELSIF f = Int32 THEN Convert(x, OPT.int16typ) - ELSIF f = Int16 THEN Convert(x, OPT.int8typ)*) - ELSIF f = LReal THEN Convert(x, OPT.realtyp) + | OPM.shortfn: (*SHORT*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f = OPM.Int THEN Convert(x, OPT.sinttyp) + ELSIF f = OPM.LInt THEN Convert(x, OPT.inttyp) + ELSIF f = OPM.LReal THEN Convert(x, OPT.realtyp) ELSE err(111) END - | longfn: (*LONG*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = SInt THEN Convert(x, OPT.inttyp) - ELSIF f = Int THEN Convert(x, OPT.linttyp) - (*ELSIF f = Int8 THEN Convert(x, OPT.int16typ) - ELSIF f = Int16 THEN Convert(x, OPT.int32typ) - ELSIF f = Int32 THEN Convert(x, OPT.int64typ)*) - ELSIF f = Real THEN Convert(x, OPT.lrltyp) - ELSIF f = Char THEN Convert(x, OPT.linttyp) + | OPM.longfn: (*LONG*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f = OPM.SInt THEN Convert(x, OPT.inttyp) + ELSIF f = OPM.Int THEN Convert(x, OPT.linttyp) + ELSIF f = OPM.Real THEN Convert(x, OPT.lrltyp) + ELSIF f = OPM.Char THEN Convert(x, OPT.linttyp) ELSE err(111) END - | incfn, decfn: (*INC, DEC*) + | OPM.incfn, OPM.decfn: (*INC, DEC*) IF NotVar(x) THEN err(112) - ELSIF ~(f IN intSet) THEN err(111) + ELSIF ~(f IN OPM.intSet) THEN err(111) ELSIF x^.readonly THEN err(76) END - | inclfn, exclfn: (*INCL, EXCL*) + | OPM.inclfn, OPM.exclfn: (*INCL, EXCL*) IF NotVar(x) THEN err(112) ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp ELSIF x^.readonly THEN err(76) END - | lenfn: (*LEN*) - IF ~(x^.typ^.comp IN {DynArr, Array}) THEN err(131) END - | copyfn: (*COPY*) - IF (x^.class = Nconst) & (f = Char) THEN CharToString(x); f := String END ; - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (~(x^.typ^.comp IN {DynArr, Array}) OR (x^.typ^.BaseTyp^.form # Char)) - & (f # String) THEN err(111) + | OPM.lenfn: (*LEN*) + IF ~(x^.typ^.comp IN {OPM.DynArr, OPM.Array}) THEN err(131) END + | OPM.copyfn: (*COPY*) + IF (x^.class = OPM.Nconst) & (f = OPM.Char) THEN CharToString(x); f := OPM.String END ; + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF (~(x^.typ^.comp IN {OPM.DynArr, OPM.Array}) OR (x^.typ^.BaseTyp^.form # OPM.Char)) + & (f # OPM.String) THEN err(111) END - | ashfn: (*ASH*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF f # LInt THEN Convert(x, OPT.linttyp) END + | OPM.ashfn: (*ASH*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN OPM.intSet THEN + IF f # OPM.LInt THEN Convert(x, OPT.linttyp) END ELSE err(111); x^.typ := OPT.linttyp END - | adrfn: (*SYSTEM.ADR*) - CheckLeaf(x, FALSE); MOp(adr, x) - | sizefn: (*SIZE*) - IF x^.class # Ntype THEN err(110); x := NewIntConst(1) - ELSIF (f IN {Byte..Set(*, Int8..Int64*), Pointer, ProcTyp}) OR (x^.typ^.comp IN {Array, Record}) THEN + | OPM.adrfn: (*SYSTEM.ADR*) + CheckLeaf(x, FALSE); MOp(OPM.adr, x) + | OPM.sizefn: (*SIZE*) + IF x^.class # OPM.Ntype THEN err(110); x := NewIntConst(1) + ELSIF (f IN {OPM.Byte..OPM.Set(*, Int8..Int64*), OPM.Pointer, OPM.ProcTyp}) OR (x^.typ^.comp IN {OPM.Array, OPM.Record}) THEN typSize(x^.typ); x^.typ^.pvused := TRUE; x := NewIntConst(x^.typ^.size) ELSE err(111); x := NewIntConst(1) END - | ccfn: (*SYSTEM.CC*) - MOp(cc, x) - | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(f IN intSet + {Byte, Char, Set(*, Int8, Int16, Int32, Int64*)}) THEN err(111) + | OPM.ccfn: (*SYSTEM.CC*) + MOp(OPM.cc, x) + | OPM.lshfn, OPM.rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF ~(f IN OPM.intSet + {OPM.Byte, OPM.Char, OPM.Set}) THEN err(111) END - | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp) - ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp + | OPM.getfn, OPM.putfn, OPM.bitfn, OPM.movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF (x^.class = OPM.Nconst) & (f IN {OPM.SInt, OPM.Int}) THEN Convert(x, OPT.linttyp) + ELSIF ~(f IN {OPM.LInt, OPM.Pointer}) THEN err(111); x^.typ := OPT.linttyp END - | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) - IF (f IN intSet) & (x^.class = Nconst) THEN + | OPM.getrfn, OPM.putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (f IN OPM.intSet) & (x^.class = OPM.Nconst) THEN IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END ELSE err(69) END - | valfn: (*SYSTEM.VAL*) - IF x^.class # Ntype THEN err(110) - ELSIF (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(111) + | OPM.valfn: (*SYSTEM.VAL*) + IF x^.class # OPM.Ntype THEN err(110) + ELSIF (f IN {OPM.Undef, OPM.String, OPM.NoTyp}) OR (x^.typ^.comp = OPM.DynArr) THEN err(111) END - | sysnewfn: (*SYSTEM.NEW*) + | OPM.sysnewfn: (*SYSTEM.NEW*) IF NotVar(x) THEN err(112) - ELSIF f = Pointer THEN + ELSIF f = OPM.Pointer THEN IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ELSE err(111) END - | assertfn: (*ASSERT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := NewBoolConst(FALSE) - ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE) - ELSE MOp(not, x) + | OPM.assertfn: (*ASSERT*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126); x := NewBoolConst(FALSE) + ELSIF f # OPM.Bool THEN err(120); x := NewBoolConst(FALSE) + ELSE MOp(OPM.not, x) END ELSE OPM.LogWStr("unhandled case in OPB.StPar0, fctno = "); OPM.LogWNum(fctno, 0); OPM.LogWLn; @@ -1268,53 +1170,53 @@ avoid unnecessary intermediate variables in voc BEGIN p := par0; f := x^.typ^.form; CASE fctno OF - incfn, decfn: (*INC DEC*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); p^.typ := OPT.notyp + OPM.incfn, OPM.decfn: (*INC DEC*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126); p^.typ := OPT.notyp ELSE IF x^.typ # p^.typ THEN - IF (x^.class = Nconst) & (f IN intSet) THEN Convert(x, p^.typ) + IF (x^.class = OPM.Nconst) & (f IN OPM.intSet) THEN Convert(x, p^.typ) ELSE err(111) END END ; - p := NewOp(Nassign, fctno, p, x); + p := NewOp(OPM.Nassign, fctno, p, x); p^.typ := OPT.notyp END - | inclfn, exclfn: (*INCL, EXCL*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF (x^.class = Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202) + | OPM.inclfn, OPM.exclfn: (*INCL, EXCL*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN OPM.intSet THEN + IF (x^.class = OPM.Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202) END ; - p := NewOp(Nassign, fctno, p, x) + p := NewOp(OPM.Nassign, fctno, p, x) ELSE err(111) END ; p^.typ := OPT.notyp - | lenfn: (*LEN*) - IF ~(f IN intSet) OR (x^.class # Nconst) THEN err(69) - ELSIF f = SInt THEN + | OPM.lenfn: (*LEN*) + IF ~(f IN OPM.intSet) OR (x^.class # OPM.Nconst) THEN err(69) + ELSIF f = OPM.SInt THEN L := SHORT(x^.conval^.intval); typ := p^.typ; - WHILE (L > 0) & (typ^.comp IN {DynArr, Array}) DO typ := typ^.BaseTyp; DEC(L) END ; - IF (L # 0) OR ~(typ^.comp IN {DynArr, Array}) THEN err(132) + WHILE (L > 0) & (typ^.comp IN {OPM.DynArr, OPM.Array}) DO typ := typ^.BaseTyp; DEC(L) END ; + IF (L # 0) OR ~(typ^.comp IN {OPM.DynArr, OPM.Array}) THEN err(132) ELSE x^.obj := NIL; - IF typ^.comp = DynArr THEN - WHILE p^.class = Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *) - p := NewOp(Ndop, len, p, x); p^.typ := OPT.linttyp + IF typ^.comp = OPM.DynArr THEN + WHILE p^.class = OPM.Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *) + p := NewOp(OPM.Ndop, OPM.len, p, x); p^.typ := OPT.linttyp ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p) END END ELSE err(132) END - | copyfn: (*COPY*) + | OPM.copyfn: (*COPY*) IF NotVar(x) THEN err(112) - ELSIF (x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form = Char) THEN + ELSIF (x^.typ^.comp IN {OPM.Array, OPM.DynArr}) & (x^.typ^.BaseTyp^.form = OPM.Char) THEN IF x^.readonly THEN err(76) END ; - t := x; x := p; p := t; p := NewOp(Nassign, copyfn, p, x) + t := x; x := p; p := t; p := NewOp(OPM.Nassign, OPM.copyfn, p, x) ELSE err(111) END ; p^.typ := OPT.notyp - | ashfn: (*ASH*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF (p^.class = Nconst) & (x^.class = Nconst) THEN + | OPM.ashfn: (*ASH*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN OPM.intSet THEN + IF (p^.class = OPM.Nconst) & (x^.class = OPM.Nconst) THEN IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1 ELSIF x^.conval^.intval >= 0 THEN IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN @@ -1324,80 +1226,80 @@ avoid unnecessary intermediate variables in voc ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval) END ; p^.obj := NIL - ELSE p := NewOp(Ndop, ash, p, x); p^.typ := OPT.linttyp + ELSE p := NewOp(OPM.Ndop, OPM.ash, p, x); p^.typ := OPT.linttyp END ELSE err(111) END - | newfn: (*NEW(p, x...)*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF p^.typ^.comp = DynArr THEN - IF f IN intSet THEN - IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END + | OPM.newfn: (*NEW(p, x...)*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF p^.typ^.comp = OPM.DynArr THEN + IF f IN OPM.intSet THEN + IF (x^.class = OPM.Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ELSE err(111) END ; p^.right := x; p^.typ := p^.typ^.BaseTyp ELSE err(64) END - | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(f IN intSet) THEN err(111) + | OPM.lshfn, OPM.rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF ~(f IN OPM.intSet) THEN err(111) ELSE - IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ; + IF fctno = OPM.lshfn THEN p := NewOp(OPM.Ndop, OPM.lsh, p, x) ELSE p := NewOp(OPM.Ndop, OPM.rot, p, x) END ; p^.typ := p^.left^.typ END - | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN {Undef..Set, Pointer, ProcTyp} THEN - IF (fctno = getfn) OR (fctno = getrfn) THEN + | OPM.getfn, OPM.putfn, OPM.getrfn, OPM.putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN {OPM.Undef..OPM.Set, OPM.Pointer, OPM.ProcTyp} THEN + IF (fctno = OPM.getfn) OR (fctno = OPM.getrfn) THEN IF NotVar(x) THEN err(112) END ; t := x; x := p; p := t END ; - p := NewOp(Nassign, fctno, p, x) + p := NewOp(OPM.Nassign, fctno, p, x) ELSE err(111) END ; p^.typ := OPT.notyp - | bitfn: (*SYSTEM.BIT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - p := NewOp(Ndop, bit, p, x) + | OPM.bitfn: (*SYSTEM.BIT*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN OPM.intSet THEN + p := NewOp(OPM.Ndop, OPM.bit, p, x) ELSE err(111) END ; p^.typ := OPT.booltyp - | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) - IF (x^.class = Ntype) OR (x^.class = Nproc) OR - (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(126) + | OPM.valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) OR + (f IN {OPM.Undef, OPM.String, OPM.NoTyp}) OR (x^.typ^.comp = OPM.DynArr) THEN err(126) END ; - t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t; + t := OPT.NewNode(OPM.Nmop); t^.subcl := OPM.val; t^.left := x; x := t; (* - IF (x^.class >= Nconst) OR ((f IN realSet) # (p^.typ^.form IN realSet)) THEN - t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t + IF (x^.class >= OPM.Nconst) OR ((f IN OPM.realSet) # (p^.typ^.form IN OPM.realSet)) THEN + t := OPT.NewNode(OPM.Nmop); t^.subcl := val; t^.left := x; x := t ELSE x^.readonly := FALSE END ; *) x^.typ := p^.typ; p := x - | sysnewfn: (*SYSTEM.NEW*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - p := NewOp(Nassign, sysnewfn, p, x) + | OPM.sysnewfn: (*SYSTEM.NEW*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN OPM.intSet THEN + p := NewOp(OPM.Nassign, OPM.sysnewfn, p, x) ELSE err(111) END ; p^.typ := OPT.notyp - | movefn: (*SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp) - ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp + | OPM.movefn: (*SYSTEM.MOVE*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF (x^.class = OPM.Nconst) & (f IN {OPM.SInt, OPM.Int}) THEN Convert(x, OPT.linttyp) + ELSIF ~(f IN {OPM.LInt, OPM.Pointer}) THEN err(111); x^.typ := OPT.linttyp END ; p^.link := x - | assertfn: (*ASSERT*) - IF (f IN intSet) & (x^.class = Nconst) THEN + | OPM.assertfn: (*ASSERT*) + IF (f IN OPM.intSet) & (x^.class = OPM.Nconst) THEN IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN - BindNodes(Ntrap, OPT.notyp, x, x); + BindNodes(OPM.Ntrap, OPT.notyp, x, x); x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; - Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; - Construct(Nifelse, p, NIL); OptIf(p); + Construct(OPM.Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; + Construct(OPM.Nifelse, p, NIL); OptIf(p); IF p = NIL THEN (* ASSERT(TRUE) *) - ELSIF p^.class = Ntrap THEN err(99) - ELSE p^.subcl := assertfn + ELSIF p^.class = OPM.Ntrap THEN err(99) + ELSE p^.subcl := OPM.assertfn END ELSE err(218) END @@ -1411,19 +1313,19 @@ avoid unnecessary intermediate variables in voc PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER); (* x: n+1-th param of standard proc *) VAR node: OPT.Node; f: INTEGER; p: OPT.Node; BEGIN p := par0; f := x^.typ^.form; - IF fctno = newfn THEN (*NEW(p, ..., x...*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF p^.typ^.comp # DynArr THEN err(64) - ELSIF f IN intSet THEN - IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ; + IF fctno = OPM.newfn THEN (*NEW(p, ..., x...*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF p^.typ^.comp # OPM.DynArr THEN err(64) + ELSIF f IN OPM.intSet THEN + IF (x^.class = OPM.Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ; node := p^.right; WHILE node^.link # NIL DO node := node^.link END; node^.link := x; p^.typ := p^.typ^.BaseTyp ELSE err(111) END - ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - node := OPT.NewNode(Nassign); node^.subcl := movefn; node^.right := p; + ELSIF (fctno = OPM.movefn) & (n = 2) THEN (*SYSTEM.MOVE*) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF f IN OPM.intSet THEN + node := OPT.NewNode(OPM.Nassign); node^.subcl := OPM.movefn; node^.right := p; node^.left := p^.link; p^.link := x; p := node ELSE err(111) END ; @@ -1436,41 +1338,41 @@ avoid unnecessary intermediate variables in voc PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER); VAR dim: INTEGER; x, p: OPT.Node; BEGIN p := par0; - IF fctno <= ashfn THEN - IF (fctno = newfn) & (p^.typ # OPT.notyp) THEN - IF p^.typ^.comp = DynArr THEN err(65) END ; + IF fctno <= OPM.ashfn THEN + IF (fctno = OPM.newfn) & (p^.typ # OPT.notyp) THEN + IF p^.typ^.comp = OPM.DynArr THEN err(65) END ; p^.typ := OPT.notyp - ELSIF fctno <= sizefn THEN (* 1 param *) + ELSIF fctno <= OPM.sizefn THEN (* 1 param *) IF parno < 1 THEN err(65) END ELSE (* more than 1 param *) - IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*) - BindNodes(Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno; p^.right^.typ := p^.left^.typ - ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*) - IF p^.typ^.comp = DynArr THEN dim := 0; - WHILE p^.class = Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *) - BindNodes(Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := len + IF ((fctno = OPM.incfn) OR (fctno = OPM.decfn)) & (parno = 1) THEN (*INC, DEC*) + BindNodes(OPM.Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno; p^.right^.typ := p^.left^.typ + ELSIF (fctno = OPM.lenfn) & (parno = 1) THEN (*LEN*) + IF p^.typ^.comp = OPM.DynArr THEN dim := 0; + WHILE p^.class = OPM.Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *) + BindNodes(OPM.Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := OPM.len ELSE p := NewIntConst(p^.typ^.n) END ELSIF parno < 2 THEN err(65) END END - ELSIF fctno = assertfn THEN + ELSIF fctno = OPM.assertfn THEN IF parno = 1 THEN x := NIL; - BindNodes(Ntrap, OPT.notyp, x, NewIntConst(AssertTrap)); + BindNodes(OPM.Ntrap, OPT.notyp, x, NewIntConst(AssertTrap)); x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; - Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; - Construct(Nifelse, p, NIL); OptIf(p); + Construct(OPM.Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; + Construct(OPM.Nifelse, p, NIL); OptIf(p); IF p = NIL THEN (* ASSERT(TRUE) *) - ELSIF p^.class = Ntrap THEN err(99) - ELSE p^.subcl := assertfn + ELSIF p^.class = OPM.Ntrap THEN err(99) + ELSE p^.subcl := OPM.assertfn END ELSIF parno < 1 THEN err(65) END ELSE (*SYSTEM*) IF (parno < 1) OR - (fctno > ccfn) & (parno < 2) OR - (fctno = movefn) & (parno < 3) THEN err(65) + (fctno > OPM.ccfn) & (parno < 2) OR + (fctno = OPM.movefn) & (parno < 3) THEN err(65) END END ; par0 := p @@ -1478,18 +1380,18 @@ avoid unnecessary intermediate variables in voc PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN); VAR f: INTEGER; - BEGIN (* ftyp^.comp = DynArr *) + BEGIN (* ftyp^.comp = OPM.DynArr *) f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *) - IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..SInt(*, Int8..Int64*)}) THEN + IF ~(f IN {OPM.Array, OPM.DynArr}) OR ~(atyp^.form IN {OPM.Byte..OPM.SInt(*, Int8..Int64*)}) THEN IF OPM.verbose IN OPM.opt THEN err(-301) END END - ELSIF f IN {Array, DynArr} THEN - IF ftyp^.comp = DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar) + ELSIF f IN {OPM.Array, OPM.DynArr} THEN + IF ftyp^.comp = OPM.DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar) ELSIF ftyp # atyp THEN - IF ~fvarpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN + IF ~fvarpar & (ftyp.form = OPM.Pointer) & (atyp.form = OPM.Pointer) THEN ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; - IF (ftyp^.comp = Record) & (atyp^.comp = Record) THEN + IF (ftyp^.comp = OPM.Record) & (atyp^.comp = OPM.Record) THEN WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ; IF atyp = NIL THEN err(113) END ELSE err(66) @@ -1503,17 +1405,17 @@ avoid unnecessary intermediate variables in voc PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object); BEGIN - IF fp^.typ^.form = Pointer THEN - IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = Record*) err(71) END + IF fp^.typ^.form = OPM.Pointer THEN + IF x^.class = OPM.Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = OPM.Record*) err(71) END END END CheckReceiver; PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object); BEGIN - IF (x^.obj # NIL) & (x^.obj^.mode IN {LProc, XProc, TProc, CProc}) THEN + IF (x^.obj # NIL) & (x^.obj^.mode IN {OPM.LProc, OPM.XProc, OPM.TProc, OPM.CProc}) THEN fpar := x^.obj^.link; - IF x^.obj^.mode = TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END - ELSIF (x^.class # Ntype) & (x^.typ # NIL) & (x^.typ^.form = ProcTyp) THEN + IF x^.obj^.mode = OPM.TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END + ELSIF (x^.class # OPM.Ntype) & (x^.typ # NIL) & (x^.typ^.form = OPM.ProcTyp) THEN fpar := x^.typ^.link ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp END @@ -1522,25 +1424,25 @@ avoid unnecessary intermediate variables in voc PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object); VAR q: OPT.Struct; BEGIN - IF fp.typ.form # Undef THEN - IF fp^.mode = VarPar THEN + IF fp.typ.form # OPM.Undef THEN + IF fp^.mode = OPM.VarPar THEN IF NotVar(ap) THEN err(122) ELSE CheckLeaf(ap, FALSE) END ; IF ap^.readonly THEN err(76) END ; - IF fp^.typ^.comp = DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE) - ELSIF (fp^.typ^.comp = Record) & (ap^.typ^.comp = Record) THEN + IF fp^.typ^.comp = OPM.DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE) + ELSIF (fp^.typ^.comp = OPM.Record) & (ap^.typ^.comp = OPM.Record) THEN q := ap^.typ; WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; IF q = NIL THEN err(111) END - ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = Pointer) THEN (* ok *) - ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = Byte) & (ap^.typ^.form IN {Char, SInt})) THEN err(123) - ELSIF (fp^.typ^.form = Pointer) & (ap^.class = Nguard) THEN err(123) + ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = OPM.Pointer) THEN (* ok *) + ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = OPM.Byte) & (ap^.typ^.form IN {OPM.Char, OPM.SInt})) THEN err(123) + ELSIF (fp^.typ^.form = OPM.Pointer) & (ap^.class = OPM.Nguard) THEN err(123) END - ELSIF fp^.typ^.comp = DynArr THEN - IF (ap^.class = Nconst) & (ap^.typ^.form = Char) THEN CharToString(ap) END ; - IF (ap^.typ^.form = String) & (fp^.typ^.BaseTyp^.form = Char) THEN (* ok *) - ELSIF ap^.class >= Nconst THEN err(59) + ELSIF fp^.typ^.comp = OPM.DynArr THEN + IF (ap^.class = OPM.Nconst) & (ap^.typ^.form = OPM.Char) THEN CharToString(ap) END ; + IF (ap^.typ^.form = OPM.String) & (fp^.typ^.BaseTyp^.form = OPM.Char) THEN (* ok *) + ELSIF ap^.class >= OPM.Nconst THEN err(59) ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE) END ELSE CheckAssign(fp^.typ, ap) @@ -1553,7 +1455,7 @@ avoid unnecessary intermediate variables in voc BEGIN scope := OPT.topScope; WHILE dlev > 0 DO DEC(dlev); - INCL(scope^.link^.conval^.setval, slNeeded); + INCL(scope^.link^.conval^.setval, OPM.slNeeded); scope := scope^.left END END StaticLink; @@ -1561,21 +1463,21 @@ avoid unnecessary intermediate variables in voc PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object); VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT; BEGIN - IF x^.class = Nproc THEN typ := x^.typ; + IF x^.class = OPM.Nproc THEN typ := x^.typ; lev := x^.obj^.mnolev; IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ; - IF x^.obj^.mode = IProc THEN err(121) END - ELSIF (x^.class = Nfield) & (x^.obj^.mode = TProc) THEN typ := x^.typ; - x^.class := Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link + IF x^.obj^.mode = OPM.IProc THEN err(121) END + ELSIF (x^.class = OPM.Nfield) & (x^.obj^.mode = OPM.TProc) THEN typ := x^.typ; + x^.class := OPM.Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link ELSE typ := x^.typ^.BaseTyp END ; - BindNodes(Ncall, typ, x, apar); x^.obj := fp + BindNodes(OPM.Ncall, typ, x, apar); x^.obj := fp END Call; PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object); VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc; + x := OPT.NewNode(OPM.Nenter); x^.typ := OPT.notyp; x^.obj := proc; x^.left := procdec; x^.right := stat; procdec := x END Enter; @@ -1589,42 +1491,42 @@ avoid unnecessary intermediate variables in voc ELSIF proc^.typ # OPT.notyp THEN err(124) END END ; - node := OPT.NewNode(Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node + node := OPT.NewNode(OPM.Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node END Return; PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node); VAR z: OPT.Node; subcl: SHORTINT; BEGIN - IF x^.class >= Nconst THEN err(56) END ; + IF x^.class >= OPM.Nconst THEN err(56) END ; CheckAssign(x^.typ, y); IF x^.readonly THEN err(76) END ; - IF x^.typ^.comp = Record THEN - IF x^.class = Nguard THEN z := x^.left ELSE z := x END ; - IF (z^.class = Nderef) & (z^.left^.class = Nguard) THEN + IF x^.typ^.comp = OPM.Record THEN + IF x^.class = OPM.Nguard THEN z := x^.left ELSE z := x END ; + IF (z^.class = OPM.Nderef) & (z^.left^.class = OPM.Nguard) THEN z^.left := z^.left^.left (* skip guard before dereferencing *) END ; - IF (x^.typ^.strobj # NIL) & ((z^.class = Nderef) OR (z^.class = Nvarpar)) THEN - BindNodes(Neguard, x^.typ, z, NIL); x := z + IF (x^.typ^.strobj # NIL) & ((z^.class = OPM.Nderef) OR (z^.class = OPM.Nvarpar)) THEN + BindNodes(OPM.Neguard, x^.typ, z, NIL); x := z END - ELSIF (x^.typ^.comp = Array) & (x^.typ^.BaseTyp = OPT.chartyp) & - (y^.typ^.form = String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *) + ELSIF (x^.typ^.comp = OPM.Array) & (x^.typ^.BaseTyp = OPT.chartyp) & + (y^.typ^.form = OPM.String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *) y^.typ := OPT.chartyp; y^.conval^.intval := 0; Index(x, NewIntConst(0)) END ; - IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp = OPT.chartyp) - & (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp = OPT.chartyp) THEN - subcl := copyfn + IF (x.typ.comp IN {OPM.Array, OPM.DynArr}) & (x.typ.BaseTyp = OPT.chartyp) + & (y.typ.comp IN {OPM.Array, OPM.DynArr}) & (y.typ.BaseTyp = OPT.chartyp) THEN + subcl := OPM.copyfn ELSE - subcl := assign + subcl := OPM.assign END; - BindNodes(Nassign, OPT.notyp, x, y); + BindNodes(OPM.Nassign, OPT.notyp, x, y); x^.subcl := subcl; END Assign; PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct); VAR node: OPT.Node; BEGIN - node := OPT.NewNode(Ninittd); node^.typ := typ; + node := OPT.NewNode(OPM.Ninittd); node^.typ := typ; node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos; IF inittd = NIL THEN inittd := node ELSE last^.link := node END ; last := node diff --git a/src/compiler/OPC.Mod b/src/compiler/OPC.Mod index 718ba572..a0c474ca 100644 --- a/src/compiler/OPC.Mod +++ b/src/compiler/OPC.Mod @@ -1,1408 +1,1349 @@ -MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) +MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) (* C source code generator version - 30.4.2000 jt, synchronized with BlackBox version, in particular - various promotion rules changed (long) => (LONGINT), xxxL avoided + 30.4.2000 jt, synchronized with BlackBox version, in particular + various promotion rules changed (long) => (LONGINT), xxxL avoided *) - IMPORT OPT, OPM, Configuration; - - CONST demoVersion = FALSE; - - CONST - (* structure forms *) - Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; -(* - Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19; -*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - (* composite structure forms *) - Array = 2; DynArr = 3; Record = 4; - - (* object history *) - removed = 4; - - (* object modes *) - Var = 1; VarPar = 2; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - CProc = 9; Mod = 11; TProc = 13; - - (* symbol values and ops *) - eql = 9; neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - - (* nodes classes *) - Ninittd = 14; - - (* module visibility of objects *) - internal = 0; external = 1; - - UndefinedType = 0; (* named type not yet defined *) - ProcessingType = 1; (* pointer type is being processed *) - PredefinedType = 2; (* for all predefined types *) - DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) - DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) - - - HeaderMsg = " voc "; - BasicIncludeFile = "SYSTEM"; - Static = "static "; - Export = "export "; (* particularily introduced for VC++ declspec() *) - Extern = "import "; (* particularily introduced for VC++ declspec() *) - Struct = "struct "; - LocalScope = "_s"; (* name of a local intermediate scope (variable name) *) - GlobalScope = "_s"; (* pointer to current scope extension *) - LinkName = "lnk"; (* pointer to previous scope field *) - FlagExt = "__h"; - LenExt = "__len"; - DynTypExt = "__typ"; - TagExt = "__typ"; - - OpenParen = "("; - CloseParen = ")"; - OpenBrace = "{"; - CloseBrace = "}"; - OpenBracket = "["; - CloseBracket = "]"; - Underscore = "_"; - Quotes = 22X; - SingleQuote = 27X; - Tab = 9X; - Colon = ": "; - Semicolon = ";"; - Comma = ", "; - Becomes = " = "; - Star = "*"; - Blank = " "; - Dot = "."; - - DupFunc = "__DUP("; (* duplication of dynamic arrays *) - DupArrFunc = "__DUPARR("; (* duplication of fixed size arrays *) - DelFunc = "__DEL("; (* removal of dynamic arrays *) - - NilConst = "NIL"; - - VoidType = "void"; - CaseStat = "case "; - - VAR - indentLevel: INTEGER; - ptrinit, mainprog, ansi: BOOLEAN; - hashtab: ARRAY 105 OF SHORTINT; - keytab: ARRAY 36, 9 OF CHAR; - GlbPtrs: BOOLEAN; - BodyNameExt: ARRAY 13 OF CHAR; - - PROCEDURE Init*; - BEGIN - indentLevel := 0; - ptrinit := OPM.ptrinit IN OPM.opt; - (*mainprog := OPM.mainprog IN OPM.opt;*) - mainprog := OPM.mainProg OR OPM.mainLinkStat; - ansi := OPM.ansi IN OPM.opt; - IF ansi THEN BodyNameExt := "__init(void)" ELSE BodyNameExt := "__init()" END - END Init; - - PROCEDURE Indent* (count: INTEGER); - BEGIN INC(indentLevel, count) - END Indent; - - PROCEDURE BegStat*; - VAR i: INTEGER; - BEGIN i := indentLevel; - WHILE i > 0 DO OPM.Write(Tab); DEC (i) END - END BegStat; - - PROCEDURE EndStat*; - BEGIN OPM.Write(Semicolon); OPM.WriteLn - END EndStat; - - PROCEDURE BegBlk*; - BEGIN OPM.Write(OpenBrace); OPM.WriteLn; INC(indentLevel) - END BegBlk; - - PROCEDURE EndBlk*; - BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace); OPM.WriteLn - END EndBlk; - - PROCEDURE EndBlk0*; - BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace) - END EndBlk0; - - PROCEDURE Str1(s: ARRAY OF CHAR; x: LONGINT); - VAR ch: CHAR; i: INTEGER; - BEGIN ch := s[0]; i := 0; - WHILE ch # 0X DO - IF ch = "#" THEN OPM.WriteInt(x) - ELSE OPM.Write(ch); - END ; - INC(i); ch := s[i] - END - END Str1; - - PROCEDURE Length(VAR s: ARRAY OF CHAR): INTEGER; - VAR i: INTEGER; - BEGIN i := 0; - WHILE s[i] # 0X DO INC(i) END ; - RETURN i - END Length; - - PROCEDURE PerfectHash (VAR s: ARRAY OF CHAR): INTEGER; - VAR i, h: INTEGER; - BEGIN i := 0; h := 0; - WHILE (s[i] # 0X) & (i < 5) DO h := 3*h + ORD(s[i]); INC(i) END; - RETURN h MOD 105 - END PerfectHash; - - PROCEDURE Ident* (obj: OPT.Object); - VAR mode, level, h: INTEGER; - BEGIN - mode := obj^.mode; level := obj^.mnolev; - IF (mode IN {Var, Typ, LProc}) & (level > 0) OR (mode IN {Fld, VarPar}) THEN - OPM.WriteStringVar(obj^.name); - h := PerfectHash(obj^.name); - IF hashtab[h] >= 0 THEN - IF keytab[hashtab[h]] = obj^.name THEN OPM.Write(Underscore) END - END - ELSE - IF (mode # Typ) OR (obj^.linkadr # PredefinedType) THEN - IF mode = TProc THEN Ident(obj^.link^.typ^.strobj) - ELSIF level < 0 THEN (* use unaliased module name *) - OPM.WriteStringVar(OPT.GlbMod[-level].name); - IF OPM.currFile = OPM.HeaderFile THEN OPT.GlbMod[-level].vis := 1 (*include in header file*) END ; - ELSE OPM.WriteStringVar(OPM.modName) - END ; - OPM.Write(Underscore) - ELSIF (obj = OPT.sysptrtyp^.strobj) OR (obj = OPT.bytetyp^.strobj) (*OR (obj = OPT.int8typ^.strobj) OR (obj = OPT.int16typ^.strobj) OR (obj = OPT.int32typ^.strobj) OR (obj = OPT.int64typ^.strobj)*) THEN - OPM.WriteString("SYSTEM_") - - END ; - OPM.WriteStringVar(obj^.name) - END - END Ident; - - PROCEDURE Stars (typ: OPT.Struct; VAR openClause: BOOLEAN); - VAR pointers: INTEGER; - BEGIN - openClause := FALSE; - IF ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.comp # Record) THEN - IF typ^.comp IN {Array, DynArr} THEN - Stars (typ^.BaseTyp, openClause); - openClause := (typ^.comp = Array) - ELSIF typ^.form = ProcTyp THEN - OPM.Write(OpenParen); OPM.Write(Star) - ELSE - pointers := 0; - (*WHILE (typ^.strobj = NIL) & (typ^.form = Pointer) DO INC (pointers); typ := typ^.BaseTyp END ; - IF (typ^.comp # DynArr) & (pointers # 0) THEN Stars (typ, openClause) END ;*) - WHILE ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.form = Pointer) DO - INC (pointers); typ := typ^.BaseTyp - END ; - IF pointers > 0 THEN - IF typ^.comp # DynArr THEN Stars (typ, openClause) END ; - IF openClause THEN OPM.Write(OpenParen); openClause := FALSE END ; - WHILE pointers > 0 DO OPM.Write(Star); DEC (pointers) END - END - END - END - END Stars; - - PROCEDURE ^AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); - - PROCEDURE DeclareObj(dcl: OPT.Object; scopeDef: BOOLEAN); - VAR - typ: OPT.Struct; - varPar, openClause: BOOLEAN; form, comp: INTEGER; - BEGIN - typ := dcl^.typ; - varPar := ((dcl^.mode = VarPar) & (typ^.comp # Array)) OR (typ^.comp = DynArr) OR scopeDef; - Stars(typ, openClause); - IF varPar THEN - IF openClause THEN OPM.Write(OpenParen) END ; - OPM.Write(Star) - END ; - IF dcl.name # "" THEN Ident(dcl) END ; - IF varPar & openClause THEN OPM.Write(CloseParen) END ; - openClause := FALSE; - LOOP - form := typ^.form; - comp := typ^.comp; - IF ((typ^.strobj # NIL) & (typ^.strobj^.name # "")) OR (form = NoTyp) OR (comp = Record) THEN EXIT - ELSIF (form = Pointer) & (typ^.BaseTyp^.comp # DynArr) THEN - openClause := TRUE - ELSIF (form = ProcTyp) OR (comp IN {Array, DynArr}) THEN - IF openClause THEN OPM.Write(CloseParen); openClause := FALSE END ; - IF form = ProcTyp THEN - IF ansi THEN OPM.Write(")"); AnsiParamList(typ^.link, FALSE) - ELSE OPM.WriteString(")()") - END ; - EXIT - ELSIF comp = Array THEN - OPM.Write(OpenBracket); OPM.WriteInt(typ^.n); OPM.Write(CloseBracket) - END - ELSE - EXIT - END ; - typ := typ^.BaseTyp - END - END DeclareObj; - - PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *) - BEGIN - IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN - OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H) - ELSE Ident(typ^.strobj) - END - END Andent; - - PROCEDURE Undefined(obj: OPT.Object): BOOLEAN; - BEGIN - (* imported anonymous types have obj^.name = ""; used e.g. for repeating inherited fields *) - RETURN (obj^.mnolev >= 0) & (obj^.linkadr # 3+OPM.currFile ) & (obj^.linkadr # PredefinedType) OR (obj^.name = "") - END Undefined; - - PROCEDURE ^FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); - - PROCEDURE DeclareBase(dcl: OPT.Object); (* declare the specifier of object dcl*) - VAR typ, prev: OPT.Struct; obj: OPT.Object; nofdims: INTEGER; off, n, dummy: LONGINT; - BEGIN - typ := dcl^.typ; prev := typ; - WHILE ((typ^.strobj = NIL) OR (typ^.comp = DynArr) OR Undefined(typ^.strobj)) & (typ^.comp # Record) & (typ^.form # NoTyp) - & ~((typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr)) DO - prev := typ; typ := typ^.BaseTyp - END ; - obj := typ^.strobj; - IF typ^.form = NoTyp THEN (* proper procedure *) - OPM.WriteString(VoidType) - ELSIF (obj # NIL) & ~Undefined(obj) THEN (* named type, already declared *) - Ident(obj) - ELSIF typ^.comp = Record THEN - OPM.WriteString(Struct); Andent(typ); - IF (prev.form # Pointer) & ((obj # NIL) OR (dcl.name = "")) THEN - (* named record type not yet declared OR anonymous record with empty name *) - IF (typ^.BaseTyp # NIL) & (typ^.BaseTyp^.strobj.vis # internal) THEN - OPM.WriteString(" { /* "); Ident(typ^.BaseTyp^.strobj); OPM.WriteString(" */"); OPM.WriteLn; Indent(1) - ELSE OPM.Write(Blank); BegBlk - END ; - FieldList(typ, TRUE, off, n, dummy); - EndBlk0 - END - ELSIF (typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr) THEN - typ := typ^.BaseTyp^.BaseTyp; nofdims := 1; - WHILE typ^.comp = DynArr DO INC(nofdims); typ := typ^.BaseTyp END ; - OPM.WriteString(Struct); BegBlk; - BegStat; Str1("LONGINT len[#]", nofdims); EndStat; - BegStat; NEW(obj); NEW(obj.typ); (* aux. object for easy declaration *) - obj.typ.form := Comp; obj.typ.comp := Array; obj.typ.n := 1; obj.typ.BaseTyp := typ; obj.mode := Fld; obj.name := "data"; - obj.linkadr := UndefinedType; DeclareBase(obj); OPM.Write(Blank); DeclareObj(obj, FALSE); - EndStat; EndBlk0 - END - END DeclareBase; - - PROCEDURE NofPtrs* (typ: OPT.Struct): LONGINT; - VAR fld: OPT.Object; btyp: OPT.Struct; n: LONGINT; - BEGIN - IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN RETURN 1 - ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN - btyp := typ^.BaseTyp; - IF btyp # NIL THEN n := NofPtrs(btyp) ELSE n := 0 END ; - fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF fld^.name # OPM.HdPtrName THEN n := n + NofPtrs(fld^.typ) - ELSE INC(n) - END ; - fld := fld^.link - END ; - RETURN n - ELSIF typ^.comp = Array THEN - btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - RETURN NofPtrs(btyp) * n - ELSE RETURN 0 - END - END NofPtrs; - - PROCEDURE PutPtrOffsets (typ: OPT.Struct; adr: LONGINT; VAR cnt: LONGINT); - VAR fld: OPT.Object; btyp: OPT.Struct; n, i: LONGINT; - BEGIN - IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN - OPM.WriteInt(adr); OPM.WriteString(", "); INC(cnt); - IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END - ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN - btyp := typ^.BaseTyp; - IF btyp # NIL THEN PutPtrOffsets(btyp, adr, cnt) END ; - fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF fld^.name # OPM.HdPtrName THEN PutPtrOffsets(fld^.typ, adr + fld^.adr, cnt) - ELSE - OPM.WriteInt(adr + fld^.adr); OPM.WriteString(", "); INC(cnt); - IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END - END ; - fld := fld^.link - END - ELSIF typ^.comp = Array THEN - btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - IF NofPtrs(btyp) > 0 THEN i := 0; - WHILE i < n DO PutPtrOffsets(btyp, adr + i * btyp^.size, cnt); INC(i) END - END - END - END PutPtrOffsets; - - PROCEDURE InitTProcs(typ, obj: OPT.Object); - BEGIN - IF obj # NIL THEN - InitTProcs(typ, obj^.left); - IF obj^.mode = TProc THEN - BegStat; - OPM.WriteString("__INITBP("); - Ident(typ); OPM.WriteString(Comma); Ident(obj); - Str1(", #)", obj^.adr DIV 10000H); - EndStat - END ; - InitTProcs(typ, obj^.right) - END - END InitTProcs; - - PROCEDURE PutBase(typ: OPT.Struct); - BEGIN - IF typ # NIL THEN - PutBase(typ^.BaseTyp); - Ident(typ^.strobj); OPM.WriteString(DynTypExt); OPM.WriteString(", ") - END - END PutBase; - - PROCEDURE LenList(par: OPT.Object; ansiDefine, showParamName: BOOLEAN); - VAR typ: OPT.Struct; dim: INTEGER; - BEGIN - IF showParamName THEN Ident(par); OPM.WriteString(LenExt) END ; - dim := 1; typ := par^.typ^.BaseTyp; - WHILE typ^.comp = DynArr DO - IF ansiDefine THEN OPM.WriteString(", LONGINT ") ELSE OPM.WriteString(Comma) END ; - IF showParamName THEN Ident(par); OPM.WriteString(LenExt); OPM.WriteInt(dim) END ; - typ := typ^.BaseTyp; INC(dim) - END - END LenList; - - PROCEDURE DeclareParams(par: OPT.Object; macro: BOOLEAN); - BEGIN - OPM.Write(OpenParen); - WHILE par # NIL DO - IF macro THEN OPM.WriteStringVar(par.name) - ELSE - IF (par^.mode = Var) & (par^.typ^.form = Real) THEN OPM.Write("_") END ; - Ident(par) - END ; - IF par^.typ^.comp = DynArr THEN - OPM.WriteString(Comma); LenList(par, FALSE, TRUE); - ELSIF (par^.mode = VarPar) & (par^.typ^.comp = Record) THEN - OPM.WriteString(Comma); OPM.WriteStringVar(par.name); OPM.WriteString(TagExt) - END ; - par := par^.link; - IF par # NIL THEN OPM.WriteString(Comma) END - END ; - OPM.Write(CloseParen) - END DeclareParams; - - PROCEDURE ^DefineType(str: OPT.Struct); - PROCEDURE ^ProcHeader(proc: OPT.Object; define: BOOLEAN); - - PROCEDURE DefineTProcTypes(obj: OPT.Object); (* define all types that are used in a TProc definition *) - VAR par: OPT.Object; - BEGIN - IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; - IF ansi THEN par := obj^.link; - WHILE par # NIL DO DefineType(par^.typ); par := par^.link END - END - END DefineTProcTypes; - - PROCEDURE DeclareTProcs(obj: OPT.Object; VAR empty: BOOLEAN); - BEGIN - IF obj # NIL THEN - DeclareTProcs(obj^.left, empty); - IF obj^.mode = TProc THEN - IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; - IF OPM.currFile = OPM.HeaderFile THEN - IF obj^.vis = external THEN - DefineTProcTypes(obj); - OPM.WriteString(Extern); empty := FALSE; - ProcHeader(obj, FALSE) - END - ELSE empty := FALSE; - DefineTProcTypes(obj); - IF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - ProcHeader(obj, FALSE) - END - END ; - DeclareTProcs(obj^.right, empty) - END - END DeclareTProcs; - - PROCEDURE BaseTProc*(obj: OPT.Object): OPT.Object; - VAR typ, base: OPT.Struct; mno: LONGINT; - BEGIN typ := obj^.link^.typ; (* receiver type *) - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - base := typ^.BaseTyp; mno := obj^.adr DIV 10000H; - WHILE (base # NIL) & (mno < base^.n) DO typ := base; base := typ^.BaseTyp END ; - OPT.FindField(obj^.name, typ, obj); - RETURN obj - END BaseTProc; - - PROCEDURE DefineTProcMacros(obj: OPT.Object; VAR empty: BOOLEAN); - BEGIN - IF obj # NIL THEN - DefineTProcMacros(obj^.left, empty); - IF (obj^.mode = TProc) & (obj = BaseTProc(obj)) & ((OPM.currFile # OPM.HeaderFile) OR (obj^.vis = external)) THEN - OPM.WriteString("#define __"); - Ident(obj); - DeclareParams(obj^.link, TRUE); - OPM.WriteString(" __SEND("); - IF obj^.link^.typ^.form = Pointer THEN - OPM.WriteString("__TYPEOF("); Ident(obj^.link); OPM.Write(")") - ELSE Ident(obj^.link); OPM.WriteString(TagExt) - END ; - Str1(", #, ", obj^.adr DIV 10000H); - IF obj^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(obj^.typ^.strobj) END ; - OPM.WriteString("(*)"); - IF ansi THEN - AnsiParamList(obj^.link, FALSE); - ELSE - OPM.WriteString("()"); - END ; - OPM.WriteString(", "); - DeclareParams(obj^.link, TRUE); - OPM.Write(")"); OPM.WriteLn - END ; - DefineTProcMacros(obj^.right, empty) - END - END DefineTProcMacros; - - PROCEDURE DefineType(str: OPT.Struct); (* define a type object *) - VAR obj, field, par: OPT.Object; empty: BOOLEAN; - BEGIN - IF (OPM.currFile = OPM.BodyFile) OR (str^.ref < OPM.MaxStruct (*for hidden exports*) ) THEN - obj := str^.strobj; - IF (obj = NIL) OR Undefined(obj) THEN - IF obj # NIL THEN (* check for cycles *) - IF obj^.linkadr = ProcessingType THEN - IF str^.form # Pointer THEN OPM.Mark(244, str^.txtpos); obj^.linkadr := PredefinedType END - ELSE obj^.linkadr := ProcessingType - END - END ; - IF str^.comp = Record THEN - (* the following exports the base type of an exported type even if the former is non-exported *) - IF str^.BaseTyp # NIL THEN DefineType(str^.BaseTyp) END ; - field := str^.link; - WHILE (field # NIL) & (field^.mode = Fld) DO - IF (field^.vis # internal) OR (OPM.currFile = OPM.BodyFile) THEN DefineType(field^.typ) END ; - field := field^.link - END - ELSIF str^.form = Pointer THEN - IF str^.BaseTyp^.comp # Record THEN DefineType(str^.BaseTyp) END - ELSIF str^.comp IN {Array, DynArr} THEN - DefineType(str^.BaseTyp) - ELSIF str^.form = ProcTyp THEN - IF str^.BaseTyp # OPT.notyp THEN DefineType(str^.BaseTyp) END ; - field := str^.link; - WHILE field # NIL DO DefineType(field^.typ); field := field^.link END - END - END ; - IF (obj # NIL) & Undefined(obj) THEN - OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1); - obj^.linkadr := ProcessingType; - DeclareBase(obj); OPM.Write(Blank); - obj^.typ^.strobj := NIL; (* SG: trick to make DeclareObj declare the type *) - DeclareObj(obj, FALSE); - obj^.typ^.strobj := obj; (* SG: revert trick *) - obj^.linkadr := 3+OPM.currFile; - EndStat; Indent(-1); OPM.WriteLn; - IF obj^.typ^.comp = Record THEN empty := TRUE; - DeclareTProcs(str^.link, empty); DefineTProcMacros(str^.link, empty); - IF ~empty THEN OPM.WriteLn END - END - END - END - END DefineType; - - PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN; - VAR i: INTEGER; r: BOOLEAN; - BEGIN i := 0; - WHILE x[i+1] = y[i] DO INC(i) END ; - r := y[i] = 0X; - RETURN r; - END Prefixed; - - PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER); - VAR i: INTEGER; ext: OPT.ConstExt; - BEGIN - IF obj # NIL THEN - CProcDefs(obj^.left, vis); - (* bug: obj.history cannot be used to cover unexported and deleted CProcs; use special flag obj.adr = 1 *) - IF (obj^.mode = CProc) & (obj^.vis >= vis) & (obj^.adr = 1) THEN - ext := obj.conval.ext; i := 1; - IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN - OPM.WriteString("#define "); Ident(obj); - DeclareParams(obj^.link, TRUE); - OPM.Write(Tab); - END ; - FOR i := i TO ORD(obj.conval.ext[0]) DO OPM.Write(obj.conval.ext[i]) END; - OPM.WriteLn - END ; - CProcDefs(obj^.right, vis) - END - END CProcDefs; - - PROCEDURE TypeDefs* (obj: OPT.Object; vis(*replaced by test on currFile in DefineType*): INTEGER); - BEGIN - IF obj # NIL THEN - TypeDefs(obj^.left, vis); - (* test typ.txtpos to skip types that have been unexported; obj.history # removed is not enough!*) - IF (obj^.mode = Typ) & (obj^.typ^.txtpos > 0) THEN DefineType(obj^.typ) END ; - TypeDefs(obj^.right, vis) - END - END TypeDefs; - - PROCEDURE DefAnonRecs(n: OPT.Node); - VAR o: OPT.Object; typ: OPT.Struct; - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO - typ := n^.typ; - IF (typ^.strobj = NIL) & ((OPM.currFile = OPM.BodyFile) OR (typ.ref < OPM.MaxStruct)) THEN - DefineType(typ); (* declare base and field types, if any *) - NEW(o); o.typ := typ; o.name := ""; DeclareBase(o); EndStat; OPM.WriteLn - (* simply defines a named struct, but not a type; - o.name = "" signals field list expansion for DeclareBase in this very special case *) - END ; - n := n^.link - END - END DefAnonRecs; - - PROCEDURE TDescDecl* (typ: OPT.Struct); - VAR nofptrs: LONGINT; - o: OPT.Object; - BEGIN - BegStat; OPM.WriteString("__TDESC("); - Andent(typ); - Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ)); - OPM.Write('"'); - IF typ^.strobj # NIL THEN OPM.WriteStringVar(typ^.strobj^.name) END ; - Str1('", #), {', typ^.size); - nofptrs := 0; PutPtrOffsets(typ, 0, nofptrs); Str1("#}}", -(nofptrs + 1) * OPM.LIntSize); - EndStat - END TDescDecl; - - PROCEDURE InitTDesc*(typ: OPT.Struct); - BEGIN - BegStat; OPM.WriteString("__INITYP("); - Andent(typ); OPM.WriteString(", "); - IF typ^.BaseTyp # NIL THEN Andent(typ^.BaseTyp) ELSE Andent(typ) END ; - Str1(", #)", typ^.extlev); - EndStat; - IF typ^.strobj # NIL THEN InitTProcs(typ^.strobj, typ^.link) END - END InitTDesc; - - PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT); - BEGIN - CASE base OF - | 2: INC(adr, adr MOD 2) - | 4: INC(adr, (-adr) MOD 4) - | 8: INC(adr, (-adr) MOD 8) - |16: INC(adr, (-adr) MOD 16) - ELSE (*1*) - (*OPM.LogWStr("unhandled case at OPC.Align, base = "); OPM.LogWNum(base, 0); OPM.LogWLn;*) - END - END Align; - - PROCEDURE Base*(typ: OPT.Struct): LONGINT; - BEGIN - CASE typ^.form OF - | Byte: RETURN 1 - | Char: RETURN OPM.CharAlign - | Bool: RETURN OPM.BoolAlign - | SInt: RETURN OPM.SIntAlign - | Int: RETURN OPM.IntAlign - | LInt: RETURN OPM.LIntAlign - (* | Int8: RETURN OPM.Int8Align - | Int16: RETURN OPM.Int16Align - | Int32: RETURN OPM.Int32Align - | Int64: RETURN OPM.Int64Align*) - | Real: RETURN OPM.RealAlign - | LReal: RETURN OPM.LRealAlign - | Set: RETURN OPM.SetAlign - | Pointer: RETURN OPM.PointerAlign - | ProcTyp: RETURN OPM.ProcAlign - | Comp: - IF typ^.comp = Record THEN RETURN typ^.align MOD 10000H - ELSE RETURN Base(typ^.BaseTyp) - END - ELSE OPM.LogWStr("unhandled case in OPC.Base, typ^form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; - END - END Base; - - PROCEDURE FillGap(gap, off, align: LONGINT; VAR n, curAlign: LONGINT); - VAR adr: LONGINT; - BEGIN - adr := off; Align(adr, align); - IF (curAlign < align) & (gap - (adr - off) >= align) THEN (* preserve alignment of the enclosing struct! *) - DEC(gap, (adr - off) + align); - BegStat; - IF align = OPM.IntSize THEN OPM.WriteString("INTEGER") - ELSIF align = OPM.LIntSize THEN OPM.WriteString("LONGINT") - ELSIF align = OPM.LRealSize THEN OPM.WriteString("LONGREAL") - END ; - Str1(" _prvt#", n); INC(n); EndStat; - curAlign := align - END ; - IF gap > 0 THEN BegStat; Str1("char _prvt#", n); INC(n); Str1("[#]", gap); EndStat END - END FillGap; - - PROCEDURE FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); - VAR fld: OPT.Object; base: OPT.Struct; gap, adr, align, fldAlign: LONGINT; - BEGIN - fld := typ.link; align := typ^.align MOD 10000H; - IF typ.BaseTyp # NIL THEN FieldList(typ.BaseTyp, FALSE, off, n, curAlign) - ELSE off := 0; n := 0; curAlign := 1 - END ; - WHILE (fld # NIL) & (fld.mode = Fld) DO - IF (OPM.currFile = OPM.HeaderFile) & (fld.vis = internal) OR - (OPM.currFile = OPM.BodyFile) & (fld.vis = internal) & (typ^.mno # 0) THEN - fld := fld.link; - WHILE (fld # NIL) & (fld.mode = Fld) & (fld.vis = internal) DO fld := fld.link END ; - ELSE - (* mimic OPV.TypSize to detect gaps caused by private fields *) - adr := off; fldAlign := Base(fld^.typ); Align(adr, fldAlign); - gap := fld.adr - adr; - IF fldAlign > curAlign THEN curAlign := fldAlign END ; - IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END ; - BegStat; DeclareBase(fld); OPM.Write(Blank); DeclareObj(fld, FALSE); - off := fld.adr + fld.typ.size; base := fld.typ; fld := fld.link; - WHILE (fld # NIL) & (fld.mode = Fld) & (fld.typ = base) & (fld.adr = off) -(* ?? *) & ((OPM.currFile = OPM.BodyFile) OR (fld.vis # internal) OR (fld.typ.strobj = NIL)) DO - OPM.WriteString(", "); DeclareObj(fld, FALSE); off := fld.adr + fld.typ.size; fld := fld.link - END ; - EndStat - END - END ; - IF last THEN - adr := typ.size - typ^.sysflag DIV 100H; - IF adr = 0 THEN gap := 1 (* avoid empty struct *) ELSE gap := adr - off END ; - IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END - END - END FieldList; - - PROCEDURE IdentList (obj: OPT.Object; vis: INTEGER); - (* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *) - VAR base: OPT.Struct; first: BOOLEAN; lastvis: INTEGER; - BEGIN - base := NIL; first := TRUE; - WHILE (obj # NIL) & (obj^.mode # TProc) DO - IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN - IF (obj^.typ # base) OR (obj^.vis # lastvis) THEN (* new variable base type definition required *) - IF ~first THEN EndStat END ; - first := FALSE; - base := obj^.typ; lastvis := obj^.vis; - BegStat; - IF (vis = 1) & (obj^.vis # internal) THEN OPM.WriteString(Extern) - ELSIF (obj^.mnolev = 0) & (vis = 0) THEN - IF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END - END ; - IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.WriteString("double") - ELSE DeclareBase(obj) - END - ELSE OPM.Write(","); - END ; - OPM.Write(Blank); - IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.Write("_") END ; - DeclareObj(obj, vis = 3); - IF obj^.typ^.comp = DynArr THEN (* declare len parameter(s) *) - EndStat; BegStat; - base := OPT.linttyp; - OPM.WriteString("LONGINT "); LenList(obj, FALSE, TRUE) - ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN - EndStat; BegStat; - OPM.WriteString("LONGINT *"); Ident(obj); OPM.WriteString(TagExt); - base := NIL - ELSIF ptrinit & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = Pointer) THEN - OPM.WriteString(" = NIL") - END - END ; - obj := obj^.link - END ; - IF ~first THEN EndStat END - END IdentList; - - PROCEDURE AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); - VAR name: ARRAY 32 OF CHAR; - BEGIN - OPM.Write("("); - IF (obj = NIL) OR (obj^.mode = TProc) THEN OPM.WriteString("void") - ELSE - LOOP - DeclareBase(obj); - IF showParamNames THEN - OPM.Write(Blank); DeclareObj(obj, FALSE) - ELSE - COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name) - END ; - IF obj^.typ^.comp = DynArr THEN - OPM.WriteString(", LONGINT "); - LenList(obj, TRUE, showParamNames) - ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN - OPM.WriteString(", LONGINT *"); - IF showParamNames THEN Ident(obj); OPM.WriteString(TagExt) END - END ; - IF (obj^.link = NIL) OR (obj^.link.mode = TProc) THEN EXIT END ; - OPM.WriteString(", "); - obj := obj^.link - END - END ; - OPM.Write(")") - END AnsiParamList; - - PROCEDURE ProcHeader(proc: OPT.Object; define: BOOLEAN); - BEGIN - IF proc^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(proc^.typ^.strobj) END ; - OPM.Write(Blank); Ident(proc); OPM.Write(Blank); - IF ansi THEN - AnsiParamList(proc^.link, TRUE); - IF ~define THEN OPM.Write(";") END ; - OPM.WriteLn; - ELSIF define THEN - DeclareParams(proc^.link, FALSE); - OPM.WriteLn; - Indent(1); IdentList(proc^.link, 2(* map REAL to double *)); Indent(-1) - ELSE OPM.WriteString("();"); OPM.WriteLn - END - END ProcHeader; - - PROCEDURE ProcPredefs (obj: OPT.Object; vis: SHORTINT); (* forward declaration of procedures *) - BEGIN - IF obj # NIL THEN - ProcPredefs(obj^.left, vis); - IF (obj^.mode IN {LProc, XProc}) & (obj^.vis >= vis) & ((obj^.history # removed) OR (obj^.mode = LProc)) THEN - (* previous XProc may be deleted or become LProc after interface change*) - IF vis = external THEN OPM.WriteString(Extern) - ELSIF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - ProcHeader(obj, FALSE); - END ; - ProcPredefs(obj^.right, vis); - END; - END ProcPredefs; - - PROCEDURE Include(name: ARRAY OF CHAR); - BEGIN - OPM.WriteString("#include "); OPM.Write(Quotes); OPM.WriteStringVar(name); - OPM.WriteString(".h"); OPM.Write(Quotes); OPM.WriteLn - END Include; - - PROCEDURE IncludeImports(obj: OPT.Object; vis: INTEGER); - BEGIN - IF obj # NIL THEN - IncludeImports(obj^.left, vis); - IF (obj^.mode = Mod) & (obj^.mnolev # 0) & (OPT.GlbMod[-obj^.mnolev].vis >= vis) THEN (* @self and SYSTEM have mnolev = 0 *) - Include(OPT.GlbMod[-obj^.mnolev].name) (* use unaliased module name *) - END; - IncludeImports(obj^.right, vis); - END; - END IncludeImports; - - PROCEDURE GenDynTypes (n: OPT.Node; vis: INTEGER); - VAR typ: OPT.Struct; - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO - typ := n^.typ; - IF (vis = internal) OR (typ^.ref < OPM.MaxStruct (*type needed in symbol file*)) THEN - BegStat; - IF vis = external THEN OPM.WriteString(Extern) - ELSIF (typ^.strobj # NIL) & (typ^.strobj^.mnolev > 0) THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - OPM.WriteString("LONGINT *"); Andent(typ); OPM.WriteString(DynTypExt); - EndStat - END ; - n := n^.link - END - END GenDynTypes; - - PROCEDURE GenHdr*(n: OPT.Node); - BEGIN - (* includes are delayed until it is known which ones are needed in the header *) - OPM.currFile := OPM.HeaderFile; - DefAnonRecs(n); - TypeDefs(OPT.topScope^.right, 1); OPM.WriteLn; - IdentList(OPT.topScope^.scope, 1); OPM.WriteLn; - GenDynTypes(n, external); OPM.WriteLn; - ProcPredefs(OPT.topScope^.right, 1); - OPM.WriteString(Extern); OPM.WriteString("void *"); - OPM.WriteStringVar(OPM.modName); OPM.WriteString(BodyNameExt); - EndStat; OPM.WriteLn; - CProcDefs(OPT.topScope^.right, 1); OPM.WriteLn; - OPM.WriteString("#endif"); OPM.WriteLn - END GenHdr; - - PROCEDURE GenHeaderMsg; - VAR i: INTEGER; - BEGIN - OPM.WriteString("/*"); OPM.WriteString(HeaderMsg); - OPM.Write(" "); OPM.WriteString(Configuration.versionLong); OPM.Write (" "); (* noch *) - FOR i := 0 TO MAX(SET) DO - IF i IN OPM.glbopt THEN - CASE i OF (* c.f. ScanOptions in OPM *) - | OPM.inxchk: OPM.Write("x") - | OPM.ranchk: OPM.Write("r") - | OPM.typchk: OPM.Write("t") - | OPM.newsf: OPM.Write("s") - | OPM.ptrinit: OPM.Write("p") - | OPM.ansi: OPM.Write("k") - | OPM.assert: OPM.Write("a") - | OPM.extsf: OPM.Write("e") - | OPM.mainprog: OPM.Write("m") - | OPM.dontasm: OPM.Write("S") - | OPM.dontlink: OPM.Write("c") - | OPM.mainlinkstat: OPM.Write("M") - | OPM.notcoloroutput: OPM.Write("f") - | OPM.forcenewsym: OPM.Write("F") - | OPM.verbose: OPM.Write("v") - ELSE - (* this else is necessary cause - if someone defined a new option in OPM module - and forgot to add it here then - if option is passed this will - generate __CASECHK and cause Halt, - noch *) - OPM.LogWStr ("( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg"); OPM.LogWLn; - END - END - END; - OPM.WriteString(" */"); OPM.WriteLn - END GenHeaderMsg; - - PROCEDURE GenHdrIncludes*; - BEGIN - OPM.currFile := OPM.HeaderInclude; - GenHeaderMsg; - OPM.WriteLn; - OPM.WriteString("#ifndef "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; - OPM.WriteString("#define "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; - OPM.WriteLn; - IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; - Include(BasicIncludeFile); - IncludeImports(OPT.topScope^.right, 1); OPM.WriteLn - END GenHdrIncludes; - - PROCEDURE GenBdy*(n: OPT.Node); - BEGIN - OPM.currFile := OPM.BodyFile; - GenHeaderMsg; - IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; - Include(BasicIncludeFile); - IncludeImports(OPT.topScope^.right, 0); OPM.WriteLn; - DefAnonRecs(n); - TypeDefs(OPT.topScope^.right, 0); OPM.WriteLn; - IdentList(OPT.topScope^.scope, 0); OPM.WriteLn; - GenDynTypes(n, internal); OPM.WriteLn; - ProcPredefs(OPT.topScope^.right, 0); OPM.WriteLn; - CProcDefs(OPT.topScope^.right, 0); OPM.WriteLn - END GenBdy; - - PROCEDURE RegCmds(obj: OPT.Object); - BEGIN - IF obj # NIL THEN - RegCmds(obj^.left); - IF (obj^.mode = XProc) & (obj^.history # removed) THEN - IF (obj^.vis # 0) & (obj^.link = NIL) & (obj^.typ = OPT.notyp) THEN (*command*) - BegStat; OPM.WriteString('__REGCMD("'); - OPM.WriteStringVar(obj.name); OPM.WriteString('", '); Ident(obj); OPM.Write(")"); EndStat - END - END ; - RegCmds(obj^.right) - END - END RegCmds; - - PROCEDURE InitImports(obj: OPT.Object); - BEGIN - IF obj # NIL THEN - InitImports(obj^.left); - IF (obj^.mode = Mod) & (obj^.mnolev # 0) THEN - BegStat; OPM.WriteString("__MODULE_IMPORT("); - OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name); - OPM.Write(CloseParen); EndStat - END ; - InitImports(obj^.right) - END - END InitImports; - - PROCEDURE GenEnumPtrs* (var: OPT.Object); - VAR typ: OPT.Struct; n: LONGINT; - BEGIN GlbPtrs := FALSE; - WHILE var # NIL DO - typ := var^.typ; - IF NofPtrs(typ) > 0 THEN - IF ~GlbPtrs THEN GlbPtrs := TRUE; - OPM.WriteString(Static); - IF ansi THEN - OPM.WriteString("void EnumPtrs(void (*P)(void*))") - ELSE - OPM.WriteString("void EnumPtrs(P)"); OPM.WriteLn; - OPM.Write(Tab); OPM.WriteString("void (*P)();"); - END ; - OPM.WriteLn; - BegBlk - END ; - BegStat; - IF typ^.form = Pointer THEN - OPM.WriteString("P("); Ident(var); OPM.Write(")"); - ELSIF typ^.comp = Record THEN - OPM.WriteString("__ENUMR(&"); Ident(var); OPM.WriteString(", "); - Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); OPM.WriteString(", 1, P)") - ELSIF typ^.comp = Array THEN - n := typ^.n; typ := typ^.BaseTyp; - WHILE typ^.comp = Array DO n := n * typ^.n; typ := typ^.BaseTyp END ; - IF typ^.form = Pointer THEN - OPM.WriteString("__ENUMP("); Ident(var); Str1(", #, P)", n) - ELSIF typ^.comp = Record THEN - OPM.WriteString("__ENUMR("); Ident(var); OPM.WriteString(", "); - Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); Str1(", #, P)", n) - END - END ; - EndStat - END ; - var := var^.link - END ; - IF GlbPtrs THEN - EndBlk; OPM.WriteLn - END - END GenEnumPtrs; - - PROCEDURE EnterBody*; - BEGIN - OPM.WriteLn; OPM.WriteString(Export); - IF mainprog THEN - IF ansi THEN - OPM.WriteString("int main(int argc, char **argv)"); OPM.WriteLn; - ELSE - OPM.WriteString("main(argc, argv)"); OPM.WriteLn; - OPM.Write(Tab); OPM.WriteString("int argc; char **argv;"); OPM.WriteLn - END - ELSE - OPM.WriteString("void *"); - OPM.WriteString(OPM.modName); OPM.WriteString(BodyNameExt); OPM.WriteLn; - END ; - BegBlk; BegStat; - IF mainprog THEN OPM.WriteString("__INIT(argc, argv)") ELSE OPM.WriteString("__DEFMOD") END ; - EndStat; - IF mainprog & demoVersion THEN BegStat; - OPM.WriteString('/*don`t do it!*/ printf("DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\n")'); - EndStat - END ; - InitImports(OPT.topScope^.right); - BegStat; - IF mainprog THEN OPM.WriteString('__REGMAIN("') ELSE OPM.WriteString('__REGMOD("') END ; - OPM.WriteString(OPM.modName); - IF GlbPtrs THEN OPM.WriteString('", EnumPtrs)') ELSE OPM.WriteString('", 0)') END ; - EndStat; - IF OPM.modName # "SYSTEM" THEN RegCmds(OPT.topScope) END - END EnterBody; - - PROCEDURE ExitBody*; - BEGIN - BegStat; - IF mainprog THEN OPM.WriteString("__FINI;") ELSE OPM.WriteString("__ENDMOD;") END ; - OPM.WriteLn; EndBlk - END ExitBody; - - PROCEDURE DefineInter* (proc: OPT.Object); (* define intermediate scope record and variable *) - VAR scope: OPT.Object; - BEGIN - scope := proc^.scope; - OPM.WriteString(Static); OPM.WriteString(Struct); OPM.WriteStringVar(scope^.name); OPM.Write(Blank); - BegBlk; - IdentList(proc^.link, 3); (* parameters *) - IdentList(scope^.scope, 3); (* local variables *) - BegStat; (* scope link field declaration *) - OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name); - OPM.Write(Blank); OPM.Write(Star); OPM.WriteString(LinkName); EndStat; - EndBlk0; OPM.Write(Blank); - OPM.Write(Star); OPM.WriteStringVar (scope^.name); OPM.WriteString(GlobalScope); EndStat; OPM.WriteLn; - ProcPredefs (scope^.right, 0); - OPM.WriteLn; - END DefineInter; - - PROCEDURE EnterProc* (proc: OPT.Object); - VAR var, scope: OPT.Object; typ: OPT.Struct; dim: INTEGER; - BEGIN - IF proc^.vis # external THEN OPM.WriteString(Static) END ; - ProcHeader(proc, TRUE); - BegBlk; - - (* If there will be a result, provide a result variable. *) - IF proc^.typ # OPT.notyp THEN - BegStat; + IMPORT OPT, OPM, Configuration, SYSTEM; + + + CONST demoVersion = FALSE; + + + CONST + UndefinedType = 0; (* named type not yet defined *) + ProcessingType = 1; (* pointer type is being processed *) + PredefinedType = 2; (* for all predefined types *) + + DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) + DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) + + BasicIncludeFile = "SYSTEM"; + + Export = "export "; (* particularily introduced for VC++ declspec() *) + Extern = "import "; (* particularily introduced for VC++ declspec() *) + LocalScope = "_s"; (* name of a local intermediate scope (variable name) *) + GlobalScope = "_s"; (* pointer to current scope extension *) + LinkName = "lnk"; (* pointer to previous scope field *) + FlagExt = "__h"; + LenExt = "__len"; + DynTypExt = "__typ"; + TagExt = "__typ"; + Tab = 9X; + Backslash = 5CX; (* Defined as hex to avoid confusing editor syntax parsing *) + + + VAR + indentLevel: INTEGER; + ptrinit, mainprog, ansi: BOOLEAN; + hashtab: ARRAY 105 OF SHORTINT; + keytab: ARRAY 36, 9 OF CHAR; + GlbPtrs: BOOLEAN; + BodyNameExt: ARRAY 13 OF CHAR; + + + PROCEDURE Init*; + BEGIN + indentLevel := 0; + ptrinit := OPM.ptrinit IN OPM.opt; + (*mainprog := OPM.mainprog IN OPM.opt;*) + mainprog := OPM.mainProg OR OPM.mainLinkStat; + ansi := OPM.ansi IN OPM.opt; + IF ansi THEN BodyNameExt := "__init(void)" ELSE BodyNameExt := "__init()" END + END Init; + + PROCEDURE Indent* (count: INTEGER); + BEGIN INC(indentLevel, count) + END Indent; + + PROCEDURE BegStat*; + VAR i: INTEGER; + BEGIN i := indentLevel; + WHILE i > 0 DO OPM.Write(Tab); DEC (i) END + END BegStat; + + PROCEDURE EndStat*; + BEGIN OPM.Write(';'); OPM.WriteLn + END EndStat; + + PROCEDURE BegBlk*; + BEGIN OPM.Write('{'); OPM.WriteLn; INC(indentLevel) + END BegBlk; + + PROCEDURE EndBlk*; + BEGIN DEC(indentLevel); BegStat; OPM.Write('}'); OPM.WriteLn + END EndBlk; + + PROCEDURE EndBlk0*; + BEGIN DEC(indentLevel); BegStat; OPM.Write('}') + END EndBlk0; + + PROCEDURE Str1(s: ARRAY OF CHAR; x: LONGINT); + VAR ch: CHAR; i: INTEGER; + BEGIN ch := s[0]; i := 0; + WHILE ch # 0X DO + IF ch = "#" THEN OPM.WriteInt(x) + ELSE OPM.Write(ch); + END ; + INC(i); ch := s[i] + END + END Str1; + + PROCEDURE Length(VAR s: ARRAY OF CHAR): INTEGER; + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] # 0X DO INC(i) END ; + RETURN i + END Length; + + PROCEDURE PerfectHash (VAR s: ARRAY OF CHAR): INTEGER; + VAR i, h: INTEGER; + BEGIN i := 0; h := 0; + WHILE (s[i] # 0X) & (i < 5) DO h := 3*h + ORD(s[i]); INC(i) END; + RETURN h MOD 105 + END PerfectHash; + + PROCEDURE Ident* (obj: OPT.Object); + VAR mode, level, h: INTEGER; + BEGIN + mode := obj^.mode; level := obj^.mnolev; + IF (mode IN {OPM.Var, OPM.Typ, OPM.LProc}) & (level > 0) OR (mode IN {OPM.Fld, OPM.VarPar}) THEN + OPM.WriteStringVar(obj^.name); + h := PerfectHash(obj^.name); + IF hashtab[h] >= 0 THEN + IF keytab[hashtab[h]] = obj^.name THEN OPM.Write('_') END + END + ELSE + IF (mode # OPM.Typ) OR (obj^.linkadr # PredefinedType) THEN + IF mode = OPM.TProc THEN Ident(obj^.link^.typ^.strobj) + ELSIF level < 0 THEN (* use unaliased module name *) + OPM.WriteStringVar(OPT.GlbMod[-level].name); + IF OPM.currFile = OPM.HeaderFile THEN OPT.GlbMod[-level].vis := 1 (*include in header file*) END ; + ELSE OPM.WriteStringVar(OPM.modName) + END ; + OPM.Write('_') + ELSIF (obj = OPT.sysptrtyp^.strobj) + OR (obj = OPT.bytetyp^.strobj) THEN + OPM.WriteString("SYSTEM_") + END; + OPM.WriteStringVar(obj^.name); + END + END Ident; + + PROCEDURE Stars (typ: OPT.Struct; VAR openClause: BOOLEAN); + VAR pointers: INTEGER; + BEGIN + openClause := FALSE; + IF ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.comp # OPM.Record) THEN + IF typ^.comp IN {OPM.Array, OPM.DynArr} THEN + Stars (typ^.BaseTyp, openClause); + openClause := (typ^.comp = OPM.Array) + ELSIF typ^.form = OPM.ProcTyp THEN + OPM.Write('('); OPM.Write('*') + ELSE + pointers := 0; + (*WHILE (typ^.strobj = NIL) & (typ^.form = OPM.Pointer) DO INC (pointers); typ := typ^.BaseTyp END ; + IF (typ^.comp # OPM.DynArr) & (pointers # 0) THEN Stars (typ, openClause) END ;*) + WHILE ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.form = OPM.Pointer) DO + INC (pointers); typ := typ^.BaseTyp + END ; + IF pointers > 0 THEN + IF typ^.comp # OPM.DynArr THEN Stars (typ, openClause) END ; + IF openClause THEN OPM.Write('('); openClause := FALSE END ; + WHILE pointers > 0 DO OPM.Write('*'); DEC (pointers) END + END + END + END + END Stars; + + PROCEDURE ^AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); + + PROCEDURE DeclareObj(dcl: OPT.Object; scopeDef: BOOLEAN); + VAR + typ: OPT.Struct; + varPar, openClause: BOOLEAN; form, comp: INTEGER; + BEGIN + typ := dcl^.typ; + varPar := ((dcl^.mode = OPM.VarPar) & (typ^.comp # OPM.Array)) OR (typ^.comp = OPM.DynArr) OR scopeDef; + Stars(typ, openClause); + IF varPar THEN + IF openClause THEN OPM.Write('(') END ; + OPM.Write('*') + END ; + IF dcl.name # "" THEN Ident(dcl) END ; + IF varPar & openClause THEN OPM.Write(')') END ; + openClause := FALSE; + LOOP + form := typ^.form; + comp := typ^.comp; + IF ((typ^.strobj # NIL) & (typ^.strobj^.name # "")) OR (form = OPM.NoTyp) OR (comp = OPM.Record) THEN EXIT + ELSIF (form = OPM.Pointer) & (typ^.BaseTyp^.comp # OPM.DynArr) THEN + openClause := TRUE + ELSIF (form = OPM.ProcTyp) OR (comp IN {OPM.Array, OPM.DynArr}) THEN + IF openClause THEN OPM.Write(')'); openClause := FALSE END ; + IF form = OPM.ProcTyp THEN + IF ansi THEN OPM.Write(")"); AnsiParamList(typ^.link, FALSE) + ELSE OPM.WriteString(")()") + END ; + EXIT + ELSIF comp = OPM.Array THEN + OPM.Write('['); OPM.WriteInt(typ^.n); OPM.Write(']') + END + ELSE + EXIT + END ; + typ := typ^.BaseTyp + END + END DeclareObj; + + PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *) + BEGIN + IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN + OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H) + ELSE Ident(typ^.strobj) + END + END Andent; + + PROCEDURE Undefined(obj: OPT.Object): BOOLEAN; + BEGIN + (* imported anonymous types have obj^.name = ""; + used e.g. for repeating inherited fields *) + RETURN (obj^.name = "") + OR (obj^.mnolev >= 0) + & (obj^.linkadr # 3+OPM.currFile ) + & (obj^.linkadr # PredefinedType) + END Undefined; + + PROCEDURE ^FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); + + PROCEDURE DeclareBase(dcl: OPT.Object); (* declare the specifier of object dcl*) + VAR typ, prev: OPT.Struct; obj: OPT.Object; nofdims: INTEGER; off, n, dummy: LONGINT; + BEGIN + typ := dcl^.typ; prev := typ; + WHILE ((typ^.strobj = NIL) OR (typ^.comp = OPM.DynArr) OR Undefined(typ^.strobj)) + & (typ^.comp # OPM.Record) + & (typ^.form # OPM.NoTyp) + & ~((typ^.form = OPM.Pointer) & (typ^.BaseTyp^.comp = OPM.DynArr)) DO + prev := typ; typ := typ^.BaseTyp; + END ; + obj := typ^.strobj; + IF typ^.form = OPM.NoTyp THEN (* proper procedure *) + OPM.WriteString('void') + ELSIF (obj # NIL) & ~Undefined(obj) THEN (* named type, already declared *) + Ident(obj) + ELSIF typ^.comp = OPM.Record THEN + OPM.WriteString('struct '); Andent(typ); + IF (prev.form # OPM.Pointer) & ((obj # NIL) OR (dcl.name = "")) THEN + (* named record type not yet declared OR anonymous record with empty name *) + IF (typ^.BaseTyp # NIL) & (typ^.BaseTyp^.strobj.vis # OPM.internal) THEN + OPM.WriteString(" { /* "); Ident(typ^.BaseTyp^.strobj); OPM.WriteString(" */"); OPM.WriteLn; Indent(1) + ELSE OPM.Write(' '); BegBlk + END ; + FieldList(typ, TRUE, off, n, dummy); + EndBlk0 + END + ELSIF (typ^.form = OPM.Pointer) & (typ^.BaseTyp^.comp = OPM.DynArr) THEN + typ := typ^.BaseTyp^.BaseTyp; nofdims := 1; + WHILE typ^.comp = OPM.DynArr DO INC(nofdims); typ := typ^.BaseTyp END ; + OPM.WriteString('struct '); BegBlk; + BegStat; Str1("LONGINT len[#]", nofdims); EndStat; + BegStat; NEW(obj); NEW(obj.typ); (* aux. object for easy declaration *) + obj.typ.form := OPM.Comp; obj.typ.comp := OPM.Array; obj.typ.n := 1; obj.typ.BaseTyp := typ; obj.mode := OPM.Fld; obj.name := "data"; + obj.linkadr := UndefinedType; DeclareBase(obj); OPM.Write(' '); DeclareObj(obj, FALSE); + EndStat; EndBlk0 + END + END DeclareBase; + + PROCEDURE NofPtrs* (typ: OPT.Struct): LONGINT; + VAR fld: OPT.Object; btyp: OPT.Struct; n: LONGINT; + BEGIN + IF (typ^.form = OPM.Pointer) & (typ^.sysflag = 0) THEN RETURN 1 + ELSIF (typ^.comp = OPM.Record) & (typ^.sysflag MOD 100H = 0) THEN + btyp := typ^.BaseTyp; + IF btyp # NIL THEN n := NofPtrs(btyp) ELSE n := 0 END ; + fld := typ^.link; + WHILE (fld # NIL) & (fld^.mode = OPM.Fld) DO + IF fld^.name # OPM.HdPtrName THEN n := n + NofPtrs(fld^.typ) + ELSE INC(n) + END ; + fld := fld^.link + END ; + RETURN n + ELSIF typ^.comp = OPM.Array THEN + btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPM.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; + RETURN NofPtrs(btyp) * n + ELSE RETURN 0 + END + END NofPtrs; + + PROCEDURE PutPtrOffsets (typ: OPT.Struct; adr: LONGINT; VAR cnt: LONGINT); + VAR fld: OPT.Object; btyp: OPT.Struct; n, i: LONGINT; + BEGIN + IF (typ^.form = OPM.Pointer) & (typ^.sysflag = 0) THEN + OPM.WriteInt(adr); OPM.WriteString(", "); INC(cnt); + IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END + ELSIF (typ^.comp = OPM.Record) & (typ^.sysflag MOD 100H = 0) THEN + btyp := typ^.BaseTyp; + IF btyp # NIL THEN PutPtrOffsets(btyp, adr, cnt) END ; + fld := typ^.link; + WHILE (fld # NIL) & (fld^.mode = OPM.Fld) DO + IF fld^.name # OPM.HdPtrName THEN PutPtrOffsets(fld^.typ, adr + fld^.adr, cnt) + ELSE + OPM.WriteInt(adr + fld^.adr); OPM.WriteString(", "); INC(cnt); + IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END + END ; + fld := fld^.link + END + ELSIF typ^.comp = OPM.Array THEN + btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPM.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; + IF NofPtrs(btyp) > 0 THEN i := 0; + WHILE i < n DO PutPtrOffsets(btyp, adr + i * btyp^.size, cnt); INC(i) END + END + END + END PutPtrOffsets; + + PROCEDURE InitTProcs(typ, obj: OPT.Object); + BEGIN + IF obj # NIL THEN + InitTProcs(typ, obj^.left); + IF obj^.mode = OPM.TProc THEN + BegStat; + OPM.WriteString("__INITBP("); + Ident(typ); OPM.WriteString(', '); Ident(obj); + Str1(", #)", obj^.adr DIV 10000H); + EndStat + END ; + InitTProcs(typ, obj^.right) + END + END InitTProcs; + + PROCEDURE PutBase(typ: OPT.Struct); + BEGIN + IF typ # NIL THEN + PutBase(typ^.BaseTyp); + Ident(typ^.strobj); OPM.WriteString(DynTypExt); OPM.WriteString(", ") + END + END PutBase; + + PROCEDURE LenList(par: OPT.Object; ansiDefine, showParamName: BOOLEAN); + VAR typ: OPT.Struct; dim: INTEGER; + BEGIN + IF showParamName THEN Ident(par); OPM.WriteString(LenExt) END ; + dim := 1; typ := par^.typ^.BaseTyp; + WHILE typ^.comp = OPM.DynArr DO + IF ansiDefine THEN OPM.WriteString(", LONGINT ") ELSE OPM.WriteString(', ') END ; + IF showParamName THEN Ident(par); OPM.WriteString(LenExt); OPM.WriteInt(dim) END ; + typ := typ^.BaseTyp; INC(dim) + END + END LenList; + + PROCEDURE DeclareParams(par: OPT.Object; macro: BOOLEAN); + BEGIN + OPM.Write('('); + WHILE par # NIL DO + IF macro THEN OPM.WriteStringVar(par.name) + ELSE + IF (par^.mode = OPM.Var) & (par^.typ^.form = OPM.Real) THEN OPM.Write("_") END ; + Ident(par) + END ; + IF par^.typ^.comp = OPM.DynArr THEN + OPM.WriteString(', '); LenList(par, FALSE, TRUE); + ELSIF (par^.mode = OPM.VarPar) & (par^.typ^.comp = OPM.Record) THEN + OPM.WriteString(', '); OPM.WriteStringVar(par.name); OPM.WriteString(TagExt) + END ; + par := par^.link; + IF par # NIL THEN OPM.WriteString(', ') END + END ; + OPM.Write(')') + END DeclareParams; + + PROCEDURE ^DefineType(str: OPT.Struct); + PROCEDURE ^ProcHeader(proc: OPT.Object; define: BOOLEAN); + + PROCEDURE DefineTProcTypes(obj: OPT.Object); (* define all types that are used in a OPM.TProc definition *) + VAR par: OPT.Object; + BEGIN + IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; + IF ansi THEN par := obj^.link; + WHILE par # NIL DO DefineType(par^.typ); par := par^.link END + END + END DefineTProcTypes; + + PROCEDURE DeclareTProcs(obj: OPT.Object; VAR empty: BOOLEAN); + BEGIN + IF obj # NIL THEN + DeclareTProcs(obj^.left, empty); + IF obj^.mode = OPM.TProc THEN + IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; + IF OPM.currFile = OPM.HeaderFile THEN + IF obj^.vis = OPM.external THEN + DefineTProcTypes(obj); + OPM.WriteString(Extern); empty := FALSE; + ProcHeader(obj, FALSE) + END + ELSE empty := FALSE; + DefineTProcTypes(obj); + IF obj^.vis = OPM.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + ProcHeader(obj, FALSE) + END + END ; + DeclareTProcs(obj^.right, empty) + END + END DeclareTProcs; + + PROCEDURE BaseTProc*(obj: OPT.Object): OPT.Object; + VAR typ, base: OPT.Struct; mno: LONGINT; + BEGIN typ := obj^.link^.typ; (* receiver type *) + IF typ^.form = OPM.Pointer THEN typ := typ^.BaseTyp END ; + base := typ^.BaseTyp; mno := obj^.adr DIV 10000H; + WHILE (base # NIL) & (mno < base^.n) DO typ := base; base := typ^.BaseTyp END ; + OPT.FindField(obj^.name, typ, obj); + RETURN obj + END BaseTProc; + + PROCEDURE DefineTProcMacros(obj: OPT.Object; VAR empty: BOOLEAN); + BEGIN + IF obj # NIL THEN + DefineTProcMacros(obj^.left, empty); + IF (obj^.mode = OPM.TProc) & (obj = BaseTProc(obj)) & ((OPM.currFile # OPM.HeaderFile) OR (obj^.vis = OPM.external)) THEN + OPM.WriteString("#define __"); + Ident(obj); + DeclareParams(obj^.link, TRUE); + OPM.WriteString(" __SEND("); + IF obj^.link^.typ^.form = OPM.Pointer THEN + OPM.WriteString("__TYPEOF("); Ident(obj^.link); OPM.Write(")") + ELSE Ident(obj^.link); OPM.WriteString(TagExt) + END ; + Str1(", #, ", obj^.adr DIV 10000H); + IF obj^.typ = OPT.notyp THEN OPM.WriteString('void') ELSE Ident(obj^.typ^.strobj) END ; + OPM.WriteString("(*)"); + IF ansi THEN + AnsiParamList(obj^.link, FALSE); + ELSE + OPM.WriteString("()"); + END ; + OPM.WriteString(", "); + DeclareParams(obj^.link, TRUE); + OPM.Write(")"); OPM.WriteLn + END ; + DefineTProcMacros(obj^.right, empty) + END + END DefineTProcMacros; + + PROCEDURE DefineType(str: OPT.Struct); (* define a type object *) + VAR obj, field, par: OPT.Object; empty: BOOLEAN; + BEGIN + IF (OPM.currFile = OPM.BodyFile) OR (str^.ref < OPM.MaxStruct (*for hidden exports*) ) THEN + obj := str^.strobj; + IF (obj = NIL) OR Undefined(obj) THEN + IF obj # NIL THEN (* check for cycles *) + IF obj^.linkadr = ProcessingType THEN + IF str^.form # OPM.Pointer THEN OPM.Mark(244, str^.txtpos); obj^.linkadr := PredefinedType END + ELSE obj^.linkadr := ProcessingType + END + END ; + IF str^.comp = OPM.Record THEN + (* the following exports the base type of an exported type even if the former is non-exported *) + IF str^.BaseTyp # NIL THEN DefineType(str^.BaseTyp) END ; + field := str^.link; + WHILE (field # NIL) & (field^.mode = OPM.Fld) DO + IF (field^.vis # OPM.internal) OR (OPM.currFile = OPM.BodyFile) THEN DefineType(field^.typ) END ; + field := field^.link + END + ELSIF str^.form = OPM.Pointer THEN + IF str^.BaseTyp^.comp # OPM.Record THEN DefineType(str^.BaseTyp) END + ELSIF str^.comp IN {OPM.Array, OPM.DynArr} THEN + DefineType(str^.BaseTyp) + ELSIF str^.form = OPM.ProcTyp THEN + IF str^.BaseTyp # OPT.notyp THEN DefineType(str^.BaseTyp) END ; + field := str^.link; + WHILE field # NIL DO DefineType(field^.typ); field := field^.link END + END + END ; + IF (obj # NIL) & Undefined(obj) THEN + OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1); + obj^.linkadr := ProcessingType; + DeclareBase(obj); OPM.Write(' '); + obj^.typ^.strobj := NIL; (* SG: trick to make DeclareObj declare the type *) + DeclareObj(obj, FALSE); + obj^.typ^.strobj := obj; (* SG: revert trick *) + obj^.linkadr := 3+OPM.currFile; + EndStat; Indent(-1); OPM.WriteLn; + IF obj^.typ^.comp = OPM.Record THEN empty := TRUE; + DeclareTProcs(str^.link, empty); DefineTProcMacros(str^.link, empty); + IF ~empty THEN OPM.WriteLn END + END + END + END + END DefineType; + + PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; r: BOOLEAN; + BEGIN i := 0; + WHILE x[i+1] = y[i] DO INC(i) END ; + r := y[i] = 0X; + RETURN r; + END Prefixed; + + PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER); + VAR i: INTEGER; ext: OPT.ConstExt; + BEGIN + IF obj # NIL THEN + CProcDefs(obj^.left, vis); + (* bug: obj.history cannot be used to cover unexported and deleted CProcs; use special flag obj.adr = 1 *) + IF (obj^.mode = OPM.CProc) & (obj^.vis >= vis) & (obj^.adr = 1) THEN + ext := obj.conval.ext; i := 1; + IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN + OPM.WriteString("#define "); Ident(obj); + DeclareParams(obj^.link, TRUE); + OPM.Write(Tab); + END ; + FOR i := i TO ORD(obj.conval.ext[0]) DO OPM.Write(obj.conval.ext[i]) END; + OPM.WriteLn + END ; + CProcDefs(obj^.right, vis) + END + END CProcDefs; + + PROCEDURE TypeDefs* (obj: OPT.Object; vis(*replaced by test on currFile in DefineType*): INTEGER); + BEGIN + IF obj # NIL THEN + TypeDefs(obj^.left, vis); + (* test typ.txtpos to skip types that have been unexported; obj.history # removed is not enough!*) + IF (obj^.mode = OPM.Typ) & (obj^.typ^.txtpos > 0) THEN DefineType(obj^.typ) END ; + TypeDefs(obj^.right, vis) + END + END TypeDefs; + + PROCEDURE DefAnonRecs(n: OPT.Node); + VAR o: OPT.Object; typ: OPT.Struct; + BEGIN + WHILE (n # NIL) & (n^.class = OPM.Ninittd) DO + typ := n^.typ; + IF (typ^.strobj = NIL) & ((OPM.currFile = OPM.BodyFile) OR (typ.ref < OPM.MaxStruct)) THEN + DefineType(typ); (* declare base and field types, if any *) + NEW(o); o.typ := typ; o.name := ""; DeclareBase(o); EndStat; OPM.WriteLn + (* simply defines a named struct, but not a type; + o.name = "" signals field list expansion for DeclareBase in this very special case *) + END ; + n := n^.link + END + END DefAnonRecs; + + PROCEDURE TDescDecl* (typ: OPT.Struct); + VAR nofptrs: LONGINT; + o: OPT.Object; + BEGIN + BegStat; OPM.WriteString("__TDESC("); + Andent(typ); + Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ)); + OPM.Write('"'); + IF typ^.strobj # NIL THEN OPM.WriteStringVar(typ^.strobj^.name) END ; + Str1('", #), {', typ^.size); + nofptrs := 0; PutPtrOffsets(typ, 0, nofptrs); Str1("#}}", -(nofptrs + 1) * OPM.LIntSize); + EndStat + END TDescDecl; + + PROCEDURE InitTDesc*(typ: OPT.Struct); + BEGIN + BegStat; OPM.WriteString("__INITYP("); + Andent(typ); OPM.WriteString(", "); + IF typ^.BaseTyp # NIL THEN Andent(typ^.BaseTyp) ELSE Andent(typ) END ; + Str1(", #)", typ^.extlev); + EndStat; + IF typ^.strobj # NIL THEN InitTProcs(typ^.strobj, typ^.link) END + END InitTDesc; + + PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT); + BEGIN + CASE base OF + | 2: INC(adr, adr MOD 2) + | 4: INC(adr, (-adr) MOD 4) + | 8: INC(adr, (-adr) MOD 8) + |16: INC(adr, (-adr) MOD 16) + ELSE (*1*) + (*OPM.LogWStr("unhandled case at OPC.Align, base = "); OPM.LogWNum(base, 0); OPM.LogWLn;*) + END + END Align; + + PROCEDURE Base*(typ: OPT.Struct): LONGINT; + BEGIN + CASE typ^.form OF + | OPM.Byte: RETURN 1 + | OPM.Char: RETURN OPM.CharAlign + | OPM.Bool: RETURN OPM.BoolAlign + | OPM.SInt: RETURN OPM.SIntAlign + | OPM.Int: RETURN OPM.IntAlign + | OPM.LInt: RETURN OPM.LIntAlign + | OPM.Real: RETURN OPM.RealAlign + | OPM.LReal: RETURN OPM.LRealAlign + | OPM.Set: RETURN OPM.SetAlign + | OPM.Pointer: RETURN OPM.PointerAlign + | OPM.ProcTyp: RETURN OPM.ProcAlign + | OPM.Comp: + IF typ^.comp = OPM.Record THEN RETURN typ^.align MOD 10000H + ELSE RETURN Base(typ^.BaseTyp) + END + ELSE OPM.LogWStr("unhandled case in OPC.Base, typ^form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; + END + END Base; + + PROCEDURE FillGap(gap, off, align: LONGINT; VAR n, curAlign: LONGINT); + VAR adr: LONGINT; + BEGIN + adr := off; Align(adr, align); + IF (curAlign < align) & (gap - (adr - off) >= align) THEN (* preserve alignment of the enclosing struct! *) + DEC(gap, (adr - off) + align); + BegStat; + IF align = OPM.IntSize THEN OPM.WriteString("INTEGER") + ELSIF align = OPM.LIntSize THEN OPM.WriteString("LONGINT") + ELSIF align = OPM.LRealSize THEN OPM.WriteString("LONGREAL") + END ; + Str1(" _prvt#", n); INC(n); EndStat; + curAlign := align + END ; + IF gap > 0 THEN BegStat; Str1("char _prvt#", n); INC(n); Str1("[#]", gap); EndStat END + END FillGap; + + PROCEDURE FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); + VAR fld: OPT.Object; base: OPT.Struct; gap, adr, align, fldAlign: LONGINT; + BEGIN + fld := typ.link; align := typ^.align MOD 10000H; + IF typ.BaseTyp # NIL THEN FieldList(typ.BaseTyp, FALSE, off, n, curAlign) + ELSE off := 0; n := 0; curAlign := 1 + END ; + WHILE (fld # NIL) & (fld.mode = OPM.Fld) DO + IF (OPM.currFile = OPM.HeaderFile) & (fld.vis = OPM.internal) OR + (OPM.currFile = OPM.BodyFile) & (fld.vis = OPM.internal) & (typ^.mno # 0) THEN + fld := fld.link; + WHILE (fld # NIL) & (fld.mode = OPM.Fld) & (fld.vis = OPM.internal) DO fld := fld.link END ; + ELSE + (* mimic OPV.TypSize to detect gaps caused by private fields *) + adr := off; fldAlign := Base(fld^.typ); Align(adr, fldAlign); + gap := fld.adr - adr; + IF fldAlign > curAlign THEN curAlign := fldAlign END ; + IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END ; + BegStat; DeclareBase(fld); OPM.Write(' '); DeclareObj(fld, FALSE); + off := fld.adr + fld.typ.size; base := fld.typ; fld := fld.link; + WHILE (fld # NIL) & (fld.mode = OPM.Fld) & (fld.typ = base) & (fld.adr = off) +(* ?? *) & ((OPM.currFile = OPM.BodyFile) OR (fld.vis # OPM.internal) OR (fld.typ.strobj = NIL)) DO + OPM.WriteString(", "); DeclareObj(fld, FALSE); off := fld.adr + fld.typ.size; fld := fld.link + END ; + EndStat + END + END ; + IF last THEN + adr := typ.size - typ^.sysflag DIV 100H; + IF adr = 0 THEN gap := 1 (* avoid empty struct *) ELSE gap := adr - off END ; + IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END + END + END FieldList; + + PROCEDURE IdentList (obj: OPT.Object; vis: INTEGER); + (* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *) + VAR base: OPT.Struct; first: BOOLEAN; lastvis: INTEGER; + BEGIN + base := NIL; first := TRUE; + WHILE (obj # NIL) & (obj^.mode # OPM.TProc) DO + IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN + IF (obj^.typ # base) OR (obj^.vis # lastvis) THEN (* new variable base type definition required *) + IF ~first THEN EndStat END ; + first := FALSE; + base := obj^.typ; lastvis := obj^.vis; + BegStat; + IF (vis = 1) & (obj^.vis # OPM.internal) THEN OPM.WriteString(Extern) + ELSIF (obj^.mnolev = 0) & (vis = 0) THEN + IF obj^.vis = OPM.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END + END ; + IF (vis = 2) & (obj^.mode = OPM.Var) & (base^.form = OPM.Real) THEN OPM.WriteString("double") + ELSE DeclareBase(obj) + END + ELSE OPM.Write(","); + END ; + OPM.Write(' '); + IF (vis = 2) & (obj^.mode = OPM.Var) & (base^.form = OPM.Real) THEN OPM.Write("_") END ; + DeclareObj(obj, vis = 3); + IF obj^.typ^.comp = OPM.DynArr THEN (* declare len parameter(s) *) + EndStat; BegStat; + base := OPT.linttyp; + OPM.WriteString("LONGINT "); LenList(obj, FALSE, TRUE) + ELSIF (obj^.mode = OPM.VarPar) & (obj^.typ^.comp = OPM.Record) THEN + EndStat; BegStat; + OPM.WriteString("LONGINT *"); Ident(obj); OPM.WriteString(TagExt); + base := NIL + ELSIF ptrinit & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = OPM.Pointer) THEN + OPM.WriteString(" = NIL") + END + END ; + obj := obj^.link + END ; + IF ~first THEN EndStat END + END IdentList; + + PROCEDURE AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); + VAR name: ARRAY 32 OF CHAR; + BEGIN + OPM.Write("("); + IF (obj = NIL) OR (obj^.mode = OPM.TProc) THEN OPM.WriteString("void") + ELSE + LOOP + DeclareBase(obj); + IF showParamNames THEN + OPM.Write(' '); DeclareObj(obj, FALSE) + ELSE + COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name) + END ; + IF obj^.typ^.comp = OPM.DynArr THEN + OPM.WriteString(", LONGINT "); + LenList(obj, TRUE, showParamNames) + ELSIF (obj^.mode = OPM.VarPar) & (obj^.typ^.comp = OPM.Record) THEN + OPM.WriteString(", LONGINT *"); + IF showParamNames THEN Ident(obj); OPM.WriteString(TagExt) END + END ; + IF (obj^.link = NIL) OR (obj^.link.mode = OPM.TProc) THEN EXIT END ; + OPM.WriteString(", "); + obj := obj^.link + END + END ; + OPM.Write(")") + END AnsiParamList; + + PROCEDURE ProcHeader(proc: OPT.Object; define: BOOLEAN); + BEGIN + IF proc^.typ = OPT.notyp THEN OPM.WriteString('void') ELSE Ident(proc^.typ^.strobj) END ; + OPM.Write(' '); Ident(proc); OPM.Write(' '); + IF ansi THEN + AnsiParamList(proc^.link, TRUE); + IF ~define THEN OPM.Write(";") END ; + OPM.WriteLn; + ELSIF define THEN + DeclareParams(proc^.link, FALSE); + OPM.WriteLn; + Indent(1); IdentList(proc^.link, 2(* map REAL to double *)); Indent(-1) + ELSE OPM.WriteString("();"); OPM.WriteLn + END + END ProcHeader; + + PROCEDURE ProcPredefs (obj: OPT.Object; vis: SHORTINT); (* forward declaration of procedures *) + BEGIN + IF obj # NIL THEN + ProcPredefs(obj^.left, vis); + IF (obj^.mode IN {OPM.LProc, OPM.XProc}) & (obj^.vis >= vis) & ((obj^.history # OPM.removed) OR (obj^.mode = OPM.LProc)) THEN + (* previous OPM.XProc may be deleted or become OPM.LProc after interface change*) + IF vis = OPM.external THEN OPM.WriteString(Extern) + ELSIF obj^.vis = OPM.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + ProcHeader(obj, FALSE); + END ; + ProcPredefs(obj^.right, vis); + END; + END ProcPredefs; + + PROCEDURE Include(name: ARRAY OF CHAR); + BEGIN + OPM.WriteString("#include "); OPM.Write('"'); OPM.WriteStringVar(name); + OPM.WriteString(".h"); OPM.Write('"'); OPM.WriteLn + END Include; + + PROCEDURE IncludeImports(obj: OPT.Object; vis: INTEGER); + BEGIN + IF obj # NIL THEN + IncludeImports(obj^.left, vis); + IF (obj^.mode = OPM.Mod) & (obj^.mnolev # 0) & (OPT.GlbMod[-obj^.mnolev].vis >= vis) THEN (* @self and SYSTEM have mnolev = 0 *) + Include(OPT.GlbMod[-obj^.mnolev].name) (* use unaliased module name *) + END; + IncludeImports(obj^.right, vis); + END; + END IncludeImports; + + PROCEDURE GenDynTypes (n: OPT.Node; vis: INTEGER); + VAR typ: OPT.Struct; + BEGIN + WHILE (n # NIL) & (n^.class = OPM.Ninittd) DO + typ := n^.typ; + IF (vis = OPM.internal) OR (typ^.ref < OPM.MaxStruct (*type needed in symbol file*)) THEN + BegStat; + IF vis = OPM.external THEN OPM.WriteString(Extern) + ELSIF (typ^.strobj # NIL) & (typ^.strobj^.mnolev > 0) THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + OPM.WriteString("LONGINT *"); Andent(typ); OPM.WriteString(DynTypExt); + EndStat + END ; + n := n^.link + END + END GenDynTypes; + + PROCEDURE GenHdr*(n: OPT.Node); + BEGIN + (* includes are delayed until it is known which ones are needed in the header *) + OPM.currFile := OPM.HeaderFile; + DefAnonRecs(n); + TypeDefs(OPT.topScope^.right, 1); OPM.WriteLn; + IdentList(OPT.topScope^.scope, 1); OPM.WriteLn; + GenDynTypes(n, OPM.external); OPM.WriteLn; + ProcPredefs(OPT.topScope^.right, 1); + OPM.WriteString(Extern); OPM.WriteString("void *"); + OPM.WriteStringVar(OPM.modName); OPM.WriteString(BodyNameExt); + EndStat; OPM.WriteLn; + CProcDefs(OPT.topScope^.right, 1); OPM.WriteLn; + OPM.WriteString("#endif"); OPM.WriteLn + END GenHdr; + + PROCEDURE GenHeaderMsg; + VAR i: INTEGER; + BEGIN + OPM.WriteString("/* "); OPM.WriteString(Configuration.name); + OPM.Write(" "); OPM.WriteString(Configuration.versionLong); OPM.Write (" "); (* noch *) + FOR i := 0 TO MAX(SET) DO + IF i IN OPM.glbopt THEN + CASE i OF (* c.f. ScanOptions in OPM *) + | OPM.inxchk: OPM.Write("x") + | OPM.ranchk: OPM.Write("r") + | OPM.typchk: OPM.Write("t") + | OPM.newsf: OPM.Write("s") + | OPM.ptrinit: OPM.Write("p") + | OPM.ansi: OPM.Write("k") + | OPM.assert: OPM.Write("a") + | OPM.extsf: OPM.Write("e") + | OPM.mainprog: OPM.Write("m") + | OPM.dontasm: OPM.Write("S") + | OPM.dontlink: OPM.Write("c") + | OPM.mainlinkstat: OPM.Write("M") + | OPM.notcoloroutput: OPM.Write("f") + | OPM.forcenewsym: OPM.Write("F") + | OPM.verbose: OPM.Write("v") + ELSE + (* this else is necessary cause + if someone defined a new option in OPM module + and forgot to add it here then + if option is passed this will + generate __CASECHK and cause Halt, + noch *) + OPM.LogWStr ("( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg"); OPM.LogWLn; + END + END + END; + OPM.WriteString(" */"); OPM.WriteLn + END GenHeaderMsg; + + PROCEDURE GenHdrIncludes*; + BEGIN + OPM.currFile := OPM.HeaderInclude; + GenHeaderMsg; + OPM.WriteLn; + OPM.WriteString("#ifndef "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; + OPM.WriteString("#define "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; + OPM.WriteLn; + IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; + Include(BasicIncludeFile); + IncludeImports(OPT.topScope^.right, 1); OPM.WriteLn + END GenHdrIncludes; + + PROCEDURE GenBdy*(n: OPT.Node); + BEGIN + OPM.currFile := OPM.BodyFile; + GenHeaderMsg; + IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; + Include(BasicIncludeFile); + IncludeImports(OPT.topScope^.right, 0); OPM.WriteLn; + DefAnonRecs(n); + TypeDefs(OPT.topScope^.right, 0); OPM.WriteLn; + IdentList(OPT.topScope^.scope, 0); OPM.WriteLn; + GenDynTypes(n, OPM.internal); OPM.WriteLn; + ProcPredefs(OPT.topScope^.right, 0); OPM.WriteLn; + CProcDefs(OPT.topScope^.right, 0); OPM.WriteLn + END GenBdy; + + PROCEDURE RegCmds(obj: OPT.Object); + BEGIN + IF obj # NIL THEN + RegCmds(obj^.left); + IF (obj^.mode = OPM.XProc) & (obj^.history # OPM.removed) THEN + IF (obj^.vis # 0) & (obj^.link = NIL) & (obj^.typ = OPT.notyp) THEN (*command*) + BegStat; OPM.WriteString('__REGCMD("'); + OPM.WriteStringVar(obj.name); OPM.WriteString('", '); Ident(obj); OPM.Write(")"); EndStat + END + END ; + RegCmds(obj^.right) + END + END RegCmds; + + PROCEDURE InitImports(obj: OPT.Object); + BEGIN + IF obj # NIL THEN + InitImports(obj^.left); + IF (obj^.mode = OPM.Mod) & (obj^.mnolev # 0) THEN + BegStat; OPM.WriteString("__MODULE_IMPORT("); + OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name); + OPM.Write(')'); EndStat + END ; + InitImports(obj^.right) + END + END InitImports; + + PROCEDURE GenEnumPtrs* (var: OPT.Object); + VAR typ: OPT.Struct; n: LONGINT; + BEGIN GlbPtrs := FALSE; + WHILE var # NIL DO + typ := var^.typ; + IF NofPtrs(typ) > 0 THEN + IF ~GlbPtrs THEN GlbPtrs := TRUE; + OPM.WriteString('static '); + IF ansi THEN + OPM.WriteString("void EnumPtrs(void (*P)(void*))") + ELSE + OPM.WriteString("void EnumPtrs(P)"); OPM.WriteLn; + OPM.Write(Tab); OPM.WriteString("void (*P)();"); + END ; + OPM.WriteLn; + BegBlk + END ; + BegStat; + IF typ^.form = OPM.Pointer THEN + OPM.WriteString("P("); Ident(var); OPM.Write(")"); + ELSIF typ^.comp = OPM.Record THEN + OPM.WriteString("__ENUMR(&"); Ident(var); OPM.WriteString(", "); + Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); OPM.WriteString(", 1, P)") + ELSIF typ^.comp = OPM.Array THEN + n := typ^.n; typ := typ^.BaseTyp; + WHILE typ^.comp = OPM.Array DO n := n * typ^.n; typ := typ^.BaseTyp END ; + IF typ^.form = OPM.Pointer THEN + OPM.WriteString("__ENUMP("); Ident(var); Str1(", #, P)", n) + ELSIF typ^.comp = OPM.Record THEN + OPM.WriteString("__ENUMR("); Ident(var); OPM.WriteString(", "); + Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); Str1(", #, P)", n) + END + END ; + EndStat + END ; + var := var^.link + END ; + IF GlbPtrs THEN + EndBlk; OPM.WriteLn + END + END GenEnumPtrs; + + PROCEDURE EnterBody*; + BEGIN + OPM.WriteLn; OPM.WriteString(Export); + IF mainprog THEN + IF ansi THEN + OPM.WriteString("int main(int argc, char **argv)"); OPM.WriteLn; + ELSE + OPM.WriteString("main(argc, argv)"); OPM.WriteLn; + OPM.Write(Tab); OPM.WriteString("int argc; char **argv;"); OPM.WriteLn + END + ELSE + OPM.WriteString("void *"); + OPM.WriteString(OPM.modName); OPM.WriteString(BodyNameExt); OPM.WriteLn; + END ; + BegBlk; BegStat; + IF mainprog THEN OPM.WriteString("__INIT(argc, argv)") ELSE OPM.WriteString("__DEFMOD") END ; + EndStat; + IF mainprog & demoVersion THEN BegStat; + OPM.WriteString('/*don`t do it!*/ printf("DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\n")'); + EndStat + END ; + InitImports(OPT.topScope^.right); + BegStat; + IF mainprog THEN OPM.WriteString('__REGMAIN("') ELSE OPM.WriteString('__REGMOD("') END ; + OPM.WriteString(OPM.modName); + IF GlbPtrs THEN OPM.WriteString('", EnumPtrs)') ELSE OPM.WriteString('", 0)') END ; + EndStat; + IF OPM.modName # "SYSTEM" THEN RegCmds(OPT.topScope) END + END EnterBody; + + PROCEDURE ExitBody*; + BEGIN + BegStat; + IF mainprog THEN OPM.WriteString("__FINI;") ELSE OPM.WriteString("__ENDMOD;") END ; + OPM.WriteLn; EndBlk + END ExitBody; + + PROCEDURE DefineInter* (proc: OPT.Object); (* define intermediate scope record and variable *) + VAR scope: OPT.Object; + BEGIN + scope := proc^.scope; + OPM.WriteString('static '); OPM.WriteString('struct '); OPM.WriteStringVar(scope^.name); OPM.Write(' '); + BegBlk; + IdentList(proc^.link, 3); (* parameters *) + IdentList(scope^.scope, 3); (* local variables *) + BegStat; (* scope link field declaration *) + OPM.WriteString('struct '); OPM.WriteStringVar (scope^.name); + OPM.Write(' '); OPM.Write('*'); OPM.WriteString(LinkName); EndStat; + EndBlk0; OPM.Write(' '); + OPM.Write('*'); OPM.WriteStringVar (scope^.name); OPM.WriteString(GlobalScope); EndStat; OPM.WriteLn; + ProcPredefs (scope^.right, 0); + OPM.WriteLn; + END DefineInter; + + PROCEDURE EnterProc* (proc: OPT.Object); + VAR var, scope: OPT.Object; typ: OPT.Struct; dim: INTEGER; + BEGIN + IF proc^.vis # OPM.external THEN OPM.WriteString('static ') END ; + ProcHeader(proc, TRUE); + BegBlk; + + (* If there will be a result, provide a result variable. *) + IF proc^.typ # OPT.notyp THEN + BegStat; Ident(proc^.typ^.strobj); OPM.WriteString(" _o_result;"); OPM.WriteLn; END; - scope := proc^.scope; - IdentList(scope^.scope, 0); - IF ~scope^.leaf THEN (* declare intermediate procedure scope record variable*) - BegStat; OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name); - OPM.Write(Blank); OPM.WriteString(LocalScope); EndStat - END ; - var := proc^.link; - WHILE var # NIL DO (* declare copy of fixed size value array parameters *) - IF (var^.typ^.comp = Array) & (var^.mode = Var) THEN - BegStat; - IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END ; - OPM.Write(Blank); Ident(var); OPM.WriteString("__copy"); - EndStat - END ; - var := var^.link - END ; - IF ~ansi THEN - var := proc^.link; - WHILE var # NIL DO (* "unpromote" value real parameters *) - IF (var^.typ^.form = Real) & (var^.mode = Var) THEN - BegStat; - Ident(var^.typ^.strobj); OPM.Write(Blank); Ident(var); OPM.WriteString(" = _"); Ident(var); - EndStat - END ; - var := var^.link - END - END ; - var := proc^.link; - WHILE var # NIL DO (* copy value array parameters *) - IF (var^.typ^.comp IN {Array, DynArr}) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN - BegStat; - IF var^.typ^.comp = Array THEN - OPM.WriteString(DupArrFunc); - Ident(var); OPM.WriteString(Comma); - IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END - ELSE - OPM.WriteString(DupFunc); - Ident(var); OPM.WriteString(Comma); Ident(var); OPM.WriteString(LenExt); - typ := var^.typ^.BaseTyp; dim := 1; - WHILE typ^.comp = DynArr DO - OPM.WriteString(" * "); Ident(var); OPM.WriteString(LenExt); OPM.WriteInt(dim); - typ := typ^.BaseTyp; INC(dim) - END ; - OPM.WriteString(Comma); - IF (typ^.strobj = NIL) THEN OPM.Mark(200, typ^.txtpos) - ELSE Ident(typ^.strobj) - END - END ; - OPM.Write(CloseParen); EndStat - END ; - var := var^.link - END ; - IF ~scope^.leaf THEN - var := proc^.link; (* copy addresses of parameters into local scope record *) - WHILE var # NIL DO - IF ~var^.leaf THEN (* only if used by a nested procedure *) - BegStat; - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); - OPM.WriteString(Becomes); - IF var^.typ^.comp IN {Array, DynArr} THEN OPM.WriteString("(void*)") - (* K&R and ANSI differ in the type: array or element type*) - ELSIF var^.mode # VarPar THEN OPM.Write("&") - END ; - Ident(var); - IF var^.typ^.comp = DynArr THEN - typ := var^.typ; dim := 0; - REPEAT (* copy len(s) *) - OPM.WriteString("; "); - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END ; - OPM.WriteString(Becomes); Ident(var); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END ; - typ := typ^.BaseTyp - UNTIL typ^.comp # DynArr; - ELSIF (var^.mode = VarPar) & (var^.typ^.comp = Record) THEN - OPM.WriteString("; "); - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(TagExt); - OPM.WriteString(Becomes); Ident(var); OPM.WriteString(TagExt) - END ; - EndStat - END; - var := var^.link; - END; - var := scope^.scope; (* copy addresses of local variables into scope record *) - WHILE var # NIL DO - IF ~var^.leaf THEN (* only if used by a nested procedure *) - BegStat; - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(Becomes); - IF var^.typ^.comp # Array THEN OPM.Write("&") - ELSE OPM.WriteString("(void*)") (* K&R and ANSI differ in the type: array or element type*) - END ; - Ident(var); EndStat - END ; - var := var^.link - END; - (* now link new scope *) - BegStat; OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName); - OPM.WriteString(Becomes); OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); EndStat; - BegStat; OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); OPM.WriteString(Becomes); - OPM.Write("&"); OPM.WriteString(LocalScope); EndStat - END - END EnterProc; + scope := proc^.scope; + IdentList(scope^.scope, 0); + IF ~scope^.leaf THEN (* declare intermediate procedure scope record variable*) + BegStat; OPM.WriteString('struct '); OPM.WriteStringVar (scope^.name); + OPM.Write(' '); OPM.WriteString(LocalScope); EndStat + END ; + var := proc^.link; + WHILE var # NIL DO (* declare copy of fixed size value array parameters *) + IF (var^.typ^.comp = OPM.Array) & (var^.mode = OPM.Var) THEN + BegStat; + IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END ; + OPM.Write(' '); Ident(var); OPM.WriteString("__copy"); + EndStat + END ; + var := var^.link + END ; + IF ~ansi THEN + var := proc^.link; + WHILE var # NIL DO (* "unpromote" value real parameters *) + IF (var^.typ^.form = OPM.Real) & (var^.mode = OPM.Var) THEN + BegStat; + Ident(var^.typ^.strobj); OPM.Write(' '); Ident(var); OPM.WriteString(" = _"); Ident(var); + EndStat + END ; + var := var^.link + END + END ; + var := proc^.link; + WHILE var # NIL DO (* copy value array parameters *) + IF (var^.typ^.comp IN {OPM.Array, OPM.DynArr}) & (var^.mode = OPM.Var) & (var^.typ^.sysflag = 0) THEN + BegStat; + IF var^.typ^.comp = OPM.Array THEN + OPM.WriteString("__DUPARR("); + Ident(var); OPM.WriteString(', '); + IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END + ELSE + OPM.WriteString('__DUP('); + Ident(var); OPM.WriteString(', '); Ident(var); OPM.WriteString(LenExt); + typ := var^.typ^.BaseTyp; dim := 1; + WHILE typ^.comp = OPM.DynArr DO + OPM.WriteString(" * "); Ident(var); OPM.WriteString(LenExt); OPM.WriteInt(dim); + typ := typ^.BaseTyp; INC(dim) + END ; + OPM.WriteString(', '); + IF (typ^.strobj = NIL) THEN OPM.Mark(200, typ^.txtpos) + ELSE Ident(typ^.strobj) + END + END ; + OPM.Write(')'); EndStat + END ; + var := var^.link + END ; + IF ~scope^.leaf THEN + var := proc^.link; (* copy addresses of parameters into local scope record *) + WHILE var # NIL DO + IF ~var^.leaf THEN (* only if used by a nested procedure *) + BegStat; + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); + OPM.WriteString(' = '); + IF var^.typ^.comp IN {OPM.Array, OPM.DynArr} THEN OPM.WriteString("(void*)") + (* K&R and ANSI differ in the type: array or element type*) + ELSIF var^.mode # OPM.VarPar THEN OPM.Write("&") + END ; + Ident(var); + IF var^.typ^.comp = OPM.DynArr THEN + typ := var^.typ; dim := 0; + REPEAT (* copy len(s) *) + OPM.WriteString("; "); + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END ; + OPM.WriteString(' = '); Ident(var); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END ; + typ := typ^.BaseTyp + UNTIL typ^.comp # OPM.DynArr; + ELSIF (var^.mode = OPM.VarPar) & (var^.typ^.comp = OPM.Record) THEN + OPM.WriteString("; "); + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(TagExt); + OPM.WriteString(' = '); Ident(var); OPM.WriteString(TagExt) + END ; + EndStat + END; + var := var^.link; + END; + var := scope^.scope; (* copy addresses of local variables into scope record *) + WHILE var # NIL DO + IF ~var^.leaf THEN (* only if used by a nested procedure *) + BegStat; + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(' = '); + IF var^.typ^.comp # OPM.Array THEN OPM.Write("&") + ELSE OPM.WriteString("(void*)") (* K&R and ANSI differ in the type: array or element type*) + END ; + Ident(var); EndStat + END ; + var := var^.link + END; + (* now link new scope *) + BegStat; OPM.WriteString(LocalScope); OPM.Write('.'); OPM.WriteString(LinkName); + OPM.WriteString(' = '); OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); EndStat; + BegStat; OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); OPM.WriteString(' = '); + OPM.Write("&"); OPM.WriteString(LocalScope); EndStat + END + END EnterProc; - PROCEDURE ExitProc*(proc: OPT.Object; eoBlock, implicitRet: BOOLEAN); - VAR var: OPT.Object; indent: BOOLEAN; - BEGIN - indent := eoBlock; - IF implicitRet & (proc^.typ # OPT.notyp) THEN - OPM.Write(Tab); OPM.WriteString("__RETCHK;"); OPM.WriteLn - ELSIF ~eoBlock OR implicitRet THEN - IF ~proc^.scope^.leaf THEN - (* link scope pointer of nested proc back to previous scope *) - IF indent THEN BegStat ELSE indent := TRUE END ; - OPM.WriteStringVar(proc^.scope^.name); OPM.WriteString(GlobalScope); - OPM.WriteString(Becomes); OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName); - EndStat - END; - (* delete array value parameters *) - var := proc^.link; - WHILE var # NIL DO - IF (var^.typ^.comp = DynArr) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN - IF indent THEN BegStat ELSE indent := TRUE END ; - OPM.WriteString(DelFunc); Ident(var); OPM.Write(CloseParen); EndStat - END ; - var := var^.link - END - END ; - IF eoBlock THEN EndBlk; OPM.WriteLn - ELSIF indent THEN BegStat - END - END ExitProc; + PROCEDURE ExitProc*(proc: OPT.Object; eoBlock, implicitRet: BOOLEAN); + VAR var: OPT.Object; indent: BOOLEAN; + BEGIN + indent := eoBlock; + IF implicitRet & (proc^.typ # OPT.notyp) THEN + OPM.Write(Tab); OPM.WriteString("__RETCHK;"); OPM.WriteLn + ELSIF ~eoBlock OR implicitRet THEN + IF ~proc^.scope^.leaf THEN + (* link scope pointer of nested proc back to previous scope *) + IF indent THEN BegStat ELSE indent := TRUE END ; + OPM.WriteStringVar(proc^.scope^.name); OPM.WriteString(GlobalScope); + OPM.WriteString(' = '); OPM.WriteString(LocalScope); OPM.Write('.'); OPM.WriteString(LinkName); + EndStat + END; + (* delete array value parameters *) + var := proc^.link; + WHILE var # NIL DO + IF (var^.typ^.comp = OPM.DynArr) & (var^.mode = OPM.Var) & (var^.typ^.sysflag = 0) THEN + IF indent THEN BegStat ELSE indent := TRUE END ; + OPM.WriteString('__DEL('); Ident(var); OPM.Write(')'); EndStat + END ; + var := var^.link + END + END ; + IF eoBlock THEN EndBlk; OPM.WriteLn + ELSIF indent THEN BegStat + END + END ExitProc; - PROCEDURE CompleteIdent*(obj: OPT.Object); - VAR comp, level: INTEGER; - BEGIN - (* obj^.mode IN {Var, VarPar} *) - level := obj^.mnolev; - IF obj^.adr = 1 THEN (* WITH-variable *) - IF obj^.typ^.comp = Record THEN Ident(obj); OPM.WriteString("__") - ELSE (* cast with guard pointer type *) - OPM.WriteString("(("); Ident(obj^.typ^.strobj); OPM.Write(")"); Ident(obj); OPM.Write(")") - END - ELSIF (level # OPM.level) & (level > 0) THEN (* intermediate var *) - comp := obj^.typ^.comp; - IF (obj^.mode # VarPar) & (comp # DynArr) THEN OPM.Write(Star); END; - OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString(GlobalScope); - OPM.WriteString("->"); Ident(obj) - ELSE - Ident(obj) - END - END CompleteIdent; + PROCEDURE CompleteIdent*(obj: OPT.Object); + VAR comp, level: INTEGER; + BEGIN + (* obj^.mode IN {OPM.Var, OPM.VarPar} *) + level := obj^.mnolev; + IF obj^.adr = 1 THEN (* WITH-variable *) + IF obj^.typ^.comp = OPM.Record THEN Ident(obj); OPM.WriteString("__") + ELSE (* cast with guard pointer type *) + OPM.WriteString("(("); Ident(obj^.typ^.strobj); OPM.Write(")"); Ident(obj); OPM.Write(")") + END + ELSIF (level # OPM.level) & (level > 0) THEN (* intermediate var *) + comp := obj^.typ^.comp; + IF (obj^.mode # OPM.VarPar) & (comp # OPM.DynArr) THEN OPM.Write('*'); END; + OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString(GlobalScope); + OPM.WriteString("->"); Ident(obj) + ELSE + Ident(obj) + END + END CompleteIdent; - PROCEDURE TypeOf*(ap: OPT.Object); - VAR i: INTEGER; - BEGIN - ASSERT(ap.typ.comp = Record); - IF ap.mode = VarPar THEN - IF ap.mnolev # OPM.level THEN (*intermediate level var-par record; possible WITH-guarded*) - OPM.WriteStringVar(ap^.scope^.name); OPM.WriteString("_s->"); Ident(ap) - ELSE (*local var-par record*) - Ident(ap) - END ; - OPM.WriteString(TagExt) - ELSIF ap^.typ^.strobj # NIL THEN - Ident(ap^.typ^.strobj); OPM.WriteString(DynTypExt) - ELSE Andent(ap.typ) (*anonymous ap type, p^ *) - END - END TypeOf; + PROCEDURE TypeOf*(ap: OPT.Object); + VAR i: INTEGER; + BEGIN + ASSERT(ap.typ.comp = OPM.Record); + IF ap.mode = OPM.VarPar THEN + IF ap.mnolev # OPM.level THEN (*intermediate level var-par record; possible WITH-guarded*) + OPM.WriteStringVar(ap^.scope^.name); OPM.WriteString("_s->"); Ident(ap) + ELSE (*local var-par record*) + Ident(ap) + END ; + OPM.WriteString(TagExt) + ELSIF ap^.typ^.strobj # NIL THEN + Ident(ap^.typ^.strobj); OPM.WriteString(DynTypExt) + ELSE Andent(ap.typ) (*anonymous ap type, p^ *) + END + END TypeOf; - PROCEDURE Cmp*(rel: INTEGER); - BEGIN - CASE rel OF - eql : - OPM.WriteString(" == "); - | neq : - OPM.WriteString(" != "); - | lss : - OPM.WriteString(" < "); - | leq : - OPM.WriteString(" <= "); - | gtr : - OPM.WriteString(" > "); - | geq : - OPM.WriteString(" >= "); - ELSE - OPM.LogWStr("unhandled case in OPC.Cmp, rel = "); OPM.LogWNum(rel, 0); OPM.LogWLn; - END; - END Cmp; + PROCEDURE Cmp*(rel: INTEGER); + BEGIN + CASE rel OF + OPM.eql : + OPM.WriteString(" == "); + | OPM.neq : + OPM.WriteString(" != "); + | OPM.lss : + OPM.WriteString(" < "); + | OPM.leq : + OPM.WriteString(" <= "); + | OPM.gtr : + OPM.WriteString(" > "); + | OPM.geq : + OPM.WriteString(" >= "); + ELSE + OPM.LogWStr("unhandled case in OPC.Cmp, rel = "); OPM.LogWNum(rel, 0); OPM.LogWLn; + END; + END Cmp; - PROCEDURE Case*(caseVal: LONGINT; form: INTEGER); - VAR - ch: CHAR; - BEGIN - OPM.WriteString(CaseStat); - CASE form OF - | Char : - ch := CHR (caseVal); - IF (ch >= " ") & (ch <= "~") THEN - OPM.Write(SingleQuote); - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\"); OPM.Write(ch); - ELSE OPM.Write(ch); - END; - OPM.Write(SingleQuote); - ELSE - OPM.WriteString("0x"); OPM.WriteHex (caseVal); - END; - | SInt, Int, LInt : - OPM.WriteInt (caseVal); - ELSE - OPM.LogWStr("unhandled case in OPC.Case, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; - END; - OPM.WriteString(Colon); - END Case; + PROCEDURE Case*(caseVal: LONGINT; form: INTEGER); + VAR + ch: CHAR; + BEGIN + OPM.WriteString('case '); + CASE form OF + | OPM.Char : + ch := CHR (caseVal); + IF (ch >= " ") & (ch <= "~") THEN + OPM.Write("'"); + IF (ch = Backslash) OR (ch = "?") OR (ch = "'") OR (ch = '"') THEN OPM.Write(Backslash); OPM.Write(ch); + ELSE OPM.Write(ch); + END; + OPM.Write("'"); + ELSE + OPM.WriteString("0x"); OPM.WriteHex (caseVal); + END; + | OPM.SInt, OPM.Int, OPM.LInt : + OPM.WriteInt(caseVal); + ELSE + OPM.LogWStr("unhandled case in OPC.Case, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; + END; + OPM.WriteString(': '); + END Case; - PROCEDURE SetInclude* (exclude: BOOLEAN); - BEGIN - IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END; - END SetInclude; + PROCEDURE SetInclude* (exclude: BOOLEAN); + BEGIN + IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END; + END SetInclude; - PROCEDURE Increment* (decrement: BOOLEAN); - BEGIN - IF decrement THEN OPM.WriteString(" -= "); ELSE OPM.WriteString(" += "); END; - END Increment; + PROCEDURE Increment* (decrement: BOOLEAN); + BEGIN + IF decrement THEN OPM.WriteString(" -= "); ELSE OPM.WriteString(" += "); END; + END Increment; - PROCEDURE Halt* (n: LONGINT); - BEGIN - Str1("__HALT(#)", n) - END Halt; + PROCEDURE Halt* (n: LONGINT); + BEGIN + Str1("__HALT(#)", n) + END Halt; - PROCEDURE Len* (obj: OPT.Object; array: OPT.Struct; dim: LONGINT); - BEGIN - IF array^.comp = DynArr THEN - CompleteIdent(obj); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END - ELSE (* array *) - WHILE dim > 0 DO array := array^.BaseTyp; DEC(dim) END ; - OPM.WriteString("((LONGINT)("); OPM.WriteInt(array^.n); OPM.WriteString("))"); - END - END Len; + PROCEDURE Len* (obj: OPT.Object; array: OPT.Struct; dim: LONGINT); + BEGIN + IF array^.comp = OPM.DynArr THEN + CompleteIdent(obj); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END + ELSE (* array *) + WHILE dim > 0 DO array := array^.BaseTyp; DEC(dim) END ; + OPM.WriteString("((LONGINT)("); OPM.WriteInt(array^.n); OPM.WriteString("))"); + END + END Len; - PROCEDURE Constant* (con: OPT.Const; form: INTEGER); - VAR i, len: INTEGER; ch: CHAR; s: SET; - hex: LONGINT; skipLeading: BOOLEAN; - BEGIN - CASE form OF - Byte: - OPM.WriteInt(con^.intval) - | Bool: - OPM.WriteInt(con^.intval) - | Char: - ch := CHR(con^.intval); - IF (ch >= " ") & (ch <= "~") THEN - OPM.Write(SingleQuote); - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ; - OPM.Write(ch); - OPM.Write(SingleQuote) - ELSE - OPM.WriteString("0x"); OPM.WriteHex(con^.intval) - END - | SInt, Int, LInt: - OPM.WriteInt(con^.intval) -(* | Int8, Int16, Int32, Int64: - OPM.WriteInt(con^.intval)*) - | Real: - OPM.WriteReal(con^.realval, "f") - | LReal: - OPM.WriteReal(con^.realval, 0X) - | Set: - OPM.WriteString("0x"); - skipLeading := TRUE; - s := con^.setval; i := MAX(SET) + 1; - REPEAT - hex := 0; - REPEAT - DEC(i); hex := 2 * hex; - IF i IN s THEN INC(hex) END - UNTIL i MOD 8 = 0; - IF (hex # 0) OR ~skipLeading THEN - OPM.WriteHex(hex); - skipLeading := FALSE - END - UNTIL i = 0; - IF skipLeading THEN OPM.Write("0") END - | String: - OPM.Write(Quotes); - len := SHORT(con^.intval2) - 1; i := 0; - WHILE i < len DO ch := con^.ext^[i]; - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ; - OPM.Write(ch); INC(i) - END ; - OPM.Write(Quotes) - | NilTyp: - OPM.WriteString(NilConst); - ELSE - OPM.LogWStr("unhandled case in OPC.Constant, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; - END; - END Constant; + PROCEDURE Constant* (con: OPT.Const; form: INTEGER); + VAR i, len: INTEGER; ch: CHAR; s: SET; + hex: LONGINT; skipLeading: BOOLEAN; + BEGIN + CASE form OF + OPM.Byte: + OPM.WriteInt(con^.intval) + | OPM.Bool: + OPM.WriteInt(con^.intval) + | OPM.Char: + ch := CHR(con^.intval); + IF (ch >= " ") & (ch <= "~") THEN + OPM.Write("'"); + IF (ch = Backslash) OR (ch = "?") OR (ch = "'") OR (ch = '"') THEN OPM.Write(Backslash) END ; + OPM.Write(ch); + OPM.Write("'") + ELSE + OPM.WriteString("0x"); OPM.WriteHex(con^.intval) + END + | OPM.SInt, OPM.Int, OPM.LInt: + OPM.WriteInt(con^.intval) + | OPM.Real: + OPM.WriteReal(con^.realval, "f") + | OPM.LReal: + OPM.WriteReal(con^.realval, 0X) + | OPM.Set: + OPM.WriteString("0x"); + skipLeading := TRUE; + s := con^.setval; i := MAX(SET) + 1; + REPEAT + hex := 0; + REPEAT + DEC(i); hex := 2 * hex; + IF i IN s THEN INC(hex) END + UNTIL i MOD 8 = 0; + IF (hex # 0) OR ~skipLeading THEN + OPM.WriteHex(hex); + skipLeading := FALSE + END + UNTIL i = 0; + IF skipLeading THEN OPM.Write("0") END + | OPM.String: + OPM.Write('"'); + len := SHORT(con^.intval2) - 1; i := 0; + WHILE i < len DO ch := con^.ext^[i]; + IF (ch = Backslash) OR (ch = "?") OR (ch = "'") OR (ch = '"') THEN OPM.Write(Backslash) END ; + OPM.Write(ch); INC(i) + END ; + OPM.Write('"') + | OPM.NilTyp: + OPM.WriteString('NIL'); + ELSE + OPM.LogWStr("unhandled case in OPC.Constant, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; + END; + END Constant; - PROCEDURE InitKeywords; - VAR n, i: SHORTINT; + PROCEDURE InitKeywords; + VAR n, i: SHORTINT; - PROCEDURE Enter(s: ARRAY OF CHAR); - VAR h: INTEGER; - BEGIN h := PerfectHash(s); hashtab[h] := n; COPY(s, keytab[n]); INC(n) - END Enter; + PROCEDURE Enter(s: ARRAY OF CHAR); + VAR h: INTEGER; + BEGIN h := PerfectHash(s); hashtab[h] := n; COPY(s, keytab[n]); INC(n) + END Enter; - BEGIN n := 0; - FOR i := 0 TO 104 DO hashtab[i] := -1 END ; - Enter("asm"); - Enter("auto"); - Enter("break"); - Enter("case"); - Enter("char"); - Enter("const"); - Enter("continue"); - Enter("default"); - Enter("do"); - Enter("double"); - Enter("else"); - Enter("enum"); - Enter("extern"); - Enter("export"); (* pseudo keyword used by voc *) - Enter("float"); - Enter("for"); - Enter("fortran"); - Enter("goto"); - Enter("if"); - Enter("import"); (* pseudo keyword used by voc *) - Enter("int"); - Enter("long"); - Enter("register"); - Enter("return"); - Enter("short"); - Enter("signed"); - Enter("sizeof"); - Enter("static"); - Enter("struct"); - Enter("switch"); - Enter("typedef"); - Enter("union"); - Enter("unsigned"); - Enter("void"); - Enter("volatile"); - Enter("while"); + BEGIN n := 0; + FOR i := 0 TO 104 DO hashtab[i] := -1 END ; + Enter("asm"); + Enter("auto"); + Enter("break"); + Enter("case"); + Enter("char"); + Enter("const"); + Enter("continue"); + Enter("default"); + Enter("do"); + Enter("double"); + Enter("else"); + Enter("enum"); + Enter("extern"); + Enter("export"); (* pseudo keyword used by voc *) + Enter("float"); + Enter("for"); + Enter("fortran"); + Enter("goto"); + Enter("if"); + Enter("import"); (* pseudo keyword used by voc *) + Enter("int"); + Enter("long"); + Enter("register"); + Enter("return"); + Enter("short"); + Enter("signed"); + Enter("sizeof"); + Enter("static"); + Enter("struct"); + Enter("switch"); + Enter("typedef"); + Enter("union"); + Enter("unsigned"); + Enter("void"); + Enter("volatile"); + Enter("while"); (* what about common predefined names from cpp as e.g. Operating System: ibm, gcos, os, tss and unix @@ -1415,7 +1356,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) The lint(1V) command: lint *) - END InitKeywords; + END InitKeywords; BEGIN InitKeywords END OPC. diff --git a/src/compiler/OPM.cmdln.Mod b/src/compiler/OPM.cmdln.Mod index 5bd9b015..e7b0d015 100644 --- a/src/compiler/OPM.cmdln.Mod +++ b/src/compiler/OPM.cmdln.Mod @@ -79,6 +79,127 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) HFext = ".h"; (* header file extension *) SFtag = 0F7X; (* symbol file tag *) + + + + (***** Symbols *****) + + + (* Symbols values (also used as op values): + | 0 1 2 3 4 + ---|-------------------------------------------------------- + 0 | null * / DIV MOD + 5 | & + - OR = + 10 | # < <= > >= + 15 | IN IS ^ . , + 20 | : .. ) ] } + 25 | OF THEN DO TO BY + 30 | ( [ { ~ := + 35 | number NIL string OPM.ident ; + 40 | | END ELSE ELSIF UNTIL + 45 | IF CASE WHILE REPEAT FOR + 50 | LOOP WITH EXIT RETURN ARRAY + 55 | RECORD POINTER BEGIN CONST TYPE + 60 | VAR PROCEDURE IMPORT MODULE eof + *) + + null* = 0; times* = 1; slash* = 2; div* = 3; mod* = 4; + and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; + neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; + in* = 15; is* = 16; arrow* = 17; period* = 18; comma* = 19; + colon* = 20; upto* = 21; rparen* = 22; rbrak* = 23; rbrace* = 24; + of* = 25; then* = 26; do* = 27; to* = 28; by* = 29; + lparen* = 30; lbrak* = 31; lbrace* = 32; not* = 33; becomes* = 34; + number* = 35; nil* = 36; string* = 37; ident* = 38; semicolon* = 39; + bar* = 40; end* = 41; else* = 42; elsif* = 43; until* = 44; + if* = 45; case* = 46; while* = 47; repeat* = 48; for* = 49; + loop* = 50; with* = 51; exit* = 52; return* = 53; array* = 54; + record* = 55; pointer* = 56; begin* = 57; const* = 58; type* = 59; + var* = 60; procedure* = 61; import* = 62; module* = 63; eof* = 64; + + (* Symbol numtyp values *) + char* = 1; integer* = 2; real* = 3; longreal* = 4; + + + + + (***** Objects *****) + + + (* Object.mode values *) + Var* = 1; VarPar* = 2; Con* = 3; Fld* = 4; Typ* = 5; LProc* = 6; XProc* = 7; + SProc* = 8; CProc* = 9; IProc* = 10; Mod* = 11; Head* = 12; TProc* = 13; + + (* Object.vis - module visibility of objects *) + internal* = 0; external* = 1; externalR* = 2; + + (* Object.history - History of imported objects *) + inserted* = 0; same* = 1; pbmodified* = 2; pvmodified* = 3; removed* = 4; inconsistent* = 5; + + (* Object.adr Function numbers *) + haltfn* = 0; newfn* = 1; absfn* = 2; capfn* = 3; ordfn* = 4; + entierfn* = 5; oddfn* = 6; minfn* = 7; maxfn* = 8; chrfn* = 9; + shortfn* = 10; longfn* = 11; sizefn* = 12; incfn* = 13; decfn* = 14; + inclfn* = 15; exclfn* = 16; lenfn* = 17; copyfn* = 18; ashfn* = 19; + adrfn* = 20; ccfn* = 21; lshfn* = 22; rotfn* = 23; getfn* = 24; (* SYSTEM *) + putfn* = 25; getrfn* = 26; putrfn* = 27; bitfn* = 28; valfn* = 29; (* SYSTEM *) + sysnewfn* = 30; movefn* = 31; (* SYSTEM *) + assertfn* = 32; + + + + + (***** Structures *****) + + + (* Struct.form values *) + Undef* = 0; Byte* = 1; Bool* = 2; Char* = 3; + SInt* = 4; Int* = 5; LInt* = 6; + Real* = 7; LReal* = 8; Set* = 9; String* = 10; + NilTyp* = 11; NoTyp* = 12; Pointer* = 13; ProcTyp* = 14; + Comp* = 15; + + intSet* = {SInt..LInt(*, Int8..Int64*)}; realSet* = {Real, LReal}; + + (* Struct.comp - Composite structure forms *) + Basic* = 1; Array* = 2; DynArr* = 3; Record* = 4; + + + + + (***** Nodes *****) + + + (* Node.class values *) + Nvar* = 0; Nvarpar* = 1; Nfield* = 2; Nderef* = 3; Nindex* = 4; Nguard* = 5; Neguard* = 6; + Nconst* = 7; Ntype* = 8; Nproc* = 9; Nupto* = 10; Nmop* = 11; Ndop* = 12; Ncall* = 13; + Ninittd* = 14; Nif* = 15; Ncaselse* = 16; Ncasedo* = 17; Nenter* = 18; Nassign* = 19; + Nifelse* = 20; Ncase* = 21; Nwhile* = 22; Nrepeat* = 23; Nloop* = 24; Nexit* = 25; + Nreturn* = 26; Nwith* = 27; Ntrap* = 28; + + + (* Node.subcl values - general *) + assign* = 0; (* Pseudo function number for assignment *) + super* = 1; + + (* Node.subcl values - functions *) + ash* = 17; msk* = 18; len* = 19; + conv* = 20; abs* = 21; cap* = 22; odd* = 23; + + (* Node.subcl values - SYSTEM functions *) + adr* = 24; cc* = 25; bit* = 26; lsh* = 27; rot* = 28; val* = 29; + + (* Note: some object.adr function numbers and some symbol types are + also are used as Node.subcl function ids *) + + + + (* conval^.setval procedure flags *) + hasBody* = 1; isRedef* = 2; slNeeded* = 3; + + + + TYPE FileName = ARRAY 32 OF CHAR; @@ -142,27 +263,30 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) i := 1; (* skip - *) WHILE s[i] # 0X DO CASE s[i] OF - | "e": opt := opt / {extsf} - | "s": opt := opt / {newsf} - | "m": opt := opt / {mainprog} - | "x": opt := opt / {inxchk} - | "r": opt := opt / {ranchk} - | "t": opt := opt / {typchk} + | "a": opt := opt / {assert} - | "k": opt := opt / {ansi} (* undocumented *) - | "p": opt := opt / {ptrinit} - | "S": opt := opt / {dontasm} | "c": opt := opt / {dontlink} - | "M": opt := opt / {mainlinkstat} + | "e": opt := opt / {extsf} | "f": opt := opt / {notcoloroutput} - | "F": opt := opt / {forcenewsym} - | "V": opt := opt / {verbose} + | "k": opt := opt / {ansi} (* undocumented *) + | "m": opt := opt / {mainprog} + | "p": opt := opt / {ptrinit} + | "r": opt := opt / {ranchk} + | "s": opt := opt / {newsf} + | "t": opt := opt / {typchk} + | "x": opt := opt / {inxchk} + | "B": IF s[i+1] # 0X THEN INC(i); IntSize := ORD(s[i]) - ORD('0') END; IF s[i+1] # 0X THEN INC(i); PointerSize := ORD(s[i]) - ORD('0') END; IF s[i+1] # 0X THEN INC(i); Alignment := ORD(s[i]) - ORD('0') END; ASSERT((IntSize = 2) OR (IntSize = 4)); ASSERT((PointerSize = 4) OR (PointerSize = 8)); - ASSERT((Alignment = 4) OR (Alignment = 8)) + ASSERT((Alignment = 4) OR (Alignment = 8)); + Files.SetSearchPath("") + | "F": opt := opt / {forcenewsym} + | "M": opt := opt / {mainlinkstat} + | "S": opt := opt / {dontasm} + | "V": opt := opt / {verbose} ELSE LogWStr(" warning: option "); LogW(OptionChar); @@ -484,10 +608,10 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) END GetProperty; - PROCEDURE minus(i: LONGINT): LONGINT; + PROCEDURE minusop(i: LONGINT): LONGINT; BEGIN RETURN -i; - END minus; + END minusop; PROCEDURE power0(i, j : LONGINT) : LONGINT; (* we would like to calculate exact Min Max values in GetProperties, not hardcode em, noch *) @@ -529,9 +653,20 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) END VerboseListSizes; - PROCEDURE Min(a,b: INTEGER): INTEGER; - BEGIN IF a 8 THEN align := 16 + ELSIF size > 4 THEN align := 8 + ELSIF size > 2 THEN align := 4 + ELSE align := SHORT(size) + END + ELSE + align := Alignment + END; + RETURN align + END AlignSize; PROCEDURE GetProperties(); VAR @@ -547,28 +682,28 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) SetSize := LIntSize; (* Calculate all type alignments *) - CharAlign := Min(Alignment, CharSize); - BoolAlign := Min(Alignment, BoolSize); - SIntAlign := Min(Alignment, SIntSize); - RecAlign := Min(Alignment, RecSize); - RealAlign := Min(Alignment, RealSize); - LRealAlign := Min(Alignment, LRealSize); - PointerAlign := Min(Alignment, PointerSize); - ProcAlign := Min(Alignment, ProcSize); - IntAlign := Min(Alignment, IntSize); - LIntAlign := Min(Alignment, LIntSize); - SetAlign := Min(Alignment, SetSize); + CharAlign := AlignSize(CharSize); + BoolAlign := AlignSize(BoolSize); + SIntAlign := AlignSize(SIntSize); + RecAlign := AlignSize(RecSize); + RealAlign := AlignSize(RealSize); + LRealAlign := AlignSize(LRealSize); + PointerAlign := AlignSize(PointerSize); + ProcAlign := AlignSize(ProcSize); + IntAlign := AlignSize(IntSize); + LIntAlign := AlignSize(LIntSize); + SetAlign := AlignSize(SetSize); (* and I'd like to calculate it, not hardcode constants *) base := -2; MinSInt := ASH(base, SIntSize*8-2); - MaxSInt := minus(MinSInt + 1); + MaxSInt := minusop(MinSInt + 1); MinInt := ASH(base, IntSize*8-2); - MaxInt := minus(MinInt + 1); + MaxInt := minusop(MinInt + 1); MinLInt := ASH(base, LIntSize*8-2); - MaxLInt := minus(MinLInt +1); + MaxLInt := minusop(MinLInt +1); IF RealSize = 4 THEN MaxReal := 3.40282346D38 ELSIF RealSize = 8 THEN MaxReal := 1.7976931348623157D307 * 9.999999 diff --git a/src/compiler/OPP.Mod b/src/compiler/OPP.Mod index a9f30a0c..79a32bc5 100644 --- a/src/compiler/OPP.Mod +++ b/src/compiler/OPP.Mod @@ -3,68 +3,6 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IMPORT OPB, OPT, OPS, OPM; - CONST - (* numtyp values *) - char = 1; integer = 2; real = 3; longreal = 4; - - (* symbol values *) - null = 0; times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; arrow = 17; period = 18; comma = 19; - colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24; - of = 25; then = 26; do = 27; to = 28; by = 29; - lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34; - number = 35; nil = 36; string = 37; ident = 38; semicolon = 39; - bar = 40; end = 41; else = 42; elsif = 43; until = 44; - if = 45; case = 46; while = 47; repeat = 48; for = 49; - loop = 50; with = 51; exit = 52; return = 53; array = 54; - record = 55; pointer = 56; begin = 57; const = 58; type = 59; - var = 60; procedure = 61; import = 62; module = 63; eof = 64; - - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* Structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - intSet = {SInt..LInt(*, Int8..Int64*)}; - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (*function number*) - haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; - Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (* node subclasses *) - super = 1; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* procedure flags (conval^.setval) *) - hasBody = 1; isRedef = 2; slNeeded = 3; - TYPE CaseTable = ARRAY OPM.MaxCases OF RECORD @@ -93,19 +31,19 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE qualident(VAR id: OPT.Object); VAR obj: OPT.Object; lev: SHORTINT; - BEGIN (*sym = ident*) + BEGIN (*sym = OPM.ident*) OPT.Find(obj); OPS.Get(sym); - IF (sym = period) & (obj # NIL) & (obj^.mode = Mod) THEN + IF (sym = OPM.period) & (obj # NIL) & (obj^.mode = OPM.Mod) THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPM.ident THEN OPT.FindImport(obj, obj); OPS.Get(sym) - ELSE err(ident); obj := NIL + ELSE err(OPM.ident); obj := NIL END END ; IF obj = NIL THEN err(0); - obj := OPT.NewObj(); obj^.mode := Var; obj^.typ := OPT.undftyp; obj^.adr := 0 + obj := OPT.NewObj(); obj^.mode := OPM.Var; obj^.typ := OPT.undftyp; obj^.adr := 0 ELSE lev := obj^.mnolev; - IF (obj^.mode IN {Var, VarPar}) & (lev # level) THEN + IF (obj^.mode IN {OPM.Var, OPM.VarPar}) & (lev # level) THEN obj^.leaf := FALSE; IF lev > 0 THEN OPB.StaticLink(level-lev) END END @@ -115,32 +53,32 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ConstExpression(VAR x: OPT.Node); BEGIN Expression(x); - IF x^.class # Nconst THEN + IF x^.class # OPM.Nconst THEN err(50); x := OPB.NewIntConst(1) END END ConstExpression; PROCEDURE CheckMark(VAR vis: SHORTINT); BEGIN OPS.Get(sym); - IF (sym = times) OR (sym = minus) THEN + IF (sym = OPM.times) OR (sym = OPM.minus) THEN IF level > 0 THEN err(47) END ; - IF sym = times THEN vis := external ELSE vis := externalR END ; + IF sym = OPM.times THEN vis := OPM.external ELSE vis := OPM.externalR END ; OPS.Get(sym) - ELSE vis := internal + ELSE vis := OPM.internal END END CheckMark; PROCEDURE CheckSysFlag(VAR sysflag: INTEGER; default: INTEGER); VAR x: OPT.Node; sf: LONGINT; BEGIN - IF sym = lbrak THEN OPS.Get(sym); + IF sym = OPM.lbrak THEN OPS.Get(sym); IF ~OPT.SYSimported THEN err(135) END; ConstExpression(x); - IF x^.typ^.form IN intSet THEN sf := x^.conval^.intval; + IF x^.typ^.form IN OPM.intSet THEN sf := x^.conval^.intval; IF (sf < 0) OR (sf > OPM.MaxSysFlag) THEN err(220); sf := 0 END ELSE err(51); sf := 0 END ; - sysflag := SHORT(sf); CheckSym(rbrak) + sysflag := SHORT(sf); CheckSym(OPM.rbrak) ELSE sysflag := default END END CheckSysFlag; @@ -148,54 +86,54 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE RecordType(VAR typ, banned: OPT.Struct); VAR fld, first, last, base: OPT.Object; ftyp: OPT.Struct; sysflag: INTEGER; - BEGIN typ := OPT.NewStr(Comp, Record); typ^.BaseTyp := NIL; + BEGIN typ := OPT.NewStr(OPM.Comp, OPM.Record); typ^.BaseTyp := NIL; CheckSysFlag(sysflag, -1); - IF sym = lparen THEN + IF sym = OPM.lparen THEN OPS.Get(sym); (*record extension*) - IF sym = ident THEN + IF sym = OPM.ident THEN qualident(base); - IF (base^.mode = Typ) & (base^.typ^.comp = Record) THEN + IF (base^.mode = OPM.Typ) & (base^.typ^.comp = OPM.Record) THEN IF base^.typ = banned THEN err(58) ELSE base^.typ^.pvused := TRUE; typ^.BaseTyp := base^.typ; typ^.extlev := base^.typ^.extlev + 1; typ^.sysflag := base^.typ^.sysflag END ELSE err(52) END - ELSE err(ident) + ELSE err(OPM.ident) END ; - CheckSym(rparen) + CheckSym(OPM.rparen) END ; IF sysflag >= 0 THEN typ^.sysflag := sysflag END ; OPT.OpenScope(0, NIL); first := NIL; last := NIL; LOOP - IF sym = ident THEN + IF sym = OPM.ident THEN LOOP - IF sym = ident THEN + IF sym = OPM.ident THEN IF typ^.BaseTyp # NIL THEN OPT.FindField(OPS.name, typ^.BaseTyp, fld); IF fld # NIL THEN err(1) END END ; OPT.Insert(OPS.name, fld); CheckMark(fld^.vis); - fld^.mode := Fld; fld^.link := NIL; fld^.typ := OPT.undftyp; + fld^.mode := OPM.Fld; fld^.link := NIL; fld^.typ := OPT.undftyp; IF first = NIL THEN first := fld END ; IF last = NIL THEN typ^.link := fld ELSE last^.link := fld END ; last := fld - ELSE err(ident) + ELSE err(OPM.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF sym = OPM.ident THEN err(OPM.comma) ELSE EXIT END END ; - CheckSym(colon); Type(ftyp, banned); + CheckSym(OPM.colon); Type(ftyp, banned); ftyp^.pvused := TRUE; - IF ftyp^.comp = DynArr THEN ftyp := OPT.undftyp; err(88) END ; + IF ftyp^.comp = OPM.DynArr THEN ftyp := OPT.undftyp; err(88) END ; WHILE first # NIL DO first^.typ := ftyp; first := first^.link END END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF sym = ident THEN err(semicolon) + IF sym = OPM.semicolon THEN OPS.Get(sym) + ELSIF sym = OPM.ident THEN err(OPM.semicolon) ELSE EXIT END END ; @@ -205,36 +143,36 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ArrayType(VAR typ, banned: OPT.Struct); VAR x: OPT.Node; n: LONGINT; sysflag: INTEGER; BEGIN CheckSysFlag(sysflag, 0); - IF sym = of THEN (*dynamic array*) - typ := OPT.NewStr(Comp, DynArr); typ^.mno := 0; typ^.sysflag := sysflag; + IF sym = OPM.of THEN (*dynamic array*) + typ := OPT.NewStr(OPM.Comp, OPM.DynArr); typ^.mno := 0; typ^.sysflag := sysflag; OPS.Get(sym); Type(typ^.BaseTyp, banned); typ^.BaseTyp^.pvused := TRUE; - IF typ^.BaseTyp^.comp = DynArr THEN typ^.n := typ^.BaseTyp^.n + 1 + IF typ^.BaseTyp^.comp = OPM.DynArr THEN typ^.n := typ^.BaseTyp^.n + 1 ELSE typ^.n := 0 END ELSE - typ := OPT.NewStr(Comp, Array); typ^.sysflag := sysflag; ConstExpression(x); - IF x^.typ^.form IN intSet THEN n := x^.conval^.intval; + typ := OPT.NewStr(OPM.Comp, OPM.Array); typ^.sysflag := sysflag; ConstExpression(x); + IF x^.typ^.form IN OPM.intSet THEN n := x^.conval^.intval; IF (n <= 0) OR (n > OPM.MaxIndex) THEN err(63); n := 1 END ELSE err(51); n := 1 END ; typ^.n := n; - IF sym = of THEN + IF sym = OPM.of THEN OPS.Get(sym); Type(typ^.BaseTyp, banned); typ^.BaseTyp^.pvused := TRUE - ELSIF sym = comma THEN - OPS.Get(sym); IF sym # of THEN ArrayType(typ^.BaseTyp, banned) END + ELSIF sym = OPM.comma THEN + OPS.Get(sym); IF sym # OPM.of THEN ArrayType(typ^.BaseTyp, banned) END ELSE err(35) END ; - IF typ^.BaseTyp^.comp = DynArr THEN typ^.BaseTyp := OPT.undftyp; err(88) END + IF typ^.BaseTyp^.comp = OPM.DynArr THEN typ^.BaseTyp := OPT.undftyp; err(88) END END END ArrayType; PROCEDURE PointerType(VAR typ: OPT.Struct); VAR id: OPT.Object; - BEGIN typ := OPT.NewStr(Pointer, Basic); CheckSysFlag(typ^.sysflag, 0); - CheckSym(to); - IF sym = ident THEN OPT.Find(id); + BEGIN typ := OPT.NewStr(OPM.Pointer, OPM.Basic); CheckSysFlag(typ^.sysflag, 0); + CheckSym(OPM.to); + IF sym = OPM.ident THEN OPT.Find(id); IF id = NIL THEN IF nofFwdPtr < LEN(FwdPtr) THEN FwdPtr[nofFwdPtr] := typ; INC(nofFwdPtr) ELSE err(224) @@ -242,8 +180,8 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) typ^.link := OPT.NewObj(); COPY(OPS.name, typ^.link^.name); typ^.BaseTyp := OPT.undftyp; OPS.Get(sym) (*forward ref*) ELSE qualident(id); - IF id^.mode = Typ THEN - IF id^.typ^.comp IN {Array, DynArr, Record} THEN + IF id^.mode = OPM.Typ THEN + IF id^.typ^.comp IN {OPM.Array, OPM.DynArr, OPM.Record} THEN typ^.BaseTyp := id^.typ ELSE typ^.BaseTyp := OPT.undftyp; err(57) END @@ -251,7 +189,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END END ELSE Type(typ^.BaseTyp, OPT.notyp); - IF ~(typ^.BaseTyp^.comp IN {Array, DynArr, Record}) THEN + IF ~(typ^.BaseTyp^.comp IN {OPM.Array, OPM.DynArr, OPM.Record}) THEN typ^.BaseTyp := OPT.undftyp; err(57) END END @@ -261,45 +199,45 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR mode: SHORTINT; par, first, last, res: OPT.Object; typ: OPT.Struct; BEGIN first := NIL; last := firstPar; - IF (sym = ident) OR (sym = var) THEN + IF (sym = OPM.ident) OR (sym = OPM.var) THEN LOOP - IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ; + IF sym = OPM.var THEN OPS.Get(sym); mode := OPM.VarPar ELSE mode := OPM.Var END ; LOOP - IF sym = ident THEN + IF sym = OPM.ident THEN OPT.Insert(OPS.name, par); OPS.Get(sym); par^.mode := mode; par^.link := NIL; IF first = NIL THEN first := par END ; IF firstPar = NIL THEN firstPar := par ELSE last^.link := par END ; last := par - ELSE err(ident) + ELSE err(OPM.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) - ELSIF sym = var THEN err(comma); OPS.Get(sym) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF sym = OPM.ident THEN err(OPM.comma) + ELSIF sym = OPM.var THEN err(OPM.comma); OPS.Get(sym) ELSE EXIT END END ; - CheckSym(colon); Type(typ, OPT.notyp); - IF mode = Var THEN typ^.pvused := TRUE END ; + CheckSym(OPM.colon); Type(typ, OPT.notyp); + IF mode = OPM.Var THEN typ^.pvused := TRUE END ; (* typ^.pbused is set when parameter type name is parsed *) WHILE first # NIL DO first^.typ := typ; first := first^.link END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF sym = ident THEN err(semicolon) + IF sym = OPM.semicolon THEN OPS.Get(sym) + ELSIF sym = OPM.ident THEN err(OPM.semicolon) ELSE EXIT END END END ; - CheckSym(rparen); - IF sym = colon THEN + CheckSym(OPM.rparen); + IF sym = OPM.colon THEN OPS.Get(sym); resTyp := OPT.undftyp; - IF sym = ident THEN qualident(res); - IF res^.mode = Typ THEN - IF (res^.typ^.form < Comp) (*OR (res^.typ^.form >= Int8) & (res^.typ^.form <= Int64)*) THEN resTyp := res^.typ; + IF sym = OPM.ident THEN qualident(res); + IF res^.mode = OPM.Typ THEN + IF (res^.typ^.form < OPM.Comp) (*OR (res^.typ^.form >= Int8) & (res^.typ^.form <= Int64)*) THEN resTyp := res^.typ; ELSE err(54) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPM.ident) END ELSE resTyp := OPT.notyp END @@ -308,24 +246,26 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE TypeDecl(VAR typ, banned: OPT.Struct); VAR id: OPT.Object; BEGIN typ := OPT.undftyp; - IF sym < lparen THEN err(12); - REPEAT OPS.Get(sym) UNTIL sym >= lparen + IF sym < OPM.lparen THEN err(12); + REPEAT OPS.Get(sym) UNTIL sym >= OPM.lparen END ; - IF sym = ident THEN qualident(id); - IF id^.mode = Typ THEN - IF id^.typ # banned THEN typ := id^.typ ELSE err(58) END + IF sym = OPM.ident THEN qualident(id); + IF id^.mode = OPM.Typ THEN + IF id^.typ = banned THEN err(58) ELSE + typ := id.typ + END ELSE err(52) END - ELSIF sym = array THEN + ELSIF sym = OPM.array THEN OPS.Get(sym); ArrayType(typ, banned) - ELSIF sym = record THEN + ELSIF sym = OPM.record THEN OPS.Get(sym); RecordType(typ, banned); - OPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end) - ELSIF sym = pointer THEN + OPB.Inittd(TDinit, lastTDinit, typ); CheckSym(OPM.end) + ELSIF sym = OPM.pointer THEN OPS.Get(sym); PointerType(typ) - ELSIF sym = procedure THEN - OPS.Get(sym); typ := OPT.NewStr(ProcTyp, Basic); CheckSysFlag(typ^.sysflag, 0); - IF sym = lparen THEN + ELSIF sym = OPM.procedure THEN + OPS.Get(sym); typ := OPT.NewStr(OPM.ProcTyp, OPM.Basic); CheckSysFlag(typ^.sysflag, 0); + IF sym = OPM.lparen THEN OPS.Get(sym); OPT.OpenScope(level, NIL); FormalParameters(typ^.link, typ^.BaseTyp); OPT.CloseScope ELSE typ^.BaseTyp := OPT.notyp; typ^.link := NIL @@ -333,69 +273,69 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) ELSE err(12) END ; LOOP - IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof) THEN EXIT END; - err(15); IF sym = ident THEN EXIT END; + IF (sym >= OPM.semicolon) & (sym <= OPM.else) OR (sym = OPM.rparen) OR (sym = OPM.eof) THEN EXIT END; + err(15); IF sym = OPM.ident THEN EXIT END; OPS.Get(sym) END END TypeDecl; PROCEDURE Type(VAR typ, banned: OPT.Struct); BEGIN TypeDecl(typ, banned); - IF (typ^.form = Pointer) & (typ^.BaseTyp = OPT.undftyp) & (typ^.strobj = NIL) THEN err(0) END + IF (typ^.form = OPM.Pointer) & (typ^.BaseTyp = OPT.undftyp) & (typ^.strobj = NIL) THEN err(0) END END Type; PROCEDURE selector(VAR x: OPT.Node); VAR obj, proc: OPT.Object; y: OPT.Node; typ: OPT.Struct; name: OPS.Name; BEGIN LOOP - IF sym = lbrak THEN OPS.Get(sym); + IF sym = OPM.lbrak THEN OPS.Get(sym); LOOP - IF (x^.typ # NIL) & (x^.typ^.form = Pointer) THEN OPB.DeRef(x) END ; + IF (x^.typ # NIL) & (x^.typ^.form = OPM.Pointer) THEN OPB.DeRef(x) END ; Expression(y); OPB.Index(x, y); - IF sym = comma THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPM.comma THEN OPS.Get(sym) ELSE EXIT END END ; - CheckSym(rbrak) - ELSIF sym = period THEN OPS.Get(sym); - IF sym = ident THEN name := OPS.name; OPS.Get(sym); + CheckSym(OPM.rbrak) + ELSIF sym = OPM.period THEN OPS.Get(sym); + IF sym = OPM.ident THEN name := OPS.name; OPS.Get(sym); IF x^.typ # NIL THEN - IF x^.typ^.form = Pointer THEN OPB.DeRef(x) END ; - IF x^.typ^.comp = Record THEN + IF x^.typ^.form = OPM.Pointer THEN OPB.DeRef(x) END ; + IF x^.typ^.comp = OPM.Record THEN OPT.FindField(name, x^.typ, obj); OPB.Field(x, obj); - IF (obj # NIL) & (obj^.mode = TProc) THEN - IF sym = arrow THEN (* super call *) OPS.Get(sym); + IF (obj # NIL) & (obj^.mode = OPM.TProc) THEN + IF sym = OPM.arrow THEN (* super call *) OPS.Get(sym); y := x^.left; - IF y^.class = Nderef THEN y := y^.left END ; (* y = record variable *) + IF y^.class = OPM.Nderef THEN y := y^.left END ; (* y = record variable *) IF y^.obj # NIL THEN - proc := OPT.topScope; (* find innermost scope which owner is a TProc *) - WHILE (proc^.link # NIL) & (proc^.link^.mode # TProc) DO proc := proc^.left END ; + proc := OPT.topScope; (* find innermost scope which owner is a OPM.TProc *) + WHILE (proc^.link # NIL) & (proc^.link^.mode # OPM.TProc) DO proc := proc^.left END ; IF (proc^.link = NIL) OR (proc^.link^.link # y^.obj) THEN err(75) END ; typ := y^.obj^.typ; - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.form = OPM.Pointer THEN typ := typ^.BaseTyp END ; OPT.FindField(x^.obj^.name, typ^.BaseTyp, proc); - IF proc # NIL THEN x^.subcl := super ELSE err(74) END + IF proc # NIL THEN x^.subcl := OPM.super ELSE err(74) END ELSE err(75) END END ; - IF (obj^.typ # OPT.notyp) & (sym # lparen) THEN err(lparen) END + IF (obj^.typ # OPT.notyp) & (sym # OPM.lparen) THEN err(OPM.lparen) END END ELSE err(53) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPM.ident) END - ELSIF sym = arrow THEN OPS.Get(sym); OPB.DeRef(x) - ELSIF (sym = lparen) & (x^.class < Nconst) & (x^.typ^.form # ProcTyp) & - ((x^.obj = NIL) OR (x^.obj^.mode # TProc)) THEN + ELSIF sym = OPM.arrow THEN OPS.Get(sym); OPB.DeRef(x) + ELSIF (sym = OPM.lparen) & (x^.class < OPM.Nconst) & (x^.typ^.form # OPM.ProcTyp) & + ((x^.obj = NIL) OR (x^.obj^.mode # OPM.TProc)) THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPM.ident THEN qualident(obj); - IF obj^.mode = Typ THEN OPB.TypTest(x, obj, TRUE) + IF obj^.mode = OPM.Typ THEN OPB.TypTest(x, obj, TRUE) ELSE err(52) END - ELSE err(ident) + ELSE err(OPM.ident) END ; - CheckSym(rparen) + CheckSym(OPM.rparen) ELSE EXIT END END @@ -404,15 +344,15 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ActualParameters(VAR aparlist: OPT.Node; fpar: OPT.Object); VAR apar, last: OPT.Node; BEGIN aparlist := NIL; last := NIL; - IF sym # rparen THEN + IF sym # OPM.rparen THEN LOOP Expression(apar); IF fpar # NIL THEN OPB.Param(apar, fpar); OPB.Link(aparlist, last, apar); fpar := fpar^.link; ELSE err(64) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF (OPM.lparen <= sym) & (sym <= OPM.ident) THEN err(OPM.comma) ELSE EXIT END END @@ -423,31 +363,31 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE StandProcCall(VAR x: OPT.Node); VAR y: OPT.Node; m: SHORTINT; n: INTEGER; BEGIN m := SHORT(SHORT(x^.obj^.adr)); n := 0; - IF sym = lparen THEN OPS.Get(sym); - IF sym # rparen THEN + IF sym = OPM.lparen THEN OPS.Get(sym); + IF sym # OPM.rparen THEN LOOP IF n = 0 THEN Expression(x); OPB.StPar0(x, m); n := 1 ELSIF n = 1 THEN Expression(y); OPB.StPar1(x, y, m); n := 2 ELSE Expression(y); OPB.StParN(x, y, m, n); INC(n) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF (OPM.lparen <= sym) & (sym <= OPM.ident) THEN err(OPM.comma) ELSE EXIT END END ; - CheckSym(rparen) + CheckSym(OPM.rparen) ELSE OPS.Get(sym) END ; OPB.StFct(x, m, n) - ELSE err(lparen) + ELSE err(OPM.lparen) END ; - IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END + IF (level > 0) & ((m = OPM.newfn) OR (m = OPM.sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END END StandProcCall; PROCEDURE Element(VAR x: OPT.Node); VAR y: OPT.Node; BEGIN Expression(x); - IF sym = upto THEN + IF sym = OPM.upto THEN OPS.Get(sym); Expression(y); OPB.SetRange(x, y) ELSE OPB.SetElem(x) END @@ -456,57 +396,57 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Sets(VAR x: OPT.Node); VAR y: OPT.Node; BEGIN - IF sym # rbrace THEN + IF sym # OPM.rbrace THEN Element(x); LOOP - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF (OPM.lparen <= sym) & (sym <= OPM.ident) THEN err(OPM.comma) ELSE EXIT END ; - Element(y); OPB.Op(plus, x, y) + Element(y); OPB.Op(OPM.plus, x, y) END ELSE x := OPB.EmptySet() END ; - CheckSym(rbrace) + CheckSym(OPM.rbrace) END Sets; PROCEDURE Factor(VAR x: OPT.Node); VAR fpar, id: OPT.Object; apar: OPT.Node; BEGIN - IF sym < lparen THEN err(13); - REPEAT OPS.Get(sym) UNTIL sym >= lparen + IF sym < OPM.lparen THEN err(13); + REPEAT OPS.Get(sym) UNTIL sym >= OPM.lparen END ; - IF sym = ident THEN + IF sym = OPM.ident THEN qualident(id); x := OPB.NewLeaf(id); selector(x); - IF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN StandProcCall(x) (* x may be NIL *) - ELSIF sym = lparen THEN + IF (x^.class = OPM.Nproc) & (x^.obj^.mode = OPM.SProc) THEN StandProcCall(x) (* x may be NIL *) + ELSIF sym = OPM.lparen THEN OPS.Get(sym); OPB.PrepCall(x, fpar); ActualParameters(apar, fpar); OPB.Call(x, apar, fpar); - CheckSym(rparen); + CheckSym(OPM.rparen); IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END END - ELSIF sym = number THEN + ELSIF sym = OPM.number THEN CASE OPS.numtyp OF - char: x := OPB.NewIntConst(OPS.intval); x^.typ := OPT.chartyp - | integer: x := OPB.NewIntConst(OPS.intval) - | real: x := OPB.NewRealConst(OPS.realval, OPT.realtyp) - | longreal: x := OPB.NewRealConst(OPS.lrlval, OPT.lrltyp) + | OPM.char: x := OPB.NewIntConst(OPS.intval); x^.typ := OPT.chartyp + | OPM.integer: x := OPB.NewIntConst(OPS.intval) + | OPM.real: x := OPB.NewRealConst(OPS.realval, OPT.realtyp) + | OPM.longreal: x := OPB.NewRealConst(OPS.lrlval, OPT.lrltyp) ELSE OPM.LogWStr("unhandled case in OPP.Factor, OPS.numtyp = "); OPM.LogWNum(OPS.numtyp, 0); OPM.LogWLn; END ; OPS.Get(sym) - ELSIF sym = string THEN + ELSIF sym = OPM.string THEN x := OPB.NewString(OPS.str, OPS.intval); OPS.Get(sym) - ELSIF sym = nil THEN + ELSIF sym = OPM.nil THEN x := OPB.Nil(); OPS.Get(sym) - ELSIF sym = lparen THEN - OPS.Get(sym); Expression(x); CheckSym(rparen) - ELSIF sym = lbrak THEN - OPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen) - ELSIF sym = lbrace THEN OPS.Get(sym); Sets(x) - ELSIF sym = not THEN - OPS.Get(sym); Factor(x); OPB.MOp(not, x) + ELSIF sym = OPM.lparen THEN + OPS.Get(sym); Expression(x); CheckSym(OPM.rparen) + ELSIF sym = OPM.lbrak THEN + OPS.Get(sym); err(OPM.lparen); Expression(x); CheckSym(OPM.rparen) + ELSIF sym = OPM.lbrace THEN OPS.Get(sym); Sets(x) + ELSIF sym = OPM.not THEN + OPS.Get(sym); Factor(x); OPB.MOp(OPM.not, x) ELSE err(13); OPS.Get(sym); x := NIL END ; IF x = NIL THEN x := OPB.NewIntConst(1); x^.typ := OPT.undftyp END @@ -515,7 +455,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Term(VAR x: OPT.Node); VAR y: OPT.Node; mulop: SHORTINT; BEGIN Factor(x); - WHILE (times <= sym) & (sym <= and) DO + WHILE (OPM.times <= sym) & (sym <= OPM.and) DO mulop := sym; OPS.Get(sym); Factor(y); OPB.Op(mulop, x, y) END @@ -524,11 +464,11 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE SimpleExpression(VAR x: OPT.Node); VAR y: OPT.Node; addop: SHORTINT; BEGIN - IF sym = minus THEN OPS.Get(sym); Term(x); OPB.MOp(minus, x) - ELSIF sym = plus THEN OPS.Get(sym); Term(x); OPB.MOp(plus, x) + IF sym = OPM.minus THEN OPS.Get(sym); Term(x); OPB.MOp(OPM.minus, x) + ELSIF sym = OPM.plus THEN OPS.Get(sym); Term(x); OPB.MOp(OPM.plus, x) ELSE Term(x) END ; - WHILE (plus <= sym) & (sym <= or) DO + WHILE (OPM.plus <= sym) & (sym <= OPM.or) DO addop := sym; OPS.Get(sym); Term(y); OPB.Op(addop, x, y) END @@ -537,19 +477,19 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Expression(VAR x: OPT.Node); VAR y: OPT.Node; obj: OPT.Object; relation: SHORTINT; BEGIN SimpleExpression(x); - IF (eql <= sym) & (sym <= geq) THEN + IF (OPM.eql <= sym) & (sym <= OPM.geq) THEN relation := sym; OPS.Get(sym); SimpleExpression(y); OPB.Op(relation, x, y) - ELSIF sym = in THEN + ELSIF sym = OPM.in THEN OPS.Get(sym); SimpleExpression(y); OPB.In(x, y) - ELSIF sym = is THEN + ELSIF sym = OPM.is THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPM.ident THEN qualident(obj); - IF obj^.mode = Typ THEN OPB.TypTest(x, obj, FALSE) + IF obj^.mode = OPM.Typ THEN OPB.TypTest(x, obj, FALSE) ELSE err(52) END - ELSE err(ident) + ELSE err(OPM.ident) END END END Expression; @@ -557,27 +497,27 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Receiver(VAR mode: SHORTINT; VAR name: OPS.Name; VAR typ, rec: OPT.Struct); VAR obj: OPT.Object; BEGIN typ := OPT.undftyp; rec := NIL; - IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ; - name := OPS.name; CheckSym(ident); CheckSym(colon); - IF sym = ident THEN OPT.Find(obj); OPS.Get(sym); + IF sym = OPM.var THEN OPS.Get(sym); mode := OPM.VarPar ELSE mode := OPM.Var END ; + name := OPS.name; CheckSym(OPM.ident); CheckSym(OPM.colon); + IF sym = OPM.ident THEN OPT.Find(obj); OPS.Get(sym); IF obj = NIL THEN err(0) - ELSIF obj^.mode # Typ THEN err(72) + ELSIF obj^.mode # OPM.Typ THEN err(72) ELSE typ := obj^.typ; rec := typ; - IF rec^.form = Pointer THEN rec := rec^.BaseTyp END ; - IF ~((mode = Var) & (typ^.form = Pointer) & (rec^.comp = Record) OR - (mode = VarPar) & (typ^.comp = Record)) THEN err(70); rec := NIL END ; + IF rec^.form = OPM.Pointer THEN rec := rec^.BaseTyp END ; + IF ~((mode = OPM.Var) & (typ^.form = OPM.Pointer) & (rec^.comp = OPM.Record) OR + (mode = OPM.VarPar) & (typ^.comp = OPM.Record)) THEN err(70); rec := NIL END ; IF (rec # NIL) & (rec^.mno # level) THEN err(72); rec := NIL END END - ELSE err(ident) + ELSE err(OPM.ident) END ; - CheckSym(rparen); - IF rec = NIL THEN rec := OPT.NewStr(Comp, Record); rec^.BaseTyp := NIL END + CheckSym(OPM.rparen); + IF rec = NIL THEN rec := OPT.NewStr(OPM.Comp, OPM.Record); rec^.BaseTyp := NIL END END Receiver; PROCEDURE Extends(x, b: OPT.Struct): BOOLEAN; BEGIN - IF (b^.form = Pointer) & (x^.form = Pointer) THEN b := b^.BaseTyp; x := x^.BaseTyp END ; - IF (b^.comp = Record) & (x^.comp = Record) THEN + IF (b^.form = OPM.Pointer) & (x^.form = OPM.Pointer) THEN b := b^.BaseTyp; x := x^.BaseTyp END ; + IF (b^.comp = OPM.Record) & (x^.comp = OPM.Record) THEN REPEAT x := x^.BaseTyp UNTIL (x = NIL) OR (x = b) END ; RETURN x = b @@ -593,7 +533,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR ext: OPT.ConstExt; n: INTEGER; c: LONGINT; BEGIN ext := OPT.NewExt(); proc^.conval^.ext := ext; n := 0; - IF sym = string THEN + IF sym = OPM.string THEN WHILE OPS.str[n] # 0X DO ext[n+1] := OPS.str[n]; INC(n) END ; ext^[0] := CHR(n); OPS.Get(sym); (* @@ -602,33 +542,33 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) *) ELSE LOOP - IF sym = number THEN c := OPS.intval; INC(n); + IF sym = OPM.number THEN c := OPS.intval; INC(n); IF (c < 0) OR (c > 255) OR (n = OPT.MaxConstLen) THEN err(64); c := 1; n := 1 END ; OPS.Get(sym); ext^[n] := CHR(c) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = number THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF sym = OPM.number THEN err(OPM.comma) ELSE ext^[0] := CHR(n); EXIT END END END ; - INCL(proc^.conval^.setval, hasBody) + INCL(proc^.conval^.setval, OPM.hasBody) END GetCode; PROCEDURE GetParams; BEGIN proc^.vis := vis; proc^.mode := mode; proc^.typ := OPT.notyp; proc^.conval := OPT.NewConst(); proc^.conval^.setval := {}; - IF sym = lparen THEN + IF sym = OPM.lparen THEN OPS.Get(sym); FormalParameters(proc^.link, proc^.typ) END ; IF fwd # NIL THEN OPB.CheckParameters(proc^.link, fwd^.link, TRUE); IF proc^.typ # fwd^.typ THEN err(117) END ; proc := fwd; OPT.topScope := proc^.scope; - IF mode = IProc THEN proc^.mode := IProc END + IF mode = OPM.IProc THEN proc^.mode := OPM.IProc END END END GetParams; @@ -636,14 +576,14 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR procdec, statseq: OPT.Node; c: LONGINT; BEGIN c := OPM.errpos; - INCL(proc^.conval^.setval, hasBody); - CheckSym(semicolon); Block(procdec, statseq); + INCL(proc^.conval^.setval, OPM.hasBody); + CheckSym(OPM.semicolon); Block(procdec, statseq); OPB.Enter(procdec, statseq, proc); x := procdec; x^.conval := OPT.NewConst(); x^.conval^.intval := c; - IF sym = ident THEN + IF sym = OPM.ident THEN IF OPS.name # proc^.name THEN err(4) END ; OPS.Get(sym) - ELSE err(ident) + ELSE err(OPM.ident) END END Body; @@ -653,17 +593,17 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) objMode: SHORTINT; objName: OPS.Name; BEGIN - OPS.Get(sym); mode := TProc; + OPS.Get(sym); mode := OPM.TProc; IF level > 0 THEN err(73) END ; Receiver(objMode, objName, objTyp, recTyp); - IF sym = ident THEN + IF sym = OPM.ident THEN name := OPS.name; CheckMark(vis); OPT.FindField(name, recTyp, fwd); OPT.FindField(name, recTyp^.BaseTyp, baseProc); - IF (baseProc # NIL) & (baseProc^.mode # TProc) THEN baseProc := NIL END ; + IF (baseProc # NIL) & (baseProc^.mode # OPM.TProc) THEN baseProc := NIL END ; IF fwd = baseProc THEN fwd := NIL END ; IF (fwd # NIL) & (fwd^.mnolev # level) THEN fwd := NIL END ; - IF (fwd # NIL) & (fwd^.mode = TProc) & ~(hasBody IN fwd^.conval^.setval) THEN + IF (fwd # NIL) & (fwd^.mode = OPM.TProc) & ~(OPM.hasBody IN fwd^.conval^.setval) THEN (* there exists a corresponding forward declaration *) proc := OPT.NewObj(); proc^.leaf := TRUE; IF fwd^.vis # vis THEN err(118) END @@ -679,34 +619,34 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF (objMode # baseProc^.link^.mode) OR ~Extends(objTyp, baseProc^.link^.typ) THEN err(115) END ; OPB.CheckParameters(proc^.link^.link, baseProc^.link^.link, FALSE); IF proc^.typ # baseProc^.typ THEN err(117) END ; - IF (baseProc^.vis = external) & (proc^.vis = internal) & - (recTyp^.strobj # NIL) & (recTyp^.strobj^.vis = external) THEN err(109) + IF (baseProc^.vis = OPM.external) & (proc^.vis = OPM.internal) & + (recTyp^.strobj # NIL) & (recTyp^.strobj^.vis = OPM.external) THEN err(109) END ; - INCL(proc^.conval^.setval, isRedef) + INCL(proc^.conval^.setval, OPM.isRedef) END ; IF ~forward THEN Body END ; DEC(level); OPT.CloseScope - ELSE err(ident) + ELSE err(OPM.ident) END END TProcDecl; - BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; - IF (sym # ident) & (sym # lparen) THEN - IF sym = times THEN (* mode set later in OPB.CheckAssign *) - ELSIF sym = arrow THEN forward := TRUE - ELSIF sym = plus THEN mode := IProc - ELSIF sym = minus THEN mode := CProc - ELSE err(ident) + BEGIN proc := NIL; forward := FALSE; x := NIL; mode := OPM.LProc; + IF (sym # OPM.ident) & (sym # OPM.lparen) THEN + IF sym = OPM.times THEN (* mode set later in OPB.CheckAssign *) + ELSIF sym = OPM.arrow THEN forward := TRUE + ELSIF sym = OPM.plus THEN mode := OPM.IProc + ELSIF sym = OPM.minus THEN mode := OPM.CProc + ELSE err(OPM.ident) END ; - IF (mode IN {IProc, CProc}) & ~OPT.SYSimported THEN err(135) END ; + IF (mode IN {OPM.IProc, OPM.CProc}) & ~OPT.SYSimported THEN err(135) END ; OPS.Get(sym) END ; - IF sym = lparen THEN TProcDecl - ELSIF sym = ident THEN OPT.Find(fwd); + IF sym = OPM.lparen THEN TProcDecl + ELSIF sym = OPM.ident THEN OPT.Find(fwd); name := OPS.name; CheckMark(vis); - IF (vis # internal) & (mode = LProc) THEN mode := XProc END ; - IF (fwd # NIL) & ((fwd^.mnolev # level) OR (fwd^.mode = SProc)) THEN fwd := NIL END ; - IF (fwd # NIL) & (fwd^.mode IN {LProc, XProc}) & ~(hasBody IN fwd^.conval^.setval) THEN + IF (vis # OPM.internal) & (mode = OPM.LProc) THEN mode := OPM.XProc END ; + IF (fwd # NIL) & ((fwd^.mnolev # level) OR (fwd^.mode = OPM.SProc)) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd^.mode IN {OPM.LProc, OPM.XProc}) & ~(OPM.hasBody IN fwd^.conval^.setval) THEN (* there exists a corresponding forward declaration *) proc := OPT.NewObj(); proc^.leaf := TRUE; IF fwd^.vis # vis THEN err(118) END @@ -714,14 +654,14 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF fwd # NIL THEN err(1); fwd := NIL END ; OPT.Insert(name, proc) END ; - IF (mode # LProc) & (level > 0) THEN err(73) END ; + IF (mode # OPM.LProc) & (level > 0) THEN err(73) END ; INC(level); OPT.OpenScope(level, proc); proc^.link := NIL; GetParams; - IF mode = CProc THEN GetCode + IF mode = OPM.CProc THEN GetCode ELSIF ~forward THEN Body END ; DEC(level); OPT.CloseScope - ELSE err(ident) + ELSE err(OPM.ident) END END ProcedureDeclaration; @@ -729,16 +669,16 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR x, y, lastlab: OPT.Node; i, f: INTEGER; xval, yval: LONGINT; BEGIN lab := NIL; lastlab := NIL; LOOP ConstExpression(x); f := x^.typ^.form; - IF f IN intSet + {Char} THEN xval := x^.conval^.intval + IF f IN OPM.intSet + {OPM.Char} THEN xval := x^.conval^.intval ELSE err(61); xval := 1 END ; - IF f IN intSet THEN + IF f IN OPM.intSet THEN IF LabelForm < f THEN err(60) END ELSIF LabelForm # f THEN err(60) END ; - IF sym = upto THEN + IF sym = OPM.upto THEN OPS.Get(sym); ConstExpression(y); yval := y^.conval^.intval; - IF (y^.typ^.form # f) & ~((f IN intSet) & (y^.typ^.form IN intSet)) THEN err(60) END ; + IF (y^.typ^.form # f) & ~((f IN OPM.intSet) & (y^.typ^.form IN OPM.intSet)) THEN err(60) END ; IF yval < xval THEN err(63); yval := xval END ELSE yval := xval END ; @@ -757,8 +697,8 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) ELSE err(213) END ; OPB.Link(lab, lastlab, x); - IF sym = comma THEN OPS.Get(sym) - ELSIF (sym = number) OR (sym = ident) THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF (sym = OPM.number) OR (sym = OPM.ident) THEN err(OPM.comma) ELSE EXIT END END @@ -773,29 +713,29 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) tab: CaseTable; cases, lab, y, lastcase: OPT.Node; BEGIN Expression(x); pos := OPM.errpos; - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(x^.typ^.form IN {Char..LInt}) THEN err(125) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126) + ELSIF ~(x^.typ^.form IN {OPM.Char..OPM.LInt}) THEN err(125) END ; - CheckSym(of); cases := NIL; lastcase := NIL; n := 0; + CheckSym(OPM.of); cases := NIL; lastcase := NIL; n := 0; LOOP - IF sym < bar THEN + IF sym < OPM.bar THEN CaseLabelList(lab, x^.typ^.form, n, tab); - CheckSym(colon); StatSeq(y); - OPB.Construct(Ncasedo, lab, y); OPB.Link(cases, lastcase, lab) + CheckSym(OPM.colon); StatSeq(y); + OPB.Construct(OPM.Ncasedo, lab, y); OPB.Link(cases, lastcase, lab) END ; - IF sym = bar THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPM.bar THEN OPS.Get(sym) ELSE EXIT END END ; IF n > 0 THEN low := tab[0].low; high := tab[n-1].high; IF high - low > OPM.MaxCaseRange THEN err(209) END ELSE low := 1; high := 0 END ; - e := sym = else; + e := sym = OPM.else; IF e THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL; - OPM.Mark(-307, OPM.curpos); (* notice about no else symbol; -- noch *) + OPM.Mark(-307, OPM.curpos); (* notice about no OPM.else symbol; -- noch *) END ; - OPB.Construct(Ncaselse, cases, y); OPB.Construct(Ncase, x, cases); + OPB.Construct(OPM.Ncaselse, cases, y); OPB.Construct(OPM.Ncase, x, cases); cases^.conval := OPT.NewConst(); cases^.conval^.intval := low; cases^.conval^.intval2 := high; IF e THEN cases^.conval^.setval := {1} ELSE cases^.conval^.setval := {} END @@ -808,29 +748,29 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE CheckBool(VAR x: OPT.Node); BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := OPB.NewBoolConst(FALSE) - ELSIF x^.typ^.form # Bool THEN err(120); x := OPB.NewBoolConst(FALSE) + IF (x^.class = OPM.Ntype) OR (x^.class = OPM.Nproc) THEN err(126); x := OPB.NewBoolConst(FALSE) + ELSIF x^.typ^.form # OPM.Bool THEN err(120); x := OPB.NewBoolConst(FALSE) END ; pos := OPM.errpos END CheckBool; BEGIN stat := NIL; last := NIL; LOOP x := NIL; - IF sym < ident THEN err(14); - REPEAT OPS.Get(sym) UNTIL sym >= ident + IF sym < OPM.ident THEN err(14); + REPEAT OPS.Get(sym) UNTIL sym >= OPM.ident END ; - IF sym = ident THEN + IF sym = OPM.ident THEN qualident(id); x := OPB.NewLeaf(id); selector(x); - IF sym = becomes THEN + IF sym = OPM.becomes THEN OPS.Get(sym); Expression(y); OPB.Assign(x, y) - ELSIF sym = eql THEN - err(becomes); OPS.Get(sym); Expression(y); OPB.Assign(x, y) - ELSIF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN + ELSIF sym = OPM.eql THEN + err(OPM.becomes); OPS.Get(sym); Expression(y); OPB.Assign(x, y) + ELSIF (x^.class = OPM.Nproc) & (x^.obj^.mode = OPM.SProc) THEN StandProcCall(x); IF (x # NIL) & (x^.typ # OPT.notyp) THEN err(55) END ELSE OPB.PrepCall(x, fpar); - IF sym = lparen THEN - OPS.Get(sym); ActualParameters(apar, fpar); CheckSym(rparen) + IF sym = OPM.lparen THEN + OPS.Get(sym); ActualParameters(apar, fpar); CheckSym(OPM.rparen) ELSE apar := NIL; IF fpar # NIL THEN err(65) END END ; @@ -839,36 +779,36 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END END ; pos := OPM.errpos - ELSIF sym = if THEN - OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(then); StatSeq(y); - OPB.Construct(Nif, x, y); SetPos(x); lastif := x; - WHILE sym = elsif DO - OPS.Get(sym); Expression(y); CheckBool(y); CheckSym(then); StatSeq(z); - OPB.Construct(Nif, y, z); SetPos(y); OPB.Link(x, lastif, y) + ELSIF sym = OPM.if THEN + OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(OPM.then); StatSeq(y); + OPB.Construct(OPM.Nif, x, y); SetPos(x); lastif := x; + WHILE sym = OPM.elsif DO + OPS.Get(sym); Expression(y); CheckBool(y); CheckSym(OPM.then); StatSeq(z); + OPB.Construct(OPM.Nif, y, z); SetPos(y); OPB.Link(x, lastif, y) END ; - IF sym = else THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL END ; - OPB.Construct(Nifelse, x, y); CheckSym(end); OPB.OptIf(x); pos := OPM.errpos - ELSIF sym = case THEN - OPS.Get(sym); CasePart(x); CheckSym(end) - ELSIF sym = while THEN - OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(do); StatSeq(y); - OPB.Construct(Nwhile, x, y); CheckSym(end) - ELSIF sym = repeat THEN + IF sym = OPM.else THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + OPB.Construct(OPM.Nifelse, x, y); CheckSym(OPM.end); OPB.OptIf(x); pos := OPM.errpos + ELSIF sym = OPM.case THEN + OPS.Get(sym); CasePart(x); CheckSym(OPM.end) + ELSIF sym = OPM.while THEN + OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(OPM.do); StatSeq(y); + OPB.Construct(OPM.Nwhile, x, y); CheckSym(OPM.end) + ELSIF sym = OPM.repeat THEN OPS.Get(sym); StatSeq(x); - IF sym = until THEN OPS.Get(sym); Expression(y); CheckBool(y) - ELSE err(until) + IF sym = OPM.until THEN OPS.Get(sym); Expression(y); CheckBool(y) + ELSE err(OPM.until) END ; - OPB.Construct(Nrepeat, x, y) - ELSIF sym = for THEN + OPB.Construct(OPM.Nrepeat, x, y) + ELSIF sym = OPM.for THEN OPS.Get(sym); - IF sym = ident THEN qualident(id); - IF ~(id^.typ^.form IN intSet) THEN err(68) END ; - CheckSym(becomes); Expression(y); pos := OPM.errpos; + IF sym = OPM.ident THEN qualident(id); + IF ~(id^.typ^.form IN OPM.intSet) THEN err(68) END ; + CheckSym(OPM.becomes); Expression(y); pos := OPM.errpos; x := OPB.NewLeaf(id); OPB.Assign(x, y); SetPos(x); - CheckSym(to); Expression(y); pos := OPM.errpos; - IF y^.class # Nconst THEN + CheckSym(OPM.to); Expression(y); pos := OPM.errpos; + IF y^.class # OPM.Nconst THEN name := "@@"; OPT.Insert(name, t); t^.name := "@for"; (* avoid err 1 *) - t^.mode := Var; t^.typ := x^.left^.typ; + t^.mode := OPM.Var; t^.typ := x^.left^.typ; obj := OPT.topScope^.scope; IF obj = NIL THEN OPT.topScope^.scope := t ELSE @@ -877,73 +817,73 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END ; z := OPB.NewLeaf(t); OPB.Assign(z, y); SetPos(z); OPB.Link(stat, last, z); y := OPB.NewLeaf(t) - ELSIF (y^.typ^.form < SInt) OR (y^.typ^.form > x^.left^.typ^.form) THEN err(113) + ELSIF (y^.typ^.form < OPM.SInt) OR (y^.typ^.form > x^.left^.typ^.form) THEN err(113) END ; OPB.Link(stat, last, x); - IF sym = by THEN OPS.Get(sym); ConstExpression(z) ELSE z := OPB.NewIntConst(1) END ; + IF sym = OPM.by THEN OPS.Get(sym); ConstExpression(z) ELSE z := OPB.NewIntConst(1) END ; pos := OPM.errpos; x := OPB.NewLeaf(id); - IF z^.conval^.intval > 0 THEN OPB.Op(leq, x, y) - ELSIF z^.conval^.intval < 0 THEN OPB.Op(geq, x, y) - ELSE err(63); OPB.Op(geq, x, y) + IF z^.conval^.intval > 0 THEN OPB.Op(OPM.leq, x, y) + ELSIF z^.conval^.intval < 0 THEN OPB.Op(OPM.geq, x, y) + ELSE err(63); OPB.Op(OPM.geq, x, y) END ; - CheckSym(do); StatSeq(s); - y := OPB.NewLeaf(id); OPB.StPar1(y, z, incfn); SetPos(y); + CheckSym(OPM.do); StatSeq(s); + y := OPB.NewLeaf(id); OPB.StPar1(y, z, OPM.incfn); SetPos(y); IF s = NIL THEN s := y ELSE z := s; WHILE z^.link # NIL DO z := z^.link END ; z^.link := y END ; - CheckSym(end); OPB.Construct(Nwhile, x, s) - ELSE err(ident) + CheckSym(OPM.end); OPB.Construct(OPM.Nwhile, x, s) + ELSE err(OPM.ident) END - ELSIF sym = loop THEN + ELSIF sym = OPM.loop THEN OPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel); - OPB.Construct(Nloop, x, NIL); CheckSym(end); pos := OPM.errpos - ELSIF sym = with THEN + OPB.Construct(OPM.Nloop, x, NIL); CheckSym(OPM.end); pos := OPM.errpos + ELSIF sym = OPM.with THEN OPS.Get(sym); idtyp := NIL; x := NIL; LOOP - IF sym = ident THEN + IF sym = OPM.ident THEN qualident(id); y := OPB.NewLeaf(id); - IF (id # NIL) & (id^.typ^.form = Pointer) & ((id^.mode = VarPar) OR ~id^.leaf) THEN + IF (id # NIL) & (id^.typ^.form = OPM.Pointer) & ((id^.mode = OPM.VarPar) OR ~id^.leaf) THEN err(245) (* jt: do not allow WITH on non-local pointers *) END ; - CheckSym(colon); - IF sym = ident THEN qualident(t); - IF t^.mode = Typ THEN + CheckSym(OPM.colon); + IF sym = OPM.ident THEN qualident(t); + IF t^.mode = OPM.Typ THEN IF id # NIL THEN idtyp := id^.typ; OPB.TypTest(y, t, FALSE); id^.typ := t^.typ ELSE err(130) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPM.ident) END - ELSE err(ident) + ELSE err(OPM.ident) END ; - pos := OPM.errpos; CheckSym(do); StatSeq(s); OPB.Construct(Nif, y, s); SetPos(y); + pos := OPM.errpos; CheckSym(OPM.do); StatSeq(s); OPB.Construct(OPM.Nif, y, s); SetPos(y); IF idtyp # NIL THEN id^.typ := idtyp; idtyp := NIL END ; IF x = NIL THEN x := y; lastif := x ELSE OPB.Link(x, lastif, y) END ; - IF sym = bar THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPM.bar THEN OPS.Get(sym) ELSE EXIT END END; - e := sym = else; + e := sym = OPM.else; IF e THEN OPS.Get(sym); StatSeq(s) ELSE s := NIL END ; - OPB.Construct(Nwith, x, s); CheckSym(end); + OPB.Construct(OPM.Nwith, x, s); CheckSym(OPM.end); IF e THEN x^.subcl := 1 END - ELSIF sym = exit THEN + ELSIF sym = OPM.exit THEN OPS.Get(sym); IF LoopLevel = 0 THEN err(46) END ; - OPB.Construct(Nexit, x, NIL); + OPB.Construct(OPM.Nexit, x, NIL); pos := OPM.errpos - ELSIF sym = return THEN OPS.Get(sym); - IF sym < semicolon THEN Expression(x) END ; + ELSIF sym = OPM.return THEN OPS.Get(sym); + IF sym < OPM.semicolon THEN Expression(x) END ; IF level > 0 THEN OPB.Return(x, OPT.topScope^.link) ELSE (* not standard Oberon *) OPB.Return(x, NIL) END ; pos := OPM.errpos END ; IF x # NIL THEN SetPos(x); OPB.Link(stat, last, x) END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon) + IF sym = OPM.semicolon THEN OPS.Get(sym) + ELSIF (sym <= OPM.ident) OR (OPM.if <= sym) & (sym <= OPM.return) THEN err(OPM.semicolon) ELSE EXIT END END @@ -957,67 +897,67 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) BEGIN first := NIL; last := NIL; nofFwdPtr := 0; LOOP - IF sym = const THEN + IF sym = OPM.const THEN OPS.Get(sym); - WHILE sym = ident DO + WHILE sym = OPM.ident DO OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); - obj^.typ := OPT.sinttyp; obj^.mode := Var; (* Var to avoid recursive definition *) - IF sym = eql THEN + obj^.typ := OPT.sinttyp; obj^.mode := OPM.Var; (* OPM.Var to avoid recursive definition *) + IF sym = OPM.eql THEN OPS.Get(sym); ConstExpression(x) - ELSIF sym = becomes THEN - err(eql); OPS.Get(sym); ConstExpression(x) - ELSE err(eql); x := OPB.NewIntConst(1) + ELSIF sym = OPM.becomes THEN + err(OPM.eql); OPS.Get(sym); ConstExpression(x) + ELSE err(OPM.eql); x := OPB.NewIntConst(1) END ; - obj^.mode := Con; obj^.typ := x^.typ; obj^.conval := x^.conval; (* ConstDesc ist not copied *) - CheckSym(semicolon) + obj^.mode := OPM.Con; obj^.typ := x^.typ; obj^.conval := x^.conval; (* ConstDesc ist not copied *) + CheckSym(OPM.semicolon) END END ; - IF sym = type THEN + IF sym = OPM.type THEN OPS.Get(sym); - WHILE sym = ident DO - OPT.Insert(OPS.name, obj); obj^.mode := Typ; obj^.typ := OPT.undftyp; + WHILE sym = OPM.ident DO + OPT.Insert(OPS.name, obj); obj^.mode := OPM.Typ; obj^.typ := OPT.undftyp; CheckMark(obj^.vis); - IF sym = eql THEN + IF sym = OPM.eql THEN OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) - ELSIF (sym = becomes) OR (sym = colon) THEN - err(eql); OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) - ELSE err(eql) + ELSIF (sym = OPM.becomes) OR (sym = OPM.colon) THEN + err(OPM.eql); OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) + ELSE err(OPM.eql) END ; IF obj^.typ^.strobj = NIL THEN obj^.typ^.strobj := obj END ; - IF obj^.typ^.comp IN {Record, Array, DynArr} THEN + IF obj^.typ^.comp IN {OPM.Record, OPM.Array, OPM.DynArr} THEN i := 0; WHILE i < nofFwdPtr DO typ := FwdPtr[i]; INC(i); IF typ^.link^.name = obj^.name THEN typ^.BaseTyp := obj^.typ; typ^.link^.name := "" END END END ; - CheckSym(semicolon) + CheckSym(OPM.semicolon) END END ; - IF sym = var THEN + IF sym = OPM.var THEN OPS.Get(sym); - WHILE sym = ident DO + WHILE sym = OPM.ident DO LOOP - IF sym = ident THEN + IF sym = OPM.ident THEN OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); - obj^.mode := Var; obj^.link := NIL; obj^.leaf := obj^.vis = internal; obj^.typ := OPT.undftyp; + obj^.mode := OPM.Var; obj^.link := NIL; obj^.leaf := obj^.vis = OPM.internal; obj^.typ := OPT.undftyp; IF first = NIL THEN first := obj END ; IF last = NIL THEN OPT.topScope^.scope := obj ELSE last^.link := obj END ; last := obj - ELSE err(ident) + ELSE err(OPM.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF sym = OPM.ident THEN err(OPM.comma) ELSE EXIT END END ; - CheckSym(colon); Type(typ, OPT.notyp); + CheckSym(OPM.colon); Type(typ, OPT.notyp); typ^.pvused := TRUE; - IF typ^.comp = DynArr THEN typ := OPT.undftyp; err(88) END ; + IF typ^.comp = OPM.DynArr THEN typ := OPT.undftyp; err(88) END ; WHILE first # NIL DO first^.typ := typ; first := first^.link END ; - CheckSym(semicolon) + CheckSym(OPM.semicolon) END END ; - IF (sym < const) OR (sym > var) THEN EXIT END ; + IF (sym < OPM.const) OR (sym > OPM.var) THEN EXIT END ; END ; i := 0; WHILE i < nofFwdPtr DO @@ -1027,21 +967,21 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END ; OPT.topScope^.adr := OPM.errpos; procdec := NIL; lastdec := NIL; - WHILE sym = procedure DO + WHILE sym = OPM.procedure DO OPS.Get(sym); ProcedureDeclaration(x); IF x # NIL THEN IF lastdec = NIL THEN procdec := x ELSE lastdec^.link := x END ; lastdec := x END ; - CheckSym(semicolon) + CheckSym(OPM.semicolon) END ; - IF sym = begin THEN OPS.Get(sym); StatSeq(statseq) + IF sym = OPM.begin THEN OPS.Get(sym); StatSeq(statseq) ELSE statseq := NIL END ; IF (level = 0) & (TDinit # NIL) THEN lastTDinit^.link := statseq; statseq := TDinit END ; - CheckSym(end) + CheckSym(OPM.end) END Block; PROCEDURE Module*(VAR prog: OPT.Node; opt: SET); @@ -1050,38 +990,38 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) c: LONGINT; done: BOOLEAN; BEGIN OPS.Init; LoopLevel := 0; level := 0; OPS.Get(sym); - IF sym = module THEN OPS.Get(sym) ELSE err(16) END ; - IF sym = ident THEN + IF sym = OPM.module THEN OPS.Get(sym) ELSE err(16) END ; + IF sym = OPM.ident THEN OPM.LogWStr("compiling "); OPM.LogWStr(OPS.name); OPM.LogW("."); - OPT.Init(OPS.name, opt); OPS.Get(sym); CheckSym(semicolon); - IF sym = import THEN OPS.Get(sym); + OPT.Init(OPS.name, opt); OPS.Get(sym); CheckSym(OPM.semicolon); + IF sym = OPM.import THEN OPS.Get(sym); LOOP - IF sym = ident THEN + IF sym = OPM.ident THEN COPY(OPS.name, aliasName); COPY(aliasName, impName); OPS.Get(sym); - IF sym = becomes THEN OPS.Get(sym); - IF sym = ident THEN COPY(OPS.name, impName); OPS.Get(sym) ELSE err(ident) END + IF sym = OPM.becomes THEN OPS.Get(sym); + IF sym = OPM.ident THEN COPY(OPS.name, impName); OPS.Get(sym) ELSE err(OPM.ident) END END ; OPT.Import(aliasName, impName, done) - ELSE err(ident) + ELSE err(OPM.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPM.comma THEN OPS.Get(sym) + ELSIF sym = OPM.ident THEN err(OPM.comma) ELSE EXIT END END ; - CheckSym(semicolon) + CheckSym(OPM.semicolon) END ; IF OPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := OPM.errpos; Block(procdec, statseq); OPB.Enter(procdec, statseq, NIL); prog := procdec; prog^.conval := OPT.NewConst(); prog^.conval^.intval := c; - IF sym = ident THEN + IF sym = OPM.ident THEN IF OPS.name # OPT.SelfName THEN err(4) END ; OPS.Get(sym) - ELSE err(ident) + ELSE err(OPM.ident) END ; - IF sym # period THEN err(period) END + IF sym # OPM.period THEN err(OPM.period) END END - ELSE err(ident) + ELSE err(OPM.ident) END ; TDinit := NIL; lastTDinit := NIL END Module; diff --git a/src/compiler/OPS.Mod b/src/compiler/OPS.Mod index 8514886c..d3b78781 100644 --- a/src/compiler/OPS.Mod +++ b/src/compiler/OPS.Mod @@ -10,9 +10,8 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) Name* = ARRAY MaxIdLen OF CHAR; String* = ARRAY MaxStrLen OF CHAR; - (* name, str, numtyp, intval, realval, lrlval are implicit results of Get *) - VAR + (* name, str, numtyp, intval, realval, lrlval are implicit results of Get *) name*: Name; str*: String; numtyp*: INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *) @@ -20,43 +19,6 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) realval*: REAL; lrlval*: LONGREAL; - (*symbols: - | 0 1 2 3 4 - ---|-------------------------------------------------------- - 0 | null * / DIV MOD - 5 | & + - OR = - 10 | # < <= > >= - 15 | IN IS ^ . , - 20 | : .. ) ] } - 25 | OF THEN DO TO BY - 30 | ( [ { ~ := - 35 | number NIL string ident ; - 40 | | END ELSE ELSIF UNTIL - 45 | IF CASE WHILE REPEAT FOR - 50 | LOOP WITH EXIT RETURN ARRAY - 55 | RECORD POINTER BEGIN CONST TYPE - 60 | VAR PROCEDURE IMPORT MODULE eof *) - - CONST - (* numtyp values *) - char = 1; integer = 2; real = 3; longreal = 4; - - (*symbol values*) - null = 0; times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; arrow = 17; period = 18; comma = 19; - colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24; - of = 25; then = 26; do = 27; to = 28; by = 29; - lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34; - number = 35; nil = 36; string = 37; ident = 38; semicolon = 39; - bar = 40; end = 41; else = 42; elsif = 43; until = 44; - if = 45; case = 46; while = 47; repeat = 48; for = 49; - loop = 50; with = 51; exit = 52; return = 53; array = 54; - record = 55; pointer = 56; begin = 57; const = 58; type = 59; - var = 60; procedure = 61; import = 62; module = 63; eof = 64; - - VAR ch: CHAR; (*current character*) PROCEDURE err(n: INTEGER); @@ -74,8 +36,8 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) END ; OPM.Get(ch); str[i] := 0X; intval := i + 1; IF intval = 2 THEN - sym := number; numtyp := 1; intval := ORD(str[0]) - ELSE sym := string + sym := OPM.number; numtyp := 1; intval := ORD(str[0]) + ELSE sym := OPM.string END END Str; @@ -86,7 +48,7 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) name[i] := ch; INC(i); OPM.Get(ch) UNTIL (ch < "0") OR ("9" < ch) & (CAP(ch) < "A") OR ("Z" < CAP(ch)) OR (i = MaxIdLen); IF i = MaxIdLen THEN err(240); DEC(i) END ; - name[i] := 0X; sym := ident + name[i] := 0X; sym := OPM.ident END Identifier; PROCEDURE Number; @@ -128,21 +90,21 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) ELSE EXIT END END; (* 0 <= n <= m <= i, 0 <= d <= i *) - IF d = 0 THEN (* integer *) + IF d = 0 THEN (* OPM.integer *) IF n = m THEN intval := 0; i := 0; - IF ch = "X" THEN (* character *) OPM.Get(ch); numtyp := char; + IF ch = "X" THEN (* character *) OPM.Get(ch); numtyp := OPM.char; IF n <= 2 THEN WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END ELSE err(203) END - ELSIF ch = "H" THEN (* hexadecimal *) OPM.Get(ch); numtyp := integer; + ELSIF ch = "H" THEN (* hexadecimal *) OPM.Get(ch); numtyp := OPM.integer; IF MAX(LONGINT) > 2147483647 THEN maxHdig := 16 ELSE maxHdig := 8 END; IF n <= maxHdig THEN IF (n = maxHdig) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END; WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END ELSE err(203) END - ELSE (* decimal *) numtyp := integer; + ELSE (* decimal *) numtyp := OPM.integer; WHILE i < n DO d := Ord(dig[i], FALSE); INC(i); IF intval <= (MAX(LONGINT) - d) DIV 10 THEN intval := intval*10 + d ELSE err(203) @@ -169,14 +131,14 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) END END; DEC(e, i-d-m); (* decimal point shift *) - IF expCh = "E" THEN numtyp := real; + IF expCh = "E" THEN numtyp := OPM.real; IF (1-OPM.MaxRExp < e) & (e <= OPM.MaxRExp) THEN IF e < 0 THEN realval := SHORT(f / Ten(-e)) ELSE realval := SHORT(f * Ten(e)) END ELSE err(203) END - ELSE numtyp := longreal; + ELSE numtyp := OPM.longreal; IF (1-OPM.MaxLExp < e) & (e <= OPM.MaxLExp) THEN IF e < 0 THEN lrlval := f / Ten(-e) ELSE lrlval := f * Ten(e) @@ -209,102 +171,100 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) BEGIN OPM.errpos := OPM.curpos-1; WHILE ch <= " " DO (*ignore control characters*) - IF ch = OPM.Eot THEN sym := eof; RETURN + IF ch = OPM.Eot THEN sym := OPM.eof; RETURN ELSE OPM.Get(ch) END END ; CASE ch OF (* ch > " " *) | 22X, 27X : Str(s) - | "#" : s := neq; OPM.Get(ch) - | "&" : s := and; OPM.Get(ch) + | "#" : s := OPM.neq; OPM.Get(ch) + | "&" : s := OPM.and; OPM.Get(ch) | "(" : OPM.Get(ch); - IF ch = "*" THEN Comment; Get(s) - ELSE s := lparen - END - | ")" : s := rparen; OPM.Get(ch) - | "*" : s := times; OPM.Get(ch) - | "+" : s := plus; OPM.Get(ch) - | "," : s := comma; OPM.Get(ch) - | "-" : s := minus; OPM.Get(ch) + IF ch = "*" THEN Comment; Get(s) ELSE s := OPM.lparen END + | ")" : s := OPM.rparen; OPM.Get(ch) + | "*" : s := OPM.times; OPM.Get(ch) + | "+" : s := OPM.plus; OPM.Get(ch) + | "," : s := OPM.comma; OPM.Get(ch) + | "-" : s := OPM.minus; OPM.Get(ch) | "." : OPM.Get(ch); - IF ch = "." THEN OPM.Get(ch); s := upto ELSE s := period END - | "/" : s := slash; OPM.Get(ch) - | "0".."9": Number; s := number + IF ch = "." THEN OPM.Get(ch); s := OPM.upto ELSE s := OPM.period END + | "/" : s := OPM.slash; OPM.Get(ch) + | "0".."9": Number; s := OPM.number | ":" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := becomes ELSE s := colon END - | ";" : s := semicolon; OPM.Get(ch) + IF ch = "=" THEN OPM.Get(ch); s := OPM.becomes ELSE s := OPM.colon END + | ";" : s := OPM.semicolon; OPM.Get(ch) | "<" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := leq ELSE s := lss END - | "=" : s := eql; OPM.Get(ch) + IF ch = "=" THEN OPM.Get(ch); s := OPM.leq ELSE s := OPM.lss END + | "=" : s := OPM.eql; OPM.Get(ch) | ">" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := geq ELSE s := gtr END - | "A": Identifier(s); IF name = "ARRAY" THEN s := array END + IF ch = "=" THEN OPM.Get(ch); s := OPM.geq ELSE s := OPM.gtr END + | "A": Identifier(s); IF name = "ARRAY" THEN s := OPM.array END | "B": Identifier(s); - IF name = "BEGIN" THEN s := begin - ELSIF name = "BY" THEN s := by + IF name = "BEGIN" THEN s := OPM.begin + ELSIF name = "BY" THEN s := OPM.by END | "C": Identifier(s); - IF name = "CASE" THEN s := case - ELSIF name = "CONST" THEN s := const + IF name = "CASE" THEN s := OPM.case + ELSIF name = "CONST" THEN s := OPM.const END | "D": Identifier(s); - IF name = "DO" THEN s := do - ELSIF name = "DIV" THEN s := div + IF name = "DO" THEN s := OPM.do + ELSIF name = "DIV" THEN s := OPM.div END | "E": Identifier(s); - IF name = "END" THEN s := end - ELSIF name = "ELSE" THEN s := else - ELSIF name = "ELSIF" THEN s := elsif - ELSIF name = "EXIT" THEN s := exit + IF name = "END" THEN s := OPM.end + ELSIF name = "ELSE" THEN s := OPM.else + ELSIF name = "ELSIF" THEN s := OPM.elsif + ELSIF name = "EXIT" THEN s := OPM.exit END - | "F": Identifier(s); IF name = "FOR" THEN s := for END + | "F": Identifier(s); IF name = "FOR" THEN s := OPM.for END | "I": Identifier(s); - IF name = "IF" THEN s := if - ELSIF name = "IN" THEN s := in - ELSIF name = "IS" THEN s := is - ELSIF name = "IMPORT" THEN s := import + IF name = "IF" THEN s := OPM.if + ELSIF name = "IN" THEN s := OPM.in + ELSIF name = "IS" THEN s := OPM.is + ELSIF name = "IMPORT" THEN s := OPM.import END - | "L": Identifier(s); IF name = "LOOP" THEN s := loop END + | "L": Identifier(s); IF name = "LOOP" THEN s := OPM.loop END | "M": Identifier(s); - IF name = "MOD" THEN s := mod - ELSIF name = "MODULE" THEN s := module + IF name = "MOD" THEN s := OPM.mod + ELSIF name = "MODULE" THEN s := OPM.module END - | "N": Identifier(s); IF name = "NIL" THEN s := nil END + | "N": Identifier(s); IF name = "NIL" THEN s := OPM.nil END | "O": Identifier(s); - IF name = "OR" THEN s := or - ELSIF name = "OF" THEN s := of + IF name = "OR" THEN s := OPM.or + ELSIF name = "OF" THEN s := OPM.of END | "P": Identifier(s); - IF name = "PROCEDURE" THEN s := procedure - ELSIF name = "POINTER" THEN s := pointer + IF name = "PROCEDURE" THEN s := OPM.procedure + ELSIF name = "POINTER" THEN s := OPM.pointer END | "R": Identifier(s); - IF name = "RECORD" THEN s := record - ELSIF name = "REPEAT" THEN s := repeat - ELSIF name = "RETURN" THEN s := return + IF name = "RECORD" THEN s := OPM.record + ELSIF name = "REPEAT" THEN s := OPM.repeat + ELSIF name = "RETURN" THEN s := OPM.return END | "T": Identifier(s); - IF name = "THEN" THEN s := then - ELSIF name = "TO" THEN s := to - ELSIF name = "TYPE" THEN s := type + IF name = "THEN" THEN s := OPM.then + ELSIF name = "TO" THEN s := OPM.to + ELSIF name = "TYPE" THEN s := OPM.type END - | "U": Identifier(s); IF name = "UNTIL" THEN s := until END - | "V": Identifier(s); IF name = "VAR" THEN s := var END + | "U": Identifier(s); IF name = "UNTIL" THEN s := OPM.until END + | "V": Identifier(s); IF name = "VAR" THEN s := OPM.var END | "W": Identifier(s); - IF name = "WHILE" THEN s := while - ELSIF name = "WITH" THEN s := with + IF name = "WHILE" THEN s := OPM.while + ELSIF name = "WITH" THEN s := OPM.with END | "G".."H", "J", "K", "Q", "S", "X".."Z": Identifier(s) - | "[" : s := lbrak; OPM.Get(ch) - | "]" : s := rbrak; OPM.Get(ch) - | "^" : s := arrow; OPM.Get(ch) + | "[" : s := OPM.lbrak; OPM.Get(ch) + | "]" : s := OPM.rbrak; OPM.Get(ch) + | "^" : s := OPM.arrow; OPM.Get(ch) | "a".."z": Identifier(s) - | "{" : s := lbrace; OPM.Get(ch) - | "|" : s := bar; OPM.Get(ch) - | "}" : s := rbrace; OPM.Get(ch) - | "~" : s := not; OPM.Get(ch) - | 7FX : s := upto; OPM.Get(ch) - ELSE s := null; OPM.Get(ch) + | "{" : s := OPM.lbrace; OPM.Get(ch) + | "|" : s := OPM.bar; OPM.Get(ch) + | "}" : s := OPM.rbrace; OPM.Get(ch) + | "~" : s := OPM.not; OPM.Get(ch) + | 7FX : s := OPM.upto; OPM.Get(ch) + ELSE s := OPM.null; OPM.Get(ch) END ; sym := s END Get; diff --git a/src/compiler/OPT.Mod b/src/compiler/OPT.Mod index 5912149b..d4c9f4eb 100644 --- a/src/compiler/OPT.Mod +++ b/src/compiler/OPT.Mod @@ -22,7 +22,7 @@ TYPE intval2*: LONGINT; (* string length, proc var size or larger case label *) setval*: SET; (* constant value, procedure body present or "ELSE" present in case *) realval*: LONGREAL (* real or longreal constant value *) - END ; + END; ObjDesc* = RECORD left*, right*: Object; @@ -30,7 +30,7 @@ TYPE name*: OPS.Name; leaf*: BOOLEAN; mode*, mnolev*: SHORTINT; (* mnolev < 0 -> mno = -mnolev *) - vis*: SHORTINT; (* internal, external, externalR *) + vis*: SHORTINT; (* OPM.internal, OPM.external, OPM.externalR *) history*: SHORTINT; (* relevant if name # "" *) used*, fpdone*: BOOLEAN; fprint*: LONGINT; @@ -38,21 +38,21 @@ TYPE conval*: Const; adr*, linkadr*: LONGINT; x*: INTEGER (* linkadr and x can be freely used by the backend *) - END ; + END; StrDesc* = RECORD - form*, comp*: SHORTINT; - mno*, extlev*: SHORTINT; - ref*, sysflag*: INTEGER; - n*, size*: LONGINT; - align*, txtpos*: LONGINT; (* align is alignment for records and len offset for dynarrs *) - allocated*: BOOLEAN; - pbused*, pvused*: BOOLEAN; - fpdone, idfpdone: BOOLEAN; - idfp, pbfp*, pvfp*: LONGINT; - BaseTyp*: Struct; - link*, strobj*: Object - END ; + form*, comp*: SHORTINT; + mno*, extlev*: SHORTINT; + ref*, sysflag*: INTEGER; + n*, size*: LONGINT; + align*, txtpos*: LONGINT; (* align is alignment for records, len is offset for dynarrs *) + allocated*: BOOLEAN; + pbused*, pvused*: BOOLEAN; + fpdone, idfpdone: BOOLEAN; + idfp, pbfp, pvfp: LONGINT; + BaseTyp*: Struct; + link*, strobj*: Object + END; NodeDesc* = RECORD left*, right*, link*: Node; @@ -61,70 +61,36 @@ TYPE typ*: Struct; obj*: Object; conval*: Const - END ; + END; CONST - maxImps = 64; (* must be <= MAX(SHORTINT) *) + maxImps = 64; (* must be <= MAX(SHORTINT) *) maxStruct = OPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *) - FirstRef = (*20*)16; (* comp + 1 *) + FirstRef = OPM.Comp + 1; VAR - typSize*: PROCEDURE(typ: Struct); + typSize*: PROCEDURE(typ: Struct); topScope*: Object; - undftyp*, bytetyp*, booltyp*, chartyp*, sinttyp*, inttyp*, linttyp*, - realtyp*, lrltyp*, settyp*, stringtyp*, niltyp*, notyp*, sysptrtyp*(*, - int8typ*, int16typ*, int32typ*, int64typ* *): Struct; + + undftyp*, + bytetyp*, booltyp*, chartyp*, + sinttyp*, inttyp*, linttyp*, + realtyp*, lrltyp*, settyp*, stringtyp*, + niltyp*, notyp*, sysptrtyp*: Struct; + nofGmod*: SHORTINT; (*nof imports*) - GlbMod*: ARRAY maxImps OF Object; (* ^.right = first object, ^.name = module import name (not alias) *) - SelfName*: OPS.Name; (* name of module being compiled *) + GlbMod*: ARRAY maxImps OF Object; (* ^.right = first object, ^.name = module import name (not alias) *) + + SelfName*: OPS.Name; (* name of module being compiled *) SYSimported*: BOOLEAN; CONST - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = 19;*) - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (*function number*) - assign = 0; - haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; - entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; - shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; - - (*SYSTEM function number*) - adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; - bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* history of imported objects *) - inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; - - (* symbol file items *) - Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22; - Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30; - Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40; + (* Symbol file items *) + Smname* = 16; Send* = 18; Stype* = 19; Salias* = 20; Svar* = 21; + Srvar* = 22; Svalpar* = 23; Svarpar* = 24; Sfld* = 25; Srfld* = 26; + Shdptr* = 27; Shdpro* = 28; Stpro* = 29; Shdtpro* = 30; Sxpro* = 31; + Sipro* = 32; Scpro* = 33; Sstruct* = 34; Ssys* = 35; Sptr* = 36; + Sarr* = 37; Sdarr* = 38; Srec* = 39; Spro* = 40; TYPE ImpCtxt = RECORD @@ -135,14 +101,14 @@ TYPE old: ARRAY maxStruct OF Object; pvfp: ARRAY maxStruct OF LONGINT; (* set only if old # NIL *) glbmno: ARRAY maxImps OF SHORTINT (* index is local mno *) - END ; + END; ExpCtxt = RECORD reffp: LONGINT; ref: INTEGER; nofm: SHORTINT; locmno: ARRAY maxImps OF SHORTINT (* index is global mno *) - END ; + END; VAR universe, syslink: Object; @@ -158,38 +124,38 @@ BEGIN OPM.err(n) END err; PROCEDURE NewConst*(): Const; -VAR const: Const; + VAR const: Const; BEGIN NEW(const); RETURN const END NewConst; PROCEDURE NewObj*(): Object; -VAR obj: Object; + VAR obj: Object; BEGIN NEW(obj); RETURN obj END NewObj; PROCEDURE NewStr*(form, comp: SHORTINT): Struct; -VAR typ: Struct; + VAR typ: Struct; BEGIN NEW(typ); typ^.form := form; typ^.comp := comp; typ^.ref := maxStruct; (* ref >= maxStruct: not exported yet *) -IF form # Undef THEN typ^.txtpos := OPM.errpos END ; (* txtpos remains 0 for structs read from symbol file *) -typ^.size := -1; typ^.BaseTyp := undftyp; RETURN typ + IF form # OPM.Undef THEN typ^.txtpos := OPM.errpos END ; (* txtpos remains 0 for structs read from symbol file *) + typ^.size := -1; typ^.BaseTyp := undftyp; RETURN typ END NewStr; PROCEDURE NewNode*(class: SHORTINT): Node; -VAR node: Node; + VAR node: Node; BEGIN NEW(node); node^.class := class; RETURN node END NewNode; PROCEDURE NewExt*(): ConstExt; -VAR ext: ConstExt; + VAR ext: ConstExt; BEGIN NEW(ext); RETURN ext END NewExt; PROCEDURE OpenScope*(level: SHORTINT; owner: Object); -VAR head: Object; + VAR head: Object; BEGIN head := NewObj(); -head^.mode := Head; head^.mnolev := level; head^.link := owner; -IF owner # NIL THEN owner^.scope := head END ; -head^.left := topScope; head^.right := NIL; head^.scope := NIL; topScope := head + head^.mode := OPM.Head; head^.mnolev := level; head^.link := owner; + IF owner # NIL THEN owner^.scope := head END; + head^.left := topScope; head^.right := NIL; head^.scope := NIL; topScope := head END OpenScope; PROCEDURE CloseScope*; @@ -197,97 +163,100 @@ BEGIN topScope := topScope^.left END CloseScope; PROCEDURE Init*(VAR name: OPS.Name; opt: SET); -CONST nsf = 4; fpc = 8; esf = 9; + CONST nsf = 4; fpc = 8; esf = 9; BEGIN -topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; -SelfName := name; topScope^.name := name; -GlbMod[0] := topScope; nofGmod := 1; -newsf := nsf IN opt; findpc := fpc IN opt; extsf := newsf OR (esf IN opt); sfpresent := TRUE + topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; + SelfName := name; topScope^.name := name; + GlbMod[0] := topScope; nofGmod := 1; + newsf := nsf IN opt; findpc := fpc IN opt; extsf := newsf OR (esf IN opt); sfpresent := TRUE END Init; PROCEDURE Close*; -VAR i: INTEGER; + VAR i: INTEGER; BEGIN (* garbage collection *) -CloseScope; -i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ; -i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END + CloseScope; + i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END; + i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END END Close; PROCEDURE FindImport*(mod: Object; VAR res: Object); -VAR obj: Object; + VAR obj: Object; BEGIN obj := mod^.scope; -LOOP -IF obj = NIL THEN EXIT END ; -IF OPS.name < obj^.name THEN obj := obj^.left -ELSIF OPS.name > obj^.name THEN obj := obj^.right -ELSE (*found*) -IF (obj^.mode = Typ) & (obj^.vis = internal) THEN obj := NIL -ELSE obj^.used := TRUE -END ; -EXIT -END -END ; -res := obj + LOOP + IF obj = NIL THEN EXIT END; + IF OPS.name < obj^.name THEN obj := obj^.left + ELSIF OPS.name > obj^.name THEN obj := obj^.right + ELSE (*found*) + IF (obj^.mode = OPM.Typ) & (obj^.vis = OPM.internal) THEN obj := NIL + ELSE obj^.used := TRUE + END; + EXIT + END + END; + res := obj END FindImport; PROCEDURE Find*(VAR res: Object); -VAR obj, head: Object; + VAR obj, head: Object; BEGIN head := topScope; -LOOP obj := head^.right; -LOOP -IF obj = NIL THEN EXIT END ; -IF OPS.name < obj^.name THEN obj := obj^.left -ELSIF OPS.name > obj^.name THEN obj := obj^.right -ELSE (* found, obj^.used not set for local objects *) EXIT -END -END ; -IF obj # NIL THEN EXIT END ; -head := head^.left; -IF head = NIL THEN EXIT END -END ; -res := obj + LOOP obj := head^.right; + LOOP + IF obj = NIL THEN EXIT END; + IF OPS.name < obj^.name THEN obj := obj^.left + ELSIF OPS.name > obj^.name THEN obj := obj^.right + ELSE (* found, obj^.used not set for local objects *) EXIT + END + END; + IF obj # NIL THEN EXIT END; + head := head^.left; + IF head = NIL THEN EXIT END + END; + res := obj END Find; PROCEDURE FindField*(VAR name: OPS.Name; typ: Struct; VAR res: Object); -VAR obj: Object; + VAR obj: Object; BEGIN -WHILE typ # NIL DO obj := typ^.link; -WHILE obj # NIL DO -IF name < obj^.name THEN obj := obj^.left -ELSIF name > obj^.name THEN obj := obj^.right -ELSE (*found*) res := obj; RETURN -END -END ; -typ := typ^.BaseTyp -END ; -res := NIL + WHILE typ # NIL DO obj := typ^.link; + WHILE obj # NIL DO + IF name < obj^.name THEN obj := obj^.left + ELSIF name > obj^.name THEN obj := obj^.right + ELSE (*found*) res := obj; RETURN + END + END; + typ := typ^.BaseTyp + END; + res := NIL END FindField; PROCEDURE Insert*(VAR name: OPS.Name; VAR obj: Object); -VAR ob0, ob1: Object; left: BOOLEAN; mnolev: SHORTINT; + VAR ob0, ob1: Object; left: BOOLEAN; mnolev: SHORTINT; BEGIN ob0 := topScope; ob1 := ob0^.right; left := FALSE; -LOOP -IF ob1 # NIL THEN -IF name < ob1^.name THEN ob0 := ob1; ob1 := ob0^.left; left := TRUE -ELSIF name > ob1^.name THEN ob0 := ob1; ob1 := ob0^.right; left := FALSE -ELSE (*double def*) err(1); ob0 := ob1; ob1 := ob0^.right -END -ELSE (*insert*) ob1 := NewObj(); ob1^.leaf := TRUE; -IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ; -ob1^.left := NIL; ob1^.right := NIL; COPY(name, ob1^.name); -mnolev := topScope^.mnolev; ob1^.mnolev := mnolev; -EXIT -END -END ; -obj := ob1 + LOOP + IF ob1 # NIL THEN + IF name < ob1^.name THEN ob0 := ob1; ob1 := ob0^.left; left := TRUE + ELSIF name > ob1^.name THEN ob0 := ob1; ob1 := ob0^.right; left := FALSE + ELSE (*double def*) err(1); ob0 := ob1; ob1 := ob0^.right + END + ELSE (*insert*) ob1 := NewObj(); ob1^.leaf := TRUE; + IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END; + ob1^.left := NIL; ob1^.right := NIL; COPY(name, ob1^.name); + mnolev := topScope^.mnolev; ob1^.mnolev := mnolev; + EXIT + END + END; + obj := ob1 END Insert; + (*-------------------------- Fingerprinting --------------------------*) +(* Fingerprints prevent structural type equivalence. *) + PROCEDURE FPrintName(VAR fp: LONGINT; VAR name: ARRAY OF CHAR); -VAR i: INTEGER; ch: CHAR; + VAR i: INTEGER; ch: CHAR; BEGIN i := 0; -REPEAT ch := name[i]; OPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X + REPEAT ch := name[i]; OPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X END FPrintName; PROCEDURE ^IdFPrint*(typ: Struct); @@ -328,134 +297,133 @@ BEGIN btyp := typ^.BaseTyp; strobj := typ^.strobj; IF (strobj # NIL) & (strobj^.name # "") THEN FPrintName(idfp, GlbMod[typ^.mno]^.name); FPrintName(idfp, strobj^.name) - END ; - IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN + END; + IF (f = OPM.Pointer) OR (c = OPM.Record) & (btyp # NIL) OR (c = OPM.DynArr) THEN IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp) - ELSIF c = Array THEN + ELSIF c = OPM.Array THEN IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp); OPM.FPrint(idfp, typ^.n) - ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ^.link) - END ; + ELSIF f = OPM.ProcTyp THEN FPrintSign(idfp, btyp, typ^.link) + END; typ^.idfp := idfp END END IdFPrint; PROCEDURE FPrintStr*(typ: Struct); -VAR f, c: INTEGER; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: LONGINT; + VAR f, c: INTEGER; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: LONGINT; -PROCEDURE ^FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); + PROCEDURE ^FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); -PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: LONGINT); (* modifies pvfp only *) -VAR i, j, n: LONGINT; btyp: Struct; -BEGIN -IF typ^.comp = Record THEN FPrintFlds(typ^.link, adr, FALSE) -ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; -WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; -IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN - j := nofhdfld; FPrintHdFld(btyp, fld, adr); - IF j # nofhdfld THEN i := 1; - WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO - INC(adr, btyp^.size); FPrintHdFld(btyp, fld, adr); INC(i) + PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: LONGINT); (* modifies pvfp only *) + VAR i, j, n: LONGINT; btyp: Struct; + BEGIN + IF typ^.comp = OPM.Record THEN FPrintFlds(typ^.link, adr, FALSE) + ELSIF typ^.comp = OPM.Array THEN btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPM.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END; + IF (btyp^.form = OPM.Pointer) OR (btyp^.comp = OPM.Record) THEN + j := nofhdfld; FPrintHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO + INC(adr, btyp^.size); FPrintHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF OPM.ExpHdPtrFld & ((typ^.form = OPM.Pointer) OR (fld^.name = OPM.HdPtrName)) THEN + OPM.FPrint(pvfp, OPM.Pointer); OPM.FPrint(pvfp, adr); INC(nofhdfld) + ELSIF OPM.ExpHdProcFld & ((typ^.form = OPM.ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN + OPM.FPrint(pvfp, OPM.ProcTyp); OPM.FPrint(pvfp, adr); INC(nofhdfld) + END + END FPrintHdFld; + + PROCEDURE FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); (* modifies pbfp and pvfp *) + BEGIN + WHILE (fld # NIL) & (fld^.mode = OPM.Fld) DO + IF (fld^.vis # OPM.internal) & visible THEN + OPM.FPrint(pbfp, fld^.vis); FPrintName(pbfp, fld^.name); OPM.FPrint(pbfp, fld^.adr); + FPrintStr(fld^.typ); OPM.FPrint(pbfp, fld^.typ^.pbfp); OPM.FPrint(pvfp, fld^.typ^.pvfp) + ELSE + FPrintHdFld(fld^.typ, fld, fld^.adr + adr) + END; + fld := fld^.link END; - END -END -ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN -OPM.FPrint(pvfp, Pointer); OPM.FPrint(pvfp, adr); INC(nofhdfld) -ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN -OPM.FPrint(pvfp, ProcTyp); OPM.FPrint(pvfp, adr); INC(nofhdfld) -END -END FPrintHdFld; + END FPrintFlds; -PROCEDURE FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); (* modifies pbfp and pvfp *) -BEGIN -WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF (fld^.vis # internal) & visible THEN - OPM.FPrint(pbfp, fld^.vis); FPrintName(pbfp, fld^.name); OPM.FPrint(pbfp, fld^.adr); - FPrintStr(fld^.typ); OPM.FPrint(pbfp, fld^.typ^.pbfp); OPM.FPrint(pvfp, fld^.typ^.pvfp) - ELSE - FPrintHdFld(fld^.typ, fld, fld^.adr + adr) - END ; - fld := fld^.link -END; -END FPrintFlds; - -PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) -BEGIN - IF obj # NIL THEN + PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) + BEGIN + IF obj # NIL THEN FPrintTProcs(obj^.left); - IF obj^.mode = TProc THEN - IF obj^.vis # internal THEN - OPM.FPrint(pbfp, TProc); OPM.FPrint(pbfp, obj^.adr DIV 10000H); - FPrintSign(pbfp, obj^.typ, obj^.link); FPrintName(pbfp, obj^.name) - ELSIF OPM.ExpHdTProc THEN - OPM.FPrint(pvfp, TProc); OPM.FPrint(pvfp, obj^.adr DIV 10000H) - END - END ; + IF obj^.mode = OPM.TProc THEN + IF obj^.vis # OPM.internal THEN + OPM.FPrint(pbfp, OPM.TProc); OPM.FPrint(pbfp, obj^.adr DIV 10000H); + FPrintSign(pbfp, obj^.typ, obj^.link); FPrintName(pbfp, obj^.name) + ELSIF OPM.ExpHdTProc THEN + OPM.FPrint(pvfp, OPM.TProc); OPM.FPrint(pvfp, obj^.adr DIV 10000H) + END + END; FPrintTProcs(obj^.right) - END; -END FPrintTProcs; + END; + END FPrintTProcs; BEGIN - IF ~typ^.fpdone THEN - IdFPrint(typ); pbfp := typ^.idfp; - IF typ^.sysflag # 0 THEN OPM.FPrint(pbfp, typ^.sysflag) END ; - pvfp := pbfp; typ^.pbfp := pbfp; typ^.pvfp := pvfp; (* initial fprints may be used recursively *) - typ^.fpdone := TRUE; - f := typ^.form; c := typ^.comp; btyp := typ^.BaseTyp; - IF f = Pointer THEN - strobj := typ^.strobj; bstrobj := btyp^.strobj; - IF (strobj = NIL) OR (strobj^.name = "") OR (bstrobj = NIL) OR (bstrobj^.name = "") THEN - FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); pvfp := pbfp - (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) - END - ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) - ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pvfp); pvfp := pbfp - ELSE (* c = Record *) - IF btyp # NIL THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); OPM.FPrint(pvfp, btyp^.pvfp) END ; - OPM.FPrint(pvfp, typ^.size); OPM.FPrint(pvfp, typ^.align); OPM.FPrint(pvfp, typ^.n); - nofhdfld := 0; FPrintFlds(typ^.link, 0, TRUE); - IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(225, typ^.txtpos) END ; - FPrintTProcs(typ^.link); OPM.FPrint(pvfp, pbfp); strobj := typ^.strobj; - IF (strobj = NIL) OR (strobj^.name = "") THEN pbfp := pvfp END - END ; - typ^.pbfp := pbfp; typ^.pvfp := pvfp - END; + IF ~typ^.fpdone THEN + IdFPrint(typ); pbfp := typ^.idfp; + IF typ^.sysflag # 0 THEN OPM.FPrint(pbfp, typ^.sysflag) END; + pvfp := pbfp; typ^.pbfp := pbfp; typ^.pvfp := pvfp; (* initial fprints may be used recursively *) + typ^.fpdone := TRUE; + f := typ^.form; c := typ^.comp; btyp := typ^.BaseTyp; + IF f = OPM.Pointer THEN + strobj := typ^.strobj; bstrobj := btyp^.strobj; + IF (strobj = NIL) OR (strobj^.name = "") OR (bstrobj = NIL) OR (bstrobj^.name = "") THEN + FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); pvfp := pbfp + (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) + END + ELSIF f = OPM.ProcTyp THEN (* use idfp as pbfp and as pvfp *) + ELSIF c IN {OPM.Array, OPM.DynArr} THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pvfp); pvfp := pbfp + ELSE (* c = OPM.Record *) + IF btyp # NIL THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); OPM.FPrint(pvfp, btyp^.pvfp) END; + OPM.FPrint(pvfp, typ^.size); OPM.FPrint(pvfp, typ^.align); OPM.FPrint(pvfp, typ^.n); + nofhdfld := 0; FPrintFlds(typ^.link, 0, TRUE); + IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(225, typ^.txtpos) END; + FPrintTProcs(typ^.link); OPM.FPrint(pvfp, pbfp); strobj := typ^.strobj; + IF (strobj = NIL) OR (strobj^.name = "") THEN pbfp := pvfp END + END; + typ^.pbfp := pbfp; typ^.pvfp := pvfp + END END FPrintStr; PROCEDURE FPrintObj*(obj: Object); VAR fprint: LONGINT; f, m: INTEGER; rval: REAL; ext: ConstExt; BEGIN - IF ~obj^.fpdone THEN - fprint := 0; obj^.fpdone := TRUE; - OPM.FPrint(fprint, obj^.mode); - IF obj^.mode = Con THEN - f := obj^.typ^.form; OPM.FPrint(fprint, f); - CASE f OF - | Bool, Char, SInt, Int, LInt(*, Int8, Int16, Int32, Int64*): - OPM.FPrint(fprint, obj^.conval^.intval) - | Set: - OPM.FPrintSet(fprint, obj^.conval^.setval) - | Real: - rval := SHORT(obj^.conval^.realval); OPM.FPrintReal(fprint, rval) - | LReal: - OPM.FPrintLReal(fprint, obj^.conval^.realval) - | String: - FPrintName(fprint, obj^.conval^.ext^) - | NilTyp: - ELSE err(127) - END - ELSIF obj^.mode = Var THEN - OPM.FPrint(fprint, obj^.vis); FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) - ELSIF obj^.mode IN {XProc, IProc} THEN - FPrintSign(fprint, obj^.typ, obj^.link) - ELSIF obj^.mode = CProc THEN - FPrintSign(fprint, obj^.typ, obj^.link); ext := obj^.conval^.ext; - m := ORD(ext^[0]); f := 1; OPM.FPrint(fprint, m); - WHILE f <= m DO OPM.FPrint(fprint, ORD(ext^[f])); INC(f) END; - ELSIF obj^.mode = Typ THEN - FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) - END ; - obj^.fprint := fprint - END + IF ~obj^.fpdone THEN + fprint := 0; obj^.fpdone := TRUE; + OPM.FPrint(fprint, obj^.mode); + IF obj^.mode = OPM.Con THEN + f := obj^.typ^.form; OPM.FPrint(fprint, f); + CASE f OF + | OPM.Bool, + OPM.Char, + OPM.SInt, + OPM.Int, + OPM.LInt: OPM.FPrint(fprint, obj^.conval^.intval) + | OPM.Set: OPM.FPrintSet(fprint, obj^.conval^.setval) + | OPM.Real: rval := SHORT(obj^.conval^.realval); OPM.FPrintReal(fprint, rval) + | OPM.LReal: OPM.FPrintLReal(fprint, obj^.conval^.realval) + | OPM.String: FPrintName(fprint, obj^.conval^.ext^) + | OPM.NilTyp: + ELSE err(127) + END + ELSIF obj^.mode = OPM.Var THEN + OPM.FPrint(fprint, obj^.vis); FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) + ELSIF obj^.mode IN {OPM.XProc, OPM.IProc} THEN + FPrintSign(fprint, obj^.typ, obj^.link) + ELSIF obj^.mode = OPM.CProc THEN + FPrintSign(fprint, obj^.typ, obj^.link); ext := obj^.conval^.ext; + m := ORD(ext^[0]); f := 1; OPM.FPrint(fprint, m); + WHILE f <= m DO OPM.FPrint(fprint, ORD(ext^[f])); INC(f) END; + ELSIF obj^.mode = OPM.Typ THEN + FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) + END; + obj^.fprint := fprint + END END FPrintObj; PROCEDURE FPrintErr*(obj: Object; errcode: INTEGER); @@ -463,19 +431,19 @@ VAR i, j: INTEGER; ch: CHAR; BEGIN IF obj^.mnolev # 0 THEN COPY(GlbMod[-obj^.mnolev]^.name, OPM.objname); i := 0; - WHILE OPM.objname[i] # 0X DO INC(i) END ; + WHILE OPM.objname[i] # 0X DO INC(i) END; OPM.objname[i] := "."; j := 0; INC(i); REPEAT ch := obj^.name[j]; OPM.objname[i] := ch; INC(j); INC(i) UNTIL ch = 0X; ELSE COPY(obj^.name, OPM.objname) - END ; + END; IF errcode = 249 THEN IF OPM.noerr THEN err(errcode) END ELSIF errcode = 253 THEN (* extension *) - IF ~symNew & ~symExtended & ~extsf THEN err(errcode) END ; + IF ~symNew & ~symExtended & ~extsf THEN err(errcode) END; symExtended := TRUE ELSE - IF ~symNew & ~newsf THEN err(errcode) END ; + IF ~symNew & ~newsf THEN err(errcode) END; symNew := TRUE END END FPrintErr; @@ -483,372 +451,361 @@ END FPrintErr; (*-------------------------- Import --------------------------*) PROCEDURE InsertImport*(obj: Object; VAR root, old: Object); -VAR ob0, ob1: Object; left: BOOLEAN; + VAR ob0, ob1: Object; left: BOOLEAN; BEGIN -IF root = NIL THEN root := obj; old := NIL -ELSE -ob0 := root; ob1 := ob0^.right; left := FALSE; -IF obj^.name < ob0^.name THEN ob1 := ob0^.left; left := TRUE -ELSIF obj^.name > ob0^.name THEN ob1 := ob0^.right; left := FALSE -ELSE old := ob0; RETURN -END ; -LOOP -IF ob1 # NIL THEN - IF obj^.name < ob1^.name THEN ob0 := ob1; ob1 := ob1^.left; left := TRUE - ELSIF obj^.name > ob1^.name THEN ob0 := ob1; ob1 := ob1^.right; left := FALSE - ELSE old := ob1; EXIT + IF root = NIL THEN root := obj; old := NIL + ELSE + ob0 := root; ob1 := ob0^.right; left := FALSE; + IF obj^.name < ob0^.name THEN ob1 := ob0^.left; left := TRUE + ELSIF obj^.name > ob0^.name THEN ob1 := ob0^.right; left := FALSE + ELSE old := ob0; RETURN + END; + LOOP + IF ob1 # NIL THEN + IF obj^.name < ob1^.name THEN ob0 := ob1; ob1 := ob1^.left; left := TRUE + ELSIF obj^.name > ob1^.name THEN ob0 := ob1; ob1 := ob1^.right; left := FALSE + ELSE old := ob1; EXIT + END + ELSE ob1 := obj; + IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END; + ob1^.left := NIL; ob1^.right := NIL; old := NIL; EXIT + END + END END -ELSE ob1 := obj; - IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ; - ob1^.left := NIL; ob1^.right := NIL; old := NIL; EXIT -END -END -END END InsertImport; PROCEDURE InName(VAR name: ARRAY OF CHAR); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; -REPEAT -OPM.SymRCh(ch); name[i] := ch; INC(i) -UNTIL ch = 0X + REPEAT + OPM.SymRCh(ch); name[i] := ch; INC(i) + UNTIL ch = 0X END InName; PROCEDURE InMod(VAR mno: SHORTINT); (* mno is global *) -VAR head: Object; name: OPS.Name; mn: LONGINT; i: SHORTINT; + VAR head: Object; name: OPS.Name; mn: LONGINT; i: SHORTINT; BEGIN -mn := OPM.SymRInt(); -IF mn = 0 THEN mno := impCtxt.glbmno[0] -ELSE -IF mn = Smname THEN -InName(name); -IF (name = SelfName) & ~impCtxt.self THEN err(154) END ; -i := 0; -WHILE (i < nofGmod) & (name # GlbMod[i].name) DO INC(i) END ; -IF i < nofGmod THEN mno := i (*module already present*) -ELSE - head := NewObj(); head^.mode := Head; COPY(name, head^.name); - mno := nofGmod; head^.mnolev := -mno; - IF nofGmod < maxImps THEN - GlbMod[mno] := head; INC(nofGmod) - ELSE err(227) + mn := OPM.SymRInt(); + IF mn = 0 THEN mno := impCtxt.glbmno[0] + ELSE + IF mn = Smname THEN + InName(name); + IF (name = SelfName) & ~impCtxt.self THEN err(154) END; + i := 0; + WHILE (i < nofGmod) & (name # GlbMod[i].name) DO INC(i) END; + IF i < nofGmod THEN mno := i (*module already present*) + ELSE + head := NewObj(); head^.mode := OPM.Head; COPY(name, head^.name); + mno := nofGmod; head^.mnolev := -mno; + IF nofGmod < maxImps THEN + GlbMod[mno] := head; INC(nofGmod) + ELSE err(227) + END + END; + impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) + ELSE + mno := impCtxt.glbmno[-mn] + END END -END ; -impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) -ELSE -mno := impCtxt.glbmno[-mn] -END -END END InMod; PROCEDURE InConstant(f: LONGINT; conval: Const); -VAR ch: CHAR; i: INTEGER; ext: ConstExt; rval: REAL; + VAR ch: CHAR; i: INTEGER; ext: ConstExt; rval: REAL; BEGIN -CASE f OF -| (*Int8,*) Byte, Char, Bool: -OPM.SymRCh(ch); conval^.intval := ORD(ch) -(*| Int8, Int16, Int32, Int64: -conval^.intval := OPM.SymRInt()*) -| SInt, Int, LInt: -conval^.intval := OPM.SymRInt() -| Set: -OPM.SymRSet(conval^.setval) -| Real: -OPM.SymRReal(rval); conval^.realval := rval; -conval^.intval := OPM.ConstNotAlloc -| LReal: -OPM.SymRLReal(conval^.realval); -conval^.intval := OPM.ConstNotAlloc -| String: -ext := NewExt(); conval^.ext := ext; i := 0; -REPEAT -OPM.SymRCh(ch); ext^[i] := ch; INC(i) -UNTIL ch = 0X; -conval^.intval2 := i; -conval^.intval := OPM.ConstNotAlloc -| NilTyp: -conval^.intval := OPM.nilval -ELSE -OPM.LogWStr("unhandled case in OPT.InConstant(), f = "); OPM.LogWNum(f, 0); OPM.LogWLn; -END + CASE f OF + | OPM.Byte, + OPM.Char, + OPM.Bool: OPM.SymRCh(ch); conval^.intval := ORD(ch) + | OPM.SInt, + OPM.Int, + OPM.LInt: conval^.intval := OPM.SymRInt() + | OPM.Set: OPM.SymRSet(conval^.setval) + | OPM.Real: OPM.SymRReal(rval); conval^.realval := rval; + conval^.intval := OPM.ConstNotAlloc + | OPM.LReal: OPM.SymRLReal(conval^.realval); + conval^.intval := OPM.ConstNotAlloc + | OPM.String: ext := NewExt(); conval^.ext := ext; i := 0; + REPEAT + OPM.SymRCh(ch); ext^[i] := ch; INC(i) + UNTIL ch = 0X; + conval^.intval2 := i; + conval^.intval := OPM.ConstNotAlloc + | OPM.NilTyp: conval^.intval := OPM.nilval + ELSE OPM.LogWStr("unhandled case in OPT.InConstant(), f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + END END InConstant; PROCEDURE ^InStruct(VAR typ: Struct); PROCEDURE InSign(mno: SHORTINT; VAR res: Struct; VAR par: Object); -VAR last, new: Object; tag: LONGINT; + VAR last, new: Object; tag: LONGINT; BEGIN -InStruct(res); -tag := OPM.SymRInt(); last := NIL; -WHILE tag # Send DO -new := NewObj(); new^.mnolev := -mno; -IF last = NIL THEN par := new ELSE last^.link := new END ; -IF tag = Svalpar THEN new^.mode := Var ELSE new^.mode := VarPar END ; -InStruct(new^.typ); new^.adr := OPM.SymRInt(); InName(new^.name); -last := new; tag := OPM.SymRInt() -END + InStruct(res); + tag := OPM.SymRInt(); last := NIL; + WHILE tag # Send DO + new := NewObj(); new^.mnolev := -mno; + IF last = NIL THEN par := new ELSE last^.link := new END; + IF tag = Svalpar THEN new^.mode := OPM.Var ELSE new^.mode := OPM.VarPar END; + InStruct(new^.typ); new^.adr := OPM.SymRInt(); InName(new^.name); + last := new; tag := OPM.SymRInt() + END END InSign; PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *) -VAR tag: LONGINT; obj: Object; + VAR tag: LONGINT; obj: Object; BEGIN -tag := impCtxt.nextTag; obj := NewObj(); -IF tag <= Srfld THEN -obj^.mode := Fld; -IF tag = Srfld THEN obj^.vis := externalR ELSE obj^.vis := external END ; -InStruct(obj^.typ); InName(obj^.name); -obj^.adr := OPM.SymRInt() -ELSE -obj^.mode := Fld; -IF tag = Shdptr THEN obj^.name := OPM.HdPtrName ELSE obj^.name := OPM.HdProcName END ; -obj^.typ := undftyp; obj^.vis := internal; -obj^.adr := OPM.SymRInt() -END ; -RETURN obj + tag := impCtxt.nextTag; obj := NewObj(); + IF tag <= Srfld THEN + obj^.mode := OPM.Fld; + IF tag = Srfld THEN obj^.vis := OPM.externalR ELSE obj^.vis := OPM.external END; + InStruct(obj^.typ); InName(obj^.name); + obj^.adr := OPM.SymRInt() + ELSE + obj^.mode := OPM.Fld; + IF tag = Shdptr THEN obj^.name := OPM.HdPtrName ELSE obj^.name := OPM.HdProcName END; + obj^.typ := undftyp; obj^.vis := OPM.internal; + obj^.adr := OPM.SymRInt() + END; + RETURN obj END InFld; PROCEDURE InTProc(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) -VAR tag: LONGINT; obj: Object; + VAR tag: LONGINT; obj: Object; BEGIN -tag := impCtxt.nextTag; -obj := NewObj(); obj^.mnolev := -mno; -IF tag = Stpro THEN -obj^.mode := TProc; obj^.conval := NewConst(); obj^.conval^.intval := -1; -InSign(mno, obj^.typ, obj^.link); obj^.vis := external; InName(obj^.name); -obj^.adr := 10000H*OPM.SymRInt() -ELSE (* tag = Shdtpro *) -obj^.mode := TProc; obj^.name := OPM.HdTProcName; -obj^.link := NewObj(); (* dummy, easier in Browser *) -obj^.typ := undftyp; obj^.vis := internal; -obj^.adr := 10000H*OPM.SymRInt() -END ; -RETURN obj + tag := impCtxt.nextTag; + obj := NewObj(); obj^.mnolev := -mno; + IF tag = Stpro THEN + obj^.mode := OPM.TProc; obj^.conval := NewConst(); obj^.conval^.intval := -1; + InSign(mno, obj^.typ, obj^.link); obj^.vis := OPM.external; InName(obj^.name); + obj^.adr := 10000H*OPM.SymRInt() + ELSE (* tag = Shdtpro *) + obj^.mode := OPM.TProc; obj^.name := OPM.HdTProcName; + obj^.link := NewObj(); (* dummy, easier in Browser *) + obj^.typ := undftyp; obj^.vis := OPM.internal; + obj^.adr := 10000H*OPM.SymRInt() + END; + RETURN obj END InTProc; PROCEDURE InStruct(VAR typ: Struct); -VAR mno: SHORTINT; ref: INTEGER; tag: LONGINT; name: OPS.Name; -t: Struct; obj, last, fld, old, dummy: Object; + VAR mno: SHORTINT; ref: INTEGER; tag: LONGINT; name: OPS.Name; + t: Struct; obj, last, fld, old, dummy: Object; BEGIN - tag := OPM.SymRInt(); - IF tag # Sstruct THEN - typ := impCtxt.ref[-tag] - ELSE - ref := impCtxt.nofr; INC(impCtxt.nofr); - IF ref < impCtxt.minr THEN impCtxt.minr := ref END ; - InMod(mno); InName(name); obj := NewObj(); - IF name = "" THEN - IF impCtxt.self THEN - old := NIL (* do not insert type desc anchor here, but in OPL *) - ELSE - obj^.name := "@"; InsertImport(obj, GlbMod[mno].right, old(*=NIL*)); obj^.name := "" - END ; - typ := NewStr(Undef, Basic) - ELSE - obj^.name := name; InsertImport(obj, GlbMod[mno].right, old); - IF old # NIL THEN (* recalculate fprints to compare with old fprints *) - FPrintObj(old); impCtxt.pvfp[ref] := old^.typ^.pvfp; - IF impCtxt.self THEN (* do not overwrite old typ *) - typ := NewStr(Undef, Basic) - ELSE (* overwrite old typ for compatibility reason *) - typ := old^.typ; typ^.link := NIL; typ^.sysflag := 0; - typ^.fpdone := FALSE; typ^.idfpdone := FALSE - END - ELSE - typ := NewStr(Undef, Basic) - END - END ; - impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; - typ^.ref := ref + maxStruct; - (* ref >= maxStruct: not exported yet, ref used for err 155 *) - typ^.mno := mno; typ^.allocated := TRUE; - typ^.strobj := obj; obj^.mode := Typ; obj^.typ := typ; - obj^.mnolev := -mno; obj^.vis := internal; (* name not visible here *) - tag := OPM.SymRInt(); - IF tag = Ssys THEN typ^.sysflag := SHORT(OPM.SymRInt()); tag := OPM.SymRInt() END ; - CASE tag OF - | Sptr: - typ^.form := Pointer; typ^.size := OPM.PointerSize; - typ^.n := 0; InStruct(typ^.BaseTyp) - | Sarr: - typ^.form := Comp; typ^.comp := Array; - InStruct(typ^.BaseTyp); typ^.n := OPM.SymRInt(); - typSize(typ) (* no bounds address !! *) - | Sdarr: - typ^.form := Comp; typ^.comp := DynArr; InStruct(typ^.BaseTyp); - IF typ^.BaseTyp^.comp = DynArr THEN - typ^.n := typ^.BaseTyp^.n + 1 - ELSE - typ^.n := 0 - END ; - typSize(typ) - | Srec: - typ^.form := Comp; typ^.comp := Record; - InStruct(typ^.BaseTyp); - IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL END; - typ.extlev := 0; t := typ.BaseTyp; - (* do not take extlev from base type due to possible cycles! *) - WHILE (t # NIL) (*& (t^.BaseTyp # t)*)(*(t^.(*BaseTyp^.*)form # 0)*) DO INC(typ^.extlev); t := t.BaseTyp END; (* !!! *) - typ^.size := OPM.SymRInt(); typ^.align := OPM.SymRInt(); - typ^.n := OPM.SymRInt(); - impCtxt.nextTag := OPM.SymRInt(); last := NIL; - WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) DO - fld := InFld(); fld^.mnolev := -mno; - IF last # NIL THEN last^.link := fld END ; - last := fld; InsertImport(fld, typ^.link, dummy); - impCtxt.nextTag := OPM.SymRInt() - END ; - WHILE impCtxt.nextTag # Send DO - fld := InTProc(mno); - InsertImport(fld, typ^.link, dummy); - impCtxt.nextTag := OPM.SymRInt() - END - | Spro: - typ^.form := ProcTyp; typ^.size := OPM.ProcSize; - InSign(mno, typ^.BaseTyp, typ^.link) - ELSE - OPM.LogWStr("unhandled case at OPT.InStruct, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; -END ; - IF ref = impCtxt.minr THEN - WHILE (ref < impCtxt.nofr) (*OR ((ref >= Int8) & (ref <= Int64))*) DO - t := impCtxt.ref[ref]; FPrintStr(t); - obj := t^.strobj; (* obj^.typ^.strobj = obj, else obj^.fprint differs (alias) *) - IF obj^.name # "" THEN FPrintObj(obj) END ; - old := impCtxt.old[ref]; - IF old # NIL THEN - t^.strobj := old; (* restore strobj *) - IF impCtxt.self THEN - IF old^.mnolev < 0 THEN - IF old^.history # inconsistent THEN - IF old^.fprint # obj^.fprint THEN - old^.history := pbmodified - ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := pvmodified - END - (* ELSE remain inconsistent *) - END - ELSIF old^.fprint # obj^.fprint THEN - old^.history := pbmodified - ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := pvmodified - ELSIF old^.vis = internal THEN - old^.history := same (* may be changed to "removed" in InObj *) - ELSE - old^.history := inserted (* may be changed to "same" in InObj *) - END - ELSE - (* check private part, delay error message until really used *) - IF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := inconsistent - END ; - IF old^.fprint # obj^.fprint THEN - FPrintErr(old, 249) - END - END - ELSIF impCtxt.self THEN - obj^.history := removed - ELSE - obj^.history := same - END ; - INC(ref) - END ; - impCtxt.minr := maxStruct - END - END -END InStruct; - - PROCEDURE InObj(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) - VAR i, s: INTEGER; ch: CHAR; obj, old: Object; typ: Struct; - tag: LONGINT; ext: ConstExt; - BEGIN - tag := impCtxt.nextTag; - IF tag = Stype THEN - InStruct(typ); obj := typ^.strobj; - IF ~impCtxt.self THEN obj^.vis := external END (* type name visible now, obj^.fprint already done *) - ELSE - obj := NewObj(); obj^.mnolev := -mno; obj^.vis := external; - IF tag <= Pointer THEN (* Constant *) - obj^.mode := Con; obj^.typ := impCtxt.ref[tag]; obj^.conval := NewConst(); InConstant(tag, obj^.conval) - ELSIF tag >= Sxpro THEN - obj^.conval := NewConst(); - obj^.conval^.intval := -1; - InSign(mno, obj^.typ, obj^.link); - CASE tag OF - | Sxpro: obj^.mode := XProc - | Sipro: obj^.mode := IProc - | Scpro: obj^.mode := CProc; - ext := NewExt(); obj^.conval^.ext := ext; - s := SHORT(OPM.SymRInt()); ext^[0] := CHR(s); i := 1; - WHILE i <= s DO OPM.SymRCh(ext^[i]); INC(i) END + tag := OPM.SymRInt(); + IF tag # Sstruct THEN + typ := impCtxt.ref[-tag] ELSE - OPM.LogWStr("unhandled case at OPT.InObj, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; - END - ELSIF tag = Salias THEN - obj^.mode := Typ; InStruct(obj^.typ) - ELSE - obj^.mode := Var; - IF tag = Srvar THEN obj^.vis := externalR END ; - InStruct(obj^.typ) - END ; - InName(obj^.name) - END ; - FPrintObj(obj); - IF (obj^.mode = Var) & ((obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "")) THEN - (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) - OPM.FPrint(impCtxt.reffp, obj^.typ^.ref - maxStruct) - END ; - IF tag # Stype THEN - InsertImport(obj, GlbMod[mno].right, old); + ref := impCtxt.nofr; INC(impCtxt.nofr); + IF ref < impCtxt.minr THEN impCtxt.minr := ref END; + InMod(mno); InName(name); obj := NewObj(); + IF name = "" THEN IF impCtxt.self THEN + old := NIL (* do not insert type desc anchor here, but in OPL *) + ELSE + obj^.name := "@"; InsertImport(obj, GlbMod[mno].right, old(*=NIL*)); obj^.name := "" + END; + typ := NewStr(OPM.Undef, OPM.Basic) + ELSE + obj^.name := name; InsertImport(obj, GlbMod[mno].right, old); + IF old # NIL THEN (* recalculate fprints to compare with old fprints *) + FPrintObj(old); impCtxt.pvfp[ref] := old^.typ^.pvfp; + IF impCtxt.self THEN (* do not overwrite old typ *) + typ := NewStr(OPM.Undef, OPM.Basic) + ELSE (* overwrite old typ for compatibility reason *) + typ := old^.typ; typ^.link := NIL; typ^.sysflag := 0; + typ^.fpdone := FALSE; typ^.idfpdone := FALSE + END + ELSE + typ := NewStr(OPM.Undef, OPM.Basic) + END + END; + impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; + typ^.ref := ref + maxStruct; + (* ref >= maxStruct: not exported yet, ref used for err 155 *) + typ^.mno := mno; typ^.allocated := TRUE; + typ^.strobj := obj; obj^.mode := OPM.Typ; obj^.typ := typ; + obj^.mnolev := -mno; obj^.vis := OPM.internal; (* name not visible here *) + tag := OPM.SymRInt(); + IF tag = Ssys THEN typ^.sysflag := SHORT(OPM.SymRInt()); tag := OPM.SymRInt() END; + CASE tag OF + | Sptr: typ^.form := OPM.Pointer; typ^.size := OPM.PointerSize; + typ^.n := 0; InStruct(typ^.BaseTyp) + | Sarr: typ^.form := OPM.Comp; typ^.comp := OPM.Array; + InStruct(typ^.BaseTyp); typ^.n := OPM.SymRInt(); + typSize(typ) (* no bounds address !! *) + | Sdarr: typ^.form := OPM.Comp; typ^.comp := OPM.DynArr; InStruct(typ^.BaseTyp); + IF typ^.BaseTyp^.comp = OPM.DynArr THEN + typ^.n := typ^.BaseTyp^.n + 1 + ELSE + typ^.n := 0 + END; + typSize(typ) + | Srec: typ^.form := OPM.Comp; typ^.comp := OPM.Record; + InStruct(typ^.BaseTyp); + IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL END; + typ.extlev := 0; t := typ.BaseTyp; + (* do not take extlev from base type due to possible cycles! *) + WHILE (t # NIL) (*& (t^.BaseTyp # t)*)(*(t^.(*BaseTyp^.*)form # 0)*) DO + INC(typ^.extlev); t := t.BaseTyp + END; (* !!! *) + typ^.size := OPM.SymRInt(); typ^.align := OPM.SymRInt(); + typ^.n := OPM.SymRInt(); + impCtxt.nextTag := OPM.SymRInt(); last := NIL; + WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) DO + fld := InFld(); fld^.mnolev := -mno; + IF last # NIL THEN last^.link := fld END; + last := fld; InsertImport(fld, typ^.link, dummy); + impCtxt.nextTag := OPM.SymRInt() + END; + WHILE impCtxt.nextTag # Send DO + fld := InTProc(mno); + InsertImport(fld, typ^.link, dummy); + impCtxt.nextTag := OPM.SymRInt() + END + | Spro: typ^.form := OPM.ProcTyp; typ^.size := OPM.ProcSize; + InSign(mno, typ^.BaseTyp, typ^.link) + ELSE OPM.LogWStr("unhandled case at OPT.InStruct, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; + END; + IF ref = impCtxt.minr THEN + WHILE (ref < impCtxt.nofr) (*OR ((ref >= Int8) & (ref <= Int64))*) DO + t := impCtxt.ref[ref]; FPrintStr(t); + obj := t^.strobj; (* obj^.typ^.strobj = obj, else obj^.fprint differs (alias) *) + IF obj^.name # "" THEN FPrintObj(obj) END; + old := impCtxt.old[ref]; IF old # NIL THEN - (* obj is from old symbol file, old is new declaration *) - IF old^.vis = internal THEN old^.history := removed - ELSE FPrintObj(old); (* FPrint(obj) already called *) - IF obj^.fprint # old^.fprint THEN old^.history := pbmodified - ELSIF obj^.typ^.pvfp # old^.typ^.pvfp THEN old^.history := pvmodified - ELSE old^.history := same + t^.strobj := old; (* restore strobj *) + IF impCtxt.self THEN + IF old^.mnolev < 0 THEN + IF old^.history # OPM.inconsistent THEN + IF old^.fprint # obj^.fprint THEN + old^.history := OPM.pbmodified + ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := OPM.pvmodified + END + (* ELSE remain OPM.inconsistent *) + END + ELSIF old^.fprint # obj^.fprint THEN + old^.history := OPM.pbmodified + ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := OPM.pvmodified + ELSIF old^.vis = OPM.internal THEN + old^.history := OPM.same (* may be changed to "OPM.removed" in InObj *) + ELSE + old^.history := OPM.inserted (* may be changed to "OPM.same" in InObj *) + END + ELSE + (* check private part, delay error message until really used *) + IF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := OPM.inconsistent + END; + IF old^.fprint # obj^.fprint THEN + FPrintErr(old, 249) END END - ELSE obj^.history := removed (* OutObj not called if mnolev < 0 *) - END - (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) - END - ELSE (* obj already inserted in InStruct *) - IF impCtxt.self THEN (* obj^.mnolev = 0 *) - IF obj^.vis = internal THEN obj^.history := removed - ELSIF obj^.history = inserted THEN obj^.history := same - END - (* ELSE OutObj not called for obj with mnolev < 0 *) - END - END ; - RETURN obj - END InObj; - - PROCEDURE Import*(aliasName: OPS.Name; VAR name: OPS.Name; VAR done: BOOLEAN); - VAR obj: Object; mno: SHORTINT; (* done used in Browser *) - BEGIN - IF name = "SYSTEM" THEN SYSimported := TRUE; - Insert(aliasName, obj); obj^.mode := Mod; obj^.mnolev := 0; obj^.scope := syslink; obj^.typ := notyp - ELSE - impCtxt.nofr := FirstRef(*Comp+1*); impCtxt.minr := maxStruct; impCtxt.nofm := 0; - impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; - OPM.OldSym(name, done); - IF done THEN - InMod(mno); - impCtxt.nextTag := OPM.SymRInt(); - WHILE ~OPM.eofSF() DO - obj := InObj(mno); impCtxt.nextTag := OPM.SymRInt() - END ; - Insert(aliasName, obj); - obj^.mode := Mod; obj^.scope := GlbMod[mno].right; - GlbMod[mno].link := obj; - obj^.mnolev := -mno; obj^.typ := notyp; - OPM.CloseOldSym - ELSIF impCtxt.self THEN - newsf := TRUE; extsf := TRUE; sfpresent := FALSE - ELSE err(152) (*sym file not found*) - END + ELSIF impCtxt.self THEN + obj^.history := OPM.removed + ELSE + obj^.history := OPM.same + END; + INC(ref) + END; + impCtxt.minr := maxStruct END - END Import; + END +END InStruct; + +PROCEDURE InObj(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) + VAR i, s: INTEGER; ch: CHAR; obj, old: Object; typ: Struct; + tag: LONGINT; ext: ConstExt; +BEGIN + tag := impCtxt.nextTag; + IF tag = Stype THEN + InStruct(typ); obj := typ^.strobj; + IF ~impCtxt.self THEN obj^.vis := OPM.external END (* type name visible now, obj^.fprint already done *) + ELSE + obj := NewObj(); obj^.mnolev := -mno; obj^.vis := OPM.external; + IF tag <= OPM.Pointer THEN (* Constant *) + obj^.mode := OPM.Con; obj^.typ := impCtxt.ref[tag]; obj^.conval := NewConst(); InConstant(tag, obj^.conval) + ELSIF tag >= Sxpro THEN + obj^.conval := NewConst(); + obj^.conval^.intval := -1; + InSign(mno, obj^.typ, obj^.link); + CASE tag OF + | Sxpro: obj^.mode := OPM.XProc + | Sipro: obj^.mode := OPM.IProc + | Scpro: obj^.mode := OPM.CProc; + ext := NewExt(); obj^.conval^.ext := ext; + s := SHORT(OPM.SymRInt()); ext^[0] := CHR(s); i := 1; + WHILE i <= s DO OPM.SymRCh(ext^[i]); INC(i) END + ELSE OPM.LogWStr("unhandled case at OPT.InObj, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; + END + ELSIF tag = Salias THEN + obj^.mode := OPM.Typ; InStruct(obj^.typ) + ELSE + obj^.mode := OPM.Var; + IF tag = Srvar THEN obj^.vis := OPM.externalR END; + InStruct(obj^.typ) + END; + InName(obj^.name) + END; + FPrintObj(obj); + IF (obj^.mode = OPM.Var) & ((obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "")) THEN + (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) + OPM.FPrint(impCtxt.reffp, obj^.typ^.ref - maxStruct) + END; + IF tag # Stype THEN + InsertImport(obj, GlbMod[mno].right, old); + IF impCtxt.self THEN + IF old # NIL THEN + (* obj is from old symbol file, old is new declaration *) + IF old^.vis = OPM.internal THEN old^.history := OPM.removed + ELSE FPrintObj(old); (* FPrint(obj) already called *) + IF obj^.fprint # old^.fprint THEN old^.history := OPM.pbmodified + ELSIF obj^.typ^.pvfp # old^.typ^.pvfp THEN old^.history := OPM.pvmodified + ELSE old^.history := OPM.same + END + END + ELSE obj^.history := OPM.removed (* OutObj not called if mnolev < 0 *) + END + (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) + END + ELSE (* obj already OPM.inserted in InStruct *) + IF impCtxt.self THEN (* obj^.mnolev = 0 *) + IF obj^.vis = OPM.internal THEN obj^.history := OPM.removed + ELSIF obj^.history = OPM.inserted THEN obj^.history := OPM.same + END + (* ELSE OutObj not called for obj with mnolev < 0 *) + END + END; +RETURN obj +END InObj; + +PROCEDURE Import*(aliasName: OPS.Name; VAR name: OPS.Name; VAR done: BOOLEAN); + VAR obj: Object; mno: SHORTINT; (* done used in Browser *) +BEGIN + IF name = "SYSTEM" THEN SYSimported := TRUE; + Insert(aliasName, obj); obj^.mode := OPM.Mod; obj^.mnolev := 0; obj^.scope := syslink; obj^.typ := notyp + ELSE + impCtxt.nofr := FirstRef(*Comp+1*); impCtxt.minr := maxStruct; impCtxt.nofm := 0; + impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; + OPM.OldSym(name, done); + IF done THEN + InMod(mno); + impCtxt.nextTag := OPM.SymRInt(); + WHILE ~OPM.eofSF() DO + obj := InObj(mno); impCtxt.nextTag := OPM.SymRInt() + END; + Insert(aliasName, obj); + obj^.mode := OPM.Mod; obj^.scope := GlbMod[mno].right; + GlbMod[mno].link := obj; + obj^.mnolev := -mno; obj^.typ := notyp; + OPM.CloseOldSym + ELSIF impCtxt.self THEN + newsf := TRUE; extsf := TRUE; sfpresent := FALSE + ELSE err(152) (*sym file not found*) + END + END +END Import; (*-------------------------- Export --------------------------*) @@ -874,10 +831,10 @@ END InStruct; PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: LONGINT); VAR i, j, n: LONGINT; btyp: Struct; BEGIN - IF typ^.comp = Record THEN OutFlds(typ^.link, adr, FALSE) - ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN + IF typ^.comp = OPM.Record THEN OutFlds(typ^.link, adr, FALSE) + ELSIF typ^.comp = OPM.Array THEN btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPM.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END; + IF (btyp^.form = OPM.Pointer) OR (btyp^.comp = OPM.Record) THEN j := nofhdfld; OutHdFld(btyp, fld, adr); IF j # nofhdfld THEN i := 1; WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO @@ -885,21 +842,21 @@ END InStruct; END END END - ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN + ELSIF OPM.ExpHdPtrFld & ((typ^.form = OPM.Pointer) OR (fld^.name = OPM.HdPtrName)) THEN OPM.SymWInt(Shdptr); OPM.SymWInt(adr); INC(nofhdfld) - ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN + ELSIF OPM.ExpHdProcFld & ((typ^.form = OPM.ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN OPM.SymWInt(Shdpro); OPM.SymWInt(adr); INC(nofhdfld) END END OutHdFld; PROCEDURE OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); BEGIN - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF (fld^.vis # internal) & visible THEN - IF fld^.vis = externalR THEN OPM.SymWInt(Srfld) ELSE OPM.SymWInt(Sfld) END ; + WHILE (fld # NIL) & (fld^.mode = OPM.Fld) DO + IF (fld^.vis # OPM.internal) & visible THEN + IF fld^.vis = OPM.externalR THEN OPM.SymWInt(Srfld) ELSE OPM.SymWInt(Sfld) END; OutStr(fld^.typ); OutName(fld^.name); OPM.SymWInt(fld^.adr) ELSE OutHdFld(fld^.typ, fld, fld^.adr + adr) - END ; + END; fld := fld^.link END END OutFlds; @@ -908,11 +865,11 @@ END InStruct; BEGIN OutStr(result); WHILE par # NIL DO - IF par^.mode = Var THEN OPM.SymWInt(Svalpar) ELSE OPM.SymWInt(Svarpar) END ; + IF par^.mode = OPM.Var THEN OPM.SymWInt(Svalpar) ELSE OPM.SymWInt(Svarpar) END; OutStr(par^.typ); OPM.SymWInt(par^.adr); OutName(par^.name); par := par^.link - END ; + END; OPM.SymWInt(Send) END OutSign; @@ -920,13 +877,13 @@ END InStruct; BEGIN IF obj # NIL THEN OutTProcs(typ, obj^.left); - IF obj^.mode = TProc THEN - IF (typ^.BaseTyp # NIL) & (obj^.adr DIV 10000H < typ^.BaseTyp^.n) & (obj^.vis = internal) THEN + IF obj^.mode = OPM.TProc THEN + IF (typ^.BaseTyp # NIL) & (obj^.adr DIV 10000H < typ^.BaseTyp^.n) & (obj^.vis = OPM.internal) THEN OPM.Mark(109, typ^.txtpos) (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *) - END ; - IF OPM.ExpHdTProc OR (obj^.vis # internal) THEN - IF obj^.vis # internal THEN + END; + IF OPM.ExpHdTProc OR (obj^.vis # OPM.internal) THEN + IF obj^.vis # OPM.internal THEN OPM.SymWInt(Stpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name); OPM.SymWInt(obj^.adr DIV 10000H) ELSE @@ -934,7 +891,7 @@ END InStruct; OPM.SymWInt(obj^.adr DIV 10000H) END END - END ; + END; OutTProcs(typ, obj^.right) END END OutTProcs; @@ -946,43 +903,36 @@ END InStruct; ELSE OPM.SymWInt(Sstruct); typ^.ref := expCtxt.ref; INC(expCtxt.ref); - IF expCtxt.ref >= maxStruct THEN err(228) END ; + IF expCtxt.ref >= maxStruct THEN err(228) END; OutMod(typ^.mno); strobj := typ^.strobj; IF (strobj # NIL) & (strobj^.name # "") THEN OutName(strobj^.name); CASE strobj^.history OF - | pbmodified: FPrintErr(strobj, 252) - | pvmodified: FPrintErr(strobj, 251) - | inconsistent: FPrintErr(strobj, 249) + | OPM.pbmodified: FPrintErr(strobj, 252) + | OPM.pvmodified: FPrintErr(strobj, 251) + | OPM.inconsistent: FPrintErr(strobj, 249) ELSE (* checked in OutObj or correct indirect export *) - (* OPM.LogWStr("unhandled case at OPT.OutStr, strobj^.history = "); OPM.LogWNum(strobj^.history, 0); OPM.LogWLn;*) + (* OPM.LogWStr("unhandled case at OPT.OutStr, strobj^.history = "); OPM.LogWNum(strobj^.history, 0); OPM.LogWLn;*) END - ELSE OPM.SymWCh(0X) (* anonymous => never inconsistent, pvfp influences the client fp *) - END ; - IF typ^.sysflag # 0 THEN OPM.SymWInt(Ssys); OPM.SymWInt(typ^.sysflag) END ; + ELSE OPM.SymWCh(0X) (* anonymous => never OPM.inconsistent, pvfp influences the client fp *) + END; + IF typ^.sysflag # 0 THEN OPM.SymWInt(Ssys); OPM.SymWInt(typ^.sysflag) END; CASE typ^.form OF - | Pointer: - OPM.SymWInt(Sptr); OutStr(typ^.BaseTyp) - | ProcTyp: - OPM.SymWInt(Spro); OutSign(typ^.BaseTyp, typ^.link) - | Comp: - CASE typ^.comp OF - | Array: - OPM.SymWInt(Sarr); OutStr(typ^.BaseTyp); OPM.SymWInt(typ^.n) - | DynArr: - OPM.SymWInt(Sdarr); OutStr(typ^.BaseTyp) - | Record: - OPM.SymWInt(Srec); - IF typ^.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ^.BaseTyp) END ; - (* BaseTyp should be Notyp, too late to change *) - OPM.SymWInt(typ^.size); OPM.SymWInt(typ^.align); OPM.SymWInt(typ^.n); - nofhdfld := 0; OutFlds(typ^.link, 0, TRUE); - IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(223, typ^.txtpos) END ; - OutTProcs(typ, typ^.link); OPM.SymWInt(Send) - ELSE - OPM.LogWStr("unhandled case at OPT.OutStr, typ^.comp = "); OPM.LogWNum(typ^.comp, 0); OPM.LogWLn; - END - ELSE OPM.LogWStr("unhandled case at OPT.OutStr, typ^.form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; + | OPM.Pointer: OPM.SymWInt(Sptr); OutStr(typ^.BaseTyp) + | OPM.ProcTyp: OPM.SymWInt(Spro); OutSign(typ^.BaseTyp, typ^.link) + | OPM.Comp: CASE typ^.comp OF + | OPM.Array: OPM.SymWInt(Sarr); OutStr(typ^.BaseTyp); OPM.SymWInt(typ^.n) + | OPM.DynArr: OPM.SymWInt(Sdarr); OutStr(typ^.BaseTyp) + | OPM.Record: OPM.SymWInt(Srec); + IF typ^.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ^.BaseTyp) END; + (* BaseTyp should be Notyp, too late to change *) + OPM.SymWInt(typ^.size); OPM.SymWInt(typ^.align); OPM.SymWInt(typ^.n); + nofhdfld := 0; OutFlds(typ^.link, 0, TRUE); + IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(223, typ^.txtpos) END; + OutTProcs(typ, typ^.link); OPM.SymWInt(Send) + ELSE OPM.LogWStr("unhandled case at OPT.OutStr, typ^.comp = "); OPM.LogWNum(typ^.comp, 0); OPM.LogWLn; + END + ELSE OPM.LogWStr("unhandled case at OPT.OutStr, typ^.form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; END END END OutStr; @@ -992,20 +942,17 @@ END InStruct; BEGIN f := obj^.typ^.form; OPM.SymWInt(f); CASE f OF - | Bool, Char: - OPM.SymWCh(CHR(obj^.conval^.intval)) - | SInt, Int, LInt(*, Int8, Int16, Int32, Int64*): - OPM.SymWInt(obj^.conval^.intval) - | Set: - OPM.SymWSet(obj^.conval^.setval) - | Real: - rval := SHORT(obj^.conval^.realval); OPM.SymWReal(rval) - | LReal: - OPM.SymWLReal(obj^.conval^.realval) - | String: - OutName(obj^.conval^.ext^) - | NilTyp: - ELSE err(127) + | OPM.Bool, + OPM.Char: OPM.SymWCh(CHR(obj^.conval^.intval)) + | OPM.SInt, + OPM.Int, + OPM.LInt: OPM.SymWInt(obj^.conval^.intval) + | OPM.Set: OPM.SymWSet(obj^.conval^.setval) + | OPM.Real: rval := SHORT(obj^.conval^.realval); OPM.SymWReal(rval) + | OPM.LReal: OPM.SymWLReal(obj^.conval^.realval) + | OPM.String: OutName(obj^.conval^.ext^) + | OPM.NilTyp: + ELSE err(127) END END OutConstant; @@ -1014,51 +961,43 @@ END InStruct; BEGIN IF obj # NIL THEN OutObj(obj^.left); - IF obj^.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN - IF obj^.history = removed THEN FPrintErr(obj, 250) - ELSIF obj^.vis # internal THEN + IF obj^.mode IN {OPM.Con, OPM.Typ, OPM.Var, OPM.LProc, OPM.XProc, OPM.CProc, OPM.IProc} THEN + IF obj^.history = OPM.removed THEN FPrintErr(obj, 250) + ELSIF obj^.vis # OPM.internal THEN CASE obj^.history OF - | inserted: FPrintErr(obj, 253) - | same: (* ok *) - | pbmodified: FPrintErr(obj, 252) - | pvmodified: FPrintErr(obj, 251) - ELSE - OPM.LogWStr("unhandled case at OPT.OutObj, obj^.history = "); OPM.LogWNum(obj^.history, 0); OPM.LogWLn; - END ; + | OPM.inserted: FPrintErr(obj, 253) + | OPM.same: (* ok *) + | OPM.pbmodified: FPrintErr(obj, 252) + | OPM.pvmodified: FPrintErr(obj, 251) + ELSE OPM.LogWStr("unhandled case at OPT.OutObj, obj^.history = "); OPM.LogWNum(obj^.history, 0); OPM.LogWLn; + END; CASE obj^.mode OF - | Con: - OutConstant(obj); OutName(obj^.name) - | Typ: - IF obj^.typ^.strobj = obj THEN OPM.SymWInt(Stype); OutStr(obj^.typ) - ELSE OPM.SymWInt(Salias); OutStr(obj^.typ); OutName(obj^.name) - END - | Var: - IF obj^.vis = externalR THEN OPM.SymWInt(Srvar) ELSE OPM.SymWInt(Svar) END ; - OutStr(obj^.typ); OutName(obj^.name); - IF (obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "") THEN - (* compute fingerprint to avoid structural type equivalence *) - OPM.FPrint(expCtxt.reffp, obj^.typ^.ref) - END - | XProc: - OPM.SymWInt(Sxpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) - | IProc: - OPM.SymWInt(Sipro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) - | CProc: - OPM.SymWInt(Scpro); OutSign(obj^.typ, obj^.link); ext := obj^.conval^.ext; - j := ORD(ext^[0]); i := 1; OPM.SymWInt(j); - WHILE i <= j DO OPM.SymWCh(ext^[i]); INC(i) END ; - OutName(obj^.name) - ELSE - OPM.LogWStr("unhandled case at OPT.OutObj, obj.mode = "); OPM.LogWNum(obj.mode, 0); OPM.LogWLn; + | OPM.Con: OutConstant(obj); OutName(obj^.name) + | OPM.Typ: IF obj^.typ^.strobj = obj THEN OPM.SymWInt(Stype); OutStr(obj^.typ) + ELSE OPM.SymWInt(Salias); OutStr(obj^.typ); OutName(obj^.name) + END + | OPM.Var: IF obj^.vis = OPM.externalR THEN OPM.SymWInt(Srvar) ELSE OPM.SymWInt(Svar) END; + OutStr(obj^.typ); OutName(obj^.name); + IF (obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "") THEN + (* compute fingerprint to avoid structural type equivalence *) + OPM.FPrint(expCtxt.reffp, obj^.typ^.ref) + END + | OPM.XProc: OPM.SymWInt(Sxpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) + | OPM.IProc: OPM.SymWInt(Sipro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) + | OPM.CProc: OPM.SymWInt(Scpro); OutSign(obj^.typ, obj^.link); ext := obj^.conval^.ext; + j := ORD(ext^[0]); i := 1; OPM.SymWInt(j); + WHILE i <= j DO OPM.SymWCh(ext^[i]); INC(i) END; + OutName(obj^.name) + ELSE OPM.LogWStr("unhandled case at OPT.OutObj, obj.mode = "); OPM.LogWNum(obj.mode, 0); OPM.LogWLn; END END - END ; + END; OutObj(obj^.right) END END OutObj; PROCEDURE Export*(VAR ext, new: BOOLEAN); - VAR i: INTEGER; nofmod: SHORTINT; done: BOOLEAN; + VAR i: INTEGER; nofmod: SHORTINT; done: BOOLEAN; BEGIN symExtended := FALSE; symNew := FALSE; nofmod := nofGmod; Import("@self", SelfName, done); nofGmod := nofmod; @@ -1068,20 +1007,20 @@ END InStruct; OPM.SymWInt(Smname); OutName(SelfName); expCtxt.reffp := 0; expCtxt.ref := FirstRef(*Comp+1*); expCtxt.nofm := 1; expCtxt.locmno[0] := 0; - i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ; + i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END; OutObj(topScope^.right); ext := sfpresent & symExtended; new := ~sfpresent OR symNew; - IF OPM.forceNewSym THEN - new := TRUE - END; (* for bootstrapping -- noch *) + IF OPM.forceNewSym THEN + new := TRUE + END; (* for bootstrapping -- noch *) IF OPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN new := TRUE; IF ~extsf THEN err(155) END - END ; + END; newsf := FALSE; symNew := FALSE; (* because of call to FPrintErr from OPL *) IF ~OPM.noerr OR findpc THEN - OPM.DeleteNewSym - END + OPM.DeleteNewSym + END (* OPM.RegisterNewSym is called in OP2 after writing the object file *) END END @@ -1090,7 +1029,7 @@ END InStruct; PROCEDURE InitStruct(VAR typ: Struct; form: SHORTINT); BEGIN - typ := NewStr(form, Basic); typ^.ref := form; typ^.size := OPM.ByteSize; typ^.allocated := TRUE; + typ := NewStr(form, OPM.Basic); typ^.ref := form; typ^.size := OPM.ByteSize; typ^.allocated := TRUE; typ^.strobj := NewObj(); typ^.pbfp := form; typ^.pvfp := form; typ^.fpdone := TRUE; typ^.idfp := form; typ^.idfpdone := TRUE END InitStruct; @@ -1099,14 +1038,14 @@ END InStruct; VAR obj: Object; BEGIN Insert(name, obj); obj^.conval := NewConst(); - obj^.mode := Con; obj^.typ := booltyp; obj^.conval^.intval := value + obj^.mode := OPM.Con; obj^.typ := booltyp; obj^.conval^.intval := value END EnterBoolConst; PROCEDURE EnterTyp(name: OPS.Name; form: SHORTINT; size: INTEGER; VAR res: Struct); VAR obj: Object; typ: Struct; BEGIN Insert(name, obj); - typ := NewStr(form, Basic); obj^.mode := Typ; obj^.typ := typ; obj^.vis := external; + typ := NewStr(form, OPM.Basic); obj^.mode := OPM.Typ; obj^.typ := typ; obj^.vis := OPM.external; typ^.strobj := obj; typ^.size := size; typ^.ref := form; typ^.allocated := TRUE; typ^.pbfp := form; typ^.pvfp := form; typ^.fpdone := TRUE; typ^.idfp := form; typ^.idfpdone := TRUE; res := typ @@ -1115,78 +1054,80 @@ END InStruct; PROCEDURE EnterProc(name: OPS.Name; num: INTEGER); VAR obj: Object; BEGIN Insert(name, obj); - obj^.mode := SProc; obj^.typ := notyp; obj^.adr := num + obj^.mode := OPM.SProc; obj^.typ := notyp; obj^.adr := num END EnterProc; BEGIN topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0; - InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp); - InitStruct(stringtyp, String); InitStruct(niltyp, NilTyp); + InitStruct(undftyp, OPM.Undef); InitStruct(notyp, OPM.NoTyp); + InitStruct(stringtyp, OPM.String); InitStruct(niltyp, OPM.NilTyp); undftyp^.BaseTyp := undftyp; (*initialization of module SYSTEM*) - EnterTyp("BYTE", Byte, OPM.ByteSize, bytetyp); -(* - EnterTyp("INT8", Int8, OPM.Int8Size, int8typ); - EnterTyp("INT16", Int16, OPM.Int16Size, int16typ); - EnterTyp("INT32", Int32, OPM.Int32Size, int32typ); - EnterTyp("INT64", Int64, OPM.Int64Size, int64typ); -*) - EnterTyp("PTR", Pointer, OPM.PointerSize, sysptrtyp); - EnterProc("ADR", adrfn); - EnterProc("CC", ccfn); - EnterProc("LSH", lshfn); - EnterProc("ROT", rotfn); - EnterProc("GET", getfn); - EnterProc("PUT", putfn); - EnterProc("GETREG", getrfn); - EnterProc("PUTREG", putrfn); - EnterProc("BIT", bitfn); - EnterProc("VAL", valfn); - EnterProc("NEW", sysnewfn); - EnterProc("MOVE", movefn); + EnterTyp("BYTE", OPM.Byte, OPM.ByteSize, bytetyp); + EnterTyp("PTR", OPM.Pointer, OPM.PointerSize, sysptrtyp); + EnterProc("ADR", OPM.adrfn); + EnterProc("CC", OPM.ccfn); + EnterProc("LSH", OPM.lshfn); + EnterProc("ROT", OPM.rotfn); + EnterProc("GET", OPM.getfn); + EnterProc("PUT", OPM.putfn); + EnterProc("GETREG", OPM.getrfn); + EnterProc("PUTREG", OPM.putrfn); + EnterProc("BIT", OPM.bitfn); + EnterProc("VAL", OPM.valfn); + EnterProc("NEW", OPM.sysnewfn); + EnterProc("MOVE", OPM.movefn); syslink := topScope^.right; universe := topScope; topScope^.right := NIL; - EnterTyp("CHAR", Char, OPM.CharSize, chartyp); - EnterTyp("SET", Set, OPM.SetSize, settyp); - EnterTyp("REAL", Real, OPM.RealSize, realtyp); - EnterTyp("INTEGER", Int, OPM.IntSize, inttyp); - EnterTyp("LONGINT", LInt, OPM.LIntSize, linttyp); - EnterTyp("LONGREAL", LReal, OPM.LRealSize, lrltyp); - EnterTyp("SHORTINT", SInt, OPM.SIntSize, sinttyp); - EnterTyp("BOOLEAN", Bool, OPM.BoolSize, booltyp); - EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *) + EnterTyp("BOOLEAN", OPM.Bool, OPM.BoolSize, booltyp); + EnterTyp("CHAR", OPM.Char, OPM.CharSize, chartyp); + EnterTyp("SET", OPM.Set, OPM.SetSize, settyp); + EnterTyp("REAL", OPM.Real, OPM.RealSize, realtyp); + EnterTyp("INTEGER", OPM.Int, OPM.IntSize, inttyp); + EnterTyp("LONGINT", OPM.LInt, OPM.LIntSize, linttyp); + EnterTyp("LONGREAL", OPM.LReal, OPM.LRealSize, lrltyp); + EnterTyp("SHORTINT", OPM.SInt, OPM.SIntSize, sinttyp); + + EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler OPM.internal representation only *) EnterBoolConst("TRUE", 1); - EnterProc("HALT", haltfn); - EnterProc("NEW", newfn); - EnterProc("ABS", absfn); - EnterProc("CAP", capfn); - EnterProc("ORD", ordfn); - EnterProc("ENTIER", entierfn); - EnterProc("ODD", oddfn); - EnterProc("MIN", minfn); - EnterProc("MAX", maxfn); - EnterProc("CHR", chrfn); - EnterProc("SHORT", shortfn); - EnterProc("LONG", longfn); - EnterProc("SIZE", sizefn); - EnterProc("INC", incfn); - EnterProc("DEC", decfn); - EnterProc("INCL", inclfn); - EnterProc("EXCL", exclfn); - EnterProc("LEN", lenfn); - EnterProc("COPY", copyfn); - EnterProc("ASH", ashfn); - EnterProc("ASSERT", assertfn); - impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp; -(* impCtxt.ref[Int8] := int8typ; impCtxt.ref[Int16] := int16typ; - impCtxt.ref[Int32] := int32typ; impCtxt.ref[Int64] := int64typ;*) - impCtxt.ref[Bool] := booltyp; impCtxt.ref[Char] := chartyp; - impCtxt.ref[SInt] := sinttyp; impCtxt.ref[Int] := inttyp; - impCtxt.ref[LInt] := linttyp; impCtxt.ref[Real] := realtyp; - impCtxt.ref[LReal] := lrltyp; impCtxt.ref[Set] := settyp; - impCtxt.ref[String] := stringtyp; impCtxt.ref[NilTyp] := niltyp; - impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp + + EnterProc("HALT", OPM.haltfn); + EnterProc("NEW", OPM.newfn); + EnterProc("ABS", OPM.absfn); + EnterProc("CAP", OPM.capfn); + EnterProc("ORD", OPM.ordfn); + EnterProc("ENTIER", OPM.entierfn); + EnterProc("ODD", OPM.oddfn); + EnterProc("MIN", OPM.minfn); + EnterProc("MAX", OPM.maxfn); + EnterProc("CHR", OPM.chrfn); + EnterProc("SHORT", OPM.shortfn); + EnterProc("LONG", OPM.longfn); + EnterProc("SIZE", OPM.sizefn); + EnterProc("INC", OPM.incfn); + EnterProc("DEC", OPM.decfn); + EnterProc("INCL", OPM.inclfn); + EnterProc("EXCL", OPM.exclfn); + EnterProc("LEN", OPM.lenfn); + EnterProc("COPY", OPM.copyfn); + EnterProc("ASH", OPM.ashfn); + EnterProc("ASSERT", OPM.assertfn); + + impCtxt.ref[OPM.Undef] := undftyp; + impCtxt.ref[OPM.Byte] := bytetyp; + impCtxt.ref[OPM.Bool] := booltyp; + impCtxt.ref[OPM.Char] := chartyp; + impCtxt.ref[OPM.SInt] := sinttyp; + impCtxt.ref[OPM.Int] := inttyp; + impCtxt.ref[OPM.LInt] := linttyp; + impCtxt.ref[OPM.Real] := realtyp; + impCtxt.ref[OPM.LReal] := lrltyp; + impCtxt.ref[OPM.Set] := settyp; + impCtxt.ref[OPM.String] := stringtyp; + impCtxt.ref[OPM.NilTyp] := niltyp; + impCtxt.ref[OPM.NoTyp] := notyp; + impCtxt.ref[OPM.Pointer] := sysptrtyp END OPT. Objects: @@ -1219,6 +1160,7 @@ Objects: SInt Basic | Int Basic | LInt Basic | + XInt Basic | bits Real Basic | LReal Basic | Set Basic | @@ -1332,4 +1274,3 @@ stat NIL Nreturn proc nextexpr stat (proc = NIL for mod) Nwith ifstat stat stat Ntrap expr stat - diff --git a/src/compiler/OPV.Mod b/src/compiler/OPV.Mod index 702055f9..8cb7096e 100644 --- a/src/compiler/OPV.Mod +++ b/src/compiler/OPV.Mod @@ -1,6 +1,6 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 - 26.7.2002 jt bug fix in Len: wrong result if called for fixed Array + 26.7.2002 jt bug fix OPM.in Len: wrong result if called for fixed OPM.Array 31.1.2007 jt synchronized with BlackBox version, in particular: various promotion rules changed (long) => (LONGINT), xxxL avoided *) @@ -8,55 +8,6 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 IMPORT OPT, OPC, OPM, OPS; CONST - (* object modes *) - Var = 1; VarPar = 2; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - CProc = 9; IProc = 10; Mod = 11; TProc = 13; - - (* symbol values or ops *) - times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; ash = 17; msk = 18; len = 19; - conv = 20; abs = 21; cap = 22; odd = 23; not = 33; - (*SYSTEM*) - adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; - - (* structure forms *) - Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - (* composite structure forms *) - Array = 2; DynArr = 3; Record = 4; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nenter = 18; Nassign = 19; - Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (*function number*) - assign = 0; newfn = 1; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; - - (*SYSTEM function number*) - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; - - (*procedure flags*) - isRedef = 2; - - super = 1; - UndefinedType = 0; (* named type not yet defined *) ProcessingType = 1; (* pointer type is being processed *) PredefinedType = 2; (* for all predefined types *) @@ -91,7 +42,6 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 MaxPrec = 12; ProcTypeVar = 11; (* precedence number when a call is made with a proc type variable *) - internal = 0; TYPE ExitInfo = RECORD level, label: INTEGER END ; @@ -125,12 +75,12 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 IF typ = OPT.undftyp THEN OPM.err(58) ELSIF typ^.size = -1 THEN f := typ^.form; c := typ^.comp; - IF c = Record THEN btyp := typ^.BaseTyp; + IF c = OPM.Record THEN btyp := typ^.BaseTyp; IF btyp = NIL THEN offset := 0; base := OPM.RecAlign; ELSE TypSize(btyp); offset := btyp^.size - btyp^.sysflag DIV 100H; base := btyp^.align; END; fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO + WHILE (fld # NIL) & (fld^.mode = OPM.Fld) DO btyp := fld^.typ; TypSize(btyp); size := btyp^.size; fbase := OPC.Base(btyp); OPC.Align(offset, fbase); @@ -146,19 +96,19 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 typ^.size := offset; typ^.align := base; (* encode the trailing gap into the symbol table to allow dense packing of extended records *) typ^.sysflag := typ^.sysflag MOD 100H + SHORT((offset - off0)*100H) - ELSIF c = Array THEN + ELSIF c = OPM.Array THEN TypSize(typ^.BaseTyp); typ^.size := typ^.n * typ^.BaseTyp^.size; - ELSIF f = Pointer THEN + ELSIF f = OPM.Pointer THEN typ^.size := OPM.PointerSize; IF typ^.BaseTyp = OPT.undftyp THEN OPM.Mark(128, typ^.n) ELSE TypSize(typ^.BaseTyp) END - ELSIF f = ProcTyp THEN + ELSIF f = OPM.ProcTyp THEN typ^.size := OPM.ProcSize; - ELSIF c = DynArr THEN + ELSIF c = OPM.DynArr THEN btyp := typ^.BaseTyp; TypSize(btyp); - IF btyp^.comp = DynArr THEN typ^.size := btyp^.size + 4 (* describes dim not size *) + IF btyp^.comp = OPM.DynArr THEN typ^.size := btyp^.size + 4 (* describes dim not size *) ELSE typ^.size := 8 END END @@ -181,10 +131,10 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 BEGIN oldPos := OPM.errpos; OPM.errpos := obj^.scope^.adr; typ := obj^.link^.typ; - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.form = OPM.Pointer THEN typ := typ^.BaseTyp END ; OPT.FindField(obj^.name, typ^.BaseTyp, redef); IF redef # NIL THEN obj^.adr := 10000H*(redef^.adr DIV 10000H) (*mthno*); - IF ~(isRedef IN obj^.conval^.setval) THEN OPM.err(119) END + IF ~(OPM.isRedef IN obj^.conval^.setval) THEN OPM.err(119) END ELSE INC(obj^.adr, 10000H*typ^.n); INC(typ^.n) END ; OPM.errpos := oldPos @@ -218,23 +168,23 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 IF obj^.name[0] = "@" THEN obj^.name[0] := "_"; Stamp(obj^.name) END ; (* translate and make unique @for, ... *) obj^.linkadr := UndefinedType; mode := obj^.mode; - IF (mode = Typ) & ((obj^.vis # internal) = exported) THEN + IF (mode = OPM.Typ) & ((obj^.vis # OPM.internal) = exported) THEN typ := obj^.typ; TypSize(obj^.typ); - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - IF typ^.comp = Record THEN TraverseRecord(typ) END - ELSIF mode = TProc THEN GetTProcNum(obj) - ELSIF mode = Var THEN TypSize(obj^.typ) + IF typ^.form = OPM.Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.comp = OPM.Record THEN TraverseRecord(typ) END + ELSIF mode = OPM.TProc THEN GetTProcNum(obj) + ELSIF mode = OPM.Var THEN TypSize(obj^.typ) END ; IF ~exported THEN (* do this only once *) - IF (mode IN {LProc, Typ}) & (obj^.mnolev > 0) THEN Stamp(obj^.name) END ; - IF mode IN {Var, VarPar, Typ} THEN + IF (mode IN {OPM.LProc, OPM.Typ}) & (obj^.mnolev > 0) THEN Stamp(obj^.name) END ; + IF mode IN {OPM.Var, OPM.VarPar, OPM.Typ} THEN obj^.scope := outerScope - ELSIF mode IN {LProc, XProc, TProc, CProc, IProc} THEN + ELSIF mode IN {OPM.LProc, OPM.XProc, OPM.TProc, OPM.CProc, OPM.IProc} THEN IF obj^.conval^.setval = {} THEN OPM.err(129) END ; scope := obj^.scope; scope^.leaf := TRUE; scope^.name := obj^.name; Stamp(scope^.name); - IF mode = CProc THEN obj^.adr := 1 (* c.f. OPC.CProcDefs *) END ; + IF mode = OPM.CProc THEN obj^.adr := 1 (* c.f. OPC.CProcDefs *) END ; IF scope^.mnolev > 1 THEN outerScope^.leaf := FALSE END ; Traverse (obj^.scope^.right, obj^.scope, FALSE) END @@ -250,19 +200,15 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 Traverse(topScope^.right, topScope, TRUE); (* first pass only on exported types and procedures *) Traverse(topScope^.right, topScope, FALSE); (* second pass *) (* mark basic types as predefined, OPC.Ident can avoid qualification*) - OPT.chartyp^.strobj^.linkadr := PredefinedType; - OPT.settyp^.strobj^.linkadr := PredefinedType; - OPT.realtyp^.strobj^.linkadr := PredefinedType; - OPT.inttyp^.strobj^.linkadr := PredefinedType; - OPT.linttyp^.strobj^.linkadr := PredefinedType; - OPT.lrltyp^.strobj^.linkadr := PredefinedType; - OPT.sinttyp^.strobj^.linkadr := PredefinedType; - OPT.booltyp^.strobj^.linkadr := PredefinedType; - OPT.bytetyp^.strobj^.linkadr := PredefinedType; - (*OPT.int8typ^.strobj^.linkadr := PredefinedType; - OPT.int16typ^.strobj^.linkadr := PredefinedType; - OPT.int32typ^.strobj^.linkadr := PredefinedType; - OPT.int64typ^.strobj^.linkadr := PredefinedType;*) + OPT.chartyp^.strobj^.linkadr := PredefinedType; + OPT.settyp^.strobj^.linkadr := PredefinedType; + OPT.realtyp^.strobj^.linkadr := PredefinedType; + OPT.inttyp^.strobj^.linkadr := PredefinedType; + OPT.linttyp^.strobj^.linkadr := PredefinedType; + OPT.lrltyp^.strobj^.linkadr := PredefinedType; + OPT.sinttyp^.strobj^.linkadr := PredefinedType; + OPT.booltyp^.strobj^.linkadr := PredefinedType; + OPT.bytetyp^.strobj^.linkadr := PredefinedType; OPT.sysptrtyp^.strobj^.linkadr := PredefinedType; END AdrAndSize; @@ -271,50 +217,50 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE Precedence (class, subclass, form, comp: INTEGER): INTEGER; BEGIN CASE class OF - Nconst, Nvar, Nfield, Nindex, Nproc, Ncall: + OPM.Nconst, OPM.Nvar, OPM.Nfield, OPM.Nindex, OPM.Nproc, OPM.Ncall: RETURN 10 - | Nguard: IF OPM.typchk IN OPM.opt THEN RETURN 10 ELSE RETURN 9 (*cast*) END - | Nvarpar: - IF comp IN {Array, DynArr} THEN RETURN 10 ELSE RETURN 9 END (* arrays don't need deref *) - | Nderef: + | OPM.Nguard: IF OPM.typchk IN OPM.opt THEN RETURN 10 ELSE RETURN 9 (*cast*) END + | OPM.Nvarpar: + IF comp IN {OPM.Array, OPM.DynArr} THEN RETURN 10 ELSE RETURN 9 END (* arrays don't need deref *) + | OPM.Nderef: RETURN 9 - | Nmop: + | OPM.Nmop: CASE subclass OF - not, minus, adr, val, conv: + OPM.not, OPM.minus, OPM.adr, OPM.val, OPM.conv: RETURN 9 - | is, abs, cap, odd, cc: + | OPM.is, OPM.abs, OPM.cap, OPM.odd, OPM.cc: RETURN 10 ELSE - OPM.LogWStr("unhandled case in OPV.Precedence Nmop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + OPM.LogWStr("unhandled case in OPV.Precedence OPM.Nmop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; END - | Ndop: + | OPM.Ndop: CASE subclass OF - times: - IF form = Set THEN RETURN 4 ELSE RETURN 8 END - | slash: - IF form = Set THEN RETURN 3 ELSE RETURN 8 END - | div, mod: + OPM.times: + IF form = OPM.Set THEN RETURN 4 ELSE RETURN 8 END + | OPM.slash: + IF form = OPM.Set THEN RETURN 3 ELSE RETURN 8 END + | OPM.div, OPM.mod: RETURN 10 (* div/mod are replaced by functions *) - | plus: - IF form = Set THEN RETURN 2 ELSE RETURN 7 END - | minus: - IF form = Set THEN RETURN 4 ELSE RETURN 7 END - | lss, leq, gtr, geq: + | OPM.plus: + IF form = OPM.Set THEN RETURN 2 ELSE RETURN 7 END + | OPM.minus: + IF form = OPM.Set THEN RETURN 4 ELSE RETURN 7 END + | OPM.lss, OPM.leq, OPM.gtr, OPM.geq: RETURN 6 - | eql, neq: + | OPM.eql, OPM.neq: RETURN 5 - | and: + | OPM.and: RETURN 1 - | or: + | OPM.or: RETURN 0 - | len, in, ash, msk, bit, lsh, rot: + | OPM.len, OPM.in, OPM.ash, OPM.msk, OPM.bit, OPM.lsh, OPM.rot: RETURN 10 ELSE - OPM.LogWStr("unhandled case in OPV.Precedence Ndop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + OPM.LogWStr("unhandled case in OPV.Precedence OPM.Ndop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; END; - | Nupto: + | OPM.Nupto: RETURN 10 - | Ntype, Neguard: (* ignored anyway *) + | OPM.Ntype, OPM.Neguard: (* ignored anyway *) RETURN MaxPrec ELSE OPM.LogWStr("unhandled case in OPV.Precedence, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; @@ -326,8 +272,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE Len(n: OPT.Node; dim: LONGINT); BEGIN - WHILE (n^.class = Nindex) & (n^.typ^.comp = DynArr(*26.7.2002*)) DO INC(dim); n := n^.left END ; - IF (n^.class = Nderef) & (n^.typ^.comp = DynArr) THEN + WHILE (n^.class = OPM.Nindex) & (n^.typ^.comp = OPM.DynArr(*26.7.2002*)) DO INC(dim); n := n^.left END ; + IF (n^.class = OPM.Nderef) & (n^.typ^.comp = OPM.DynArr) THEN design(n^.left, 10); OPM.WriteString("->len["); OPM.WriteInt(dim); OPM.Write("]") ELSE OPC.Len(n^.obj, n^.typ, dim) @@ -336,14 +282,14 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE SideEffects(n: OPT.Node): BOOLEAN; BEGIN - IF n # NIL THEN RETURN (n^.class = Ncall) OR SideEffects(n^.left) OR SideEffects(n^.right) + IF n # NIL THEN RETURN (n^.class = OPM.Ncall) OR SideEffects(n^.left) OR SideEffects(n^.right) ELSE RETURN FALSE END END SideEffects; PROCEDURE Entier(n: OPT.Node; prec: INTEGER); BEGIN - IF n^.typ^.form IN {Real, LReal} THEN + IF n^.typ^.form IN {OPM.Real, OPM.LReal} THEN OPM.WriteString(EntierFunc); expr(n, MinPrec); OPM.Write(CloseParen) ELSE expr(n, prec) END @@ -352,15 +298,15 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE Convert(n: OPT.Node; form, prec: INTEGER); VAR from: INTEGER; BEGIN from := n^.typ^.form; - IF form = Set THEN OPM.WriteString(SetOfFunc); Entier(n, MinPrec); OPM.Write(CloseParen) - ELSIF form = LInt THEN - IF from < LInt THEN OPM.WriteString("(LONGINT)") END ; + IF form = OPM.Set THEN OPM.WriteString(SetOfFunc); Entier(n, MinPrec); OPM.Write(CloseParen) + ELSIF form = OPM.LInt THEN + IF from < OPM.LInt THEN OPM.WriteString("(LONGINT)") END ; Entier(n, 9) (*ELSIF form = Int64 THEN - IF (from >= SInt) & (from <= LInt) OR (from >= Int8) & (from < Int64) THEN OPM.WriteString("(SYSTEM_INT64)") END; + IF (from >= OPM.SInt) & (from <= OPM.LInt) OR (from >= Int8) & (from < Int64) THEN OPM.WriteString("(SYSTEM_INT64)") END; Entier(n, 9);*) - ELSIF form = Int THEN - IF from < Int THEN OPM.WriteString("(int)"); expr(n, 9) + ELSIF form = OPM.Int THEN + IF from < OPM.Int THEN OPM.WriteString("(int)"); expr(n, 9) ELSE IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__SHORT"); IF SideEffects(n) THEN OPM.Write("F") END ; @@ -369,14 +315,14 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 ELSE OPM.WriteString("(int)"); Entier(n, 9) END END - ELSIF form = SInt THEN + ELSIF form = OPM.SInt THEN IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__SHORT"); IF SideEffects(n) THEN OPM.Write("F") END ; OPM.Write(OpenParen); Entier(n, MinPrec); OPM.WriteString(Comma); OPM.WriteInt(OPM.MaxSInt + 1); OPM.Write(CloseParen) ELSE OPM.WriteString("(int)"); Entier(n, 9) END - ELSIF form = Char THEN + ELSIF form = OPM.Char THEN IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__CHR"); IF SideEffects(n) THEN OPM.Write("F") END ; OPM.Write(OpenParen); Entier(n, MinPrec); OPM.Write(CloseParen) @@ -388,15 +334,15 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE TypeOf(n: OPT.Node); BEGIN - IF n^.typ^.form = Pointer THEN + IF n^.typ^.form = OPM.Pointer THEN OPM.WriteString(TypeFunc); expr(n, MinPrec); OPM.Write(")") - ELSIF n^.class IN {Nvar, Nindex, Nfield} THEN (* dyn rec type = stat rec type *) + ELSIF n^.class IN {OPM.Nvar, OPM.Nindex, OPM.Nfield} THEN (* dyn rec type = stat rec type *) OPC.Andent(n^.typ); OPM.WriteString(DynTypExt) - ELSIF n^.class = Nderef THEN (* p^ *) + ELSIF n^.class = OPM.Nderef THEN (* p^ *) OPM.WriteString(TypeFunc); expr(n^.left, MinPrec); OPM.Write(")") - ELSIF n^.class = Nguard THEN (* r(T) *) + ELSIF n^.class = OPM.Nguard THEN (* r(T) *) TypeOf(n^.left) (* skip guard *) - ELSIF (n^.class = Nmop) & (n^.subcl = val) THEN + ELSIF (n^.class = OPM.Nmop) & (n^.subcl = OPM.val) THEN (*SYSTEM.VAL(typ, var par rec)*) OPC.TypeOf(n^.left^.obj) ELSE (* var par rec *) @@ -407,7 +353,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE Index(n, d: OPT.Node; prec, dim: INTEGER); BEGIN IF ~inxchk - OR (n^.right^.class = Nconst) & ((n^.right^.conval^.intval = 0) OR (n^.left^.typ^.comp # DynArr)) THEN + OR (n^.right^.class = OPM.Nconst) & ((n^.right^.conval^.intval = 0) OR (n^.left^.typ^.comp # OPM.DynArr)) THEN expr(n^.right, prec) ELSE IF SideEffects(n^.right) THEN OPM.WriteString("__XF(") ELSE OPM.WriteString("__X(") END ; @@ -422,34 +368,34 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 BEGIN comp := n^.typ^.comp; obj := n^.obj; class := n^.class; designPrec := Precedence(class, n^.subcl, n^.typ^.form, comp); - IF (class = Nvar) & (obj^.mnolev > 0) & (obj^.mnolev # OPM.level) & (prec = 10) THEN designPrec := 9 END ; + IF (class = OPM.Nvar) & (obj^.mnolev > 0) & (obj^.mnolev # OPM.level) & (prec = 10) THEN designPrec := 9 END ; IF prec > designPrec THEN OPM.Write(OpenParen) END; IF prec = ProcTypeVar THEN OPM.Write(Deref) END; (* proc var calls must be dereferenced in K&R C *) CASE class OF - Nproc: + OPM.Nproc: OPC.Ident(n^.obj) - | Nvar: + | OPM.Nvar: OPC.CompleteIdent(n^.obj) - | Nvarpar: - IF ~(comp IN {Array, DynArr}) THEN OPM.Write(Deref) END; (* deref var parameter *) + | OPM.Nvarpar: + IF ~(comp IN {OPM.Array, OPM.DynArr}) THEN OPM.Write(Deref) END; (* deref var parameter *) OPC.CompleteIdent(n^.obj) - | Nfield: - IF n^.left^.class = Nderef THEN design(n^.left^.left, designPrec); OPM.WriteString("->") + | OPM.Nfield: + IF n^.left^.class = OPM.Nderef THEN design(n^.left^.left, designPrec); OPM.WriteString("->") ELSE design(n^.left, designPrec); OPM.Write(".") END ; OPC.Ident(n^.obj) - | Nderef: - IF n^.typ^.comp = DynArr THEN design(n^.left, 10); OPM.WriteString("->data") + | OPM.Nderef: + IF n^.typ^.comp = OPM.DynArr THEN design(n^.left, 10); OPM.WriteString("->data") ELSE OPM.Write(Deref); design(n^.left, designPrec) END - | Nindex: + | OPM.Nindex: d := n^.left; - IF d^.typ^.comp = DynArr THEN dims := 0; - WHILE d^.class = Nindex DO d := d^.left; INC(dims) END ; - IF n^.typ^.comp = DynArr THEN OPM.Write("&") END ; + IF d^.typ^.comp = OPM.DynArr THEN dims := 0; + WHILE d^.class = OPM.Nindex DO d := d^.left; INC(dims) END ; + IF n^.typ^.comp = OPM.DynArr THEN OPM.Write("&") END ; design(d, designPrec); OPM.Write(OpenBracket); - IF n^.typ^.comp = DynArr THEN OPM.Write("(") END ; + IF n^.typ^.comp = OPM.DynArr THEN OPM.Write("(") END ; i := dims; x := n; WHILE x # d DO (* apply Horner schema *) IF x^.left # d THEN Index(x, d, 7, i); OPM.WriteString(" + "); Len(d, i); OPM.WriteString(" * ("); DEC(i) @@ -458,8 +404,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 x := x^.left END ; FOR i := 1 TO dims DO OPM.Write(")") END ; - IF n^.typ^.comp = DynArr THEN - (* element type is DynArr; finish Horner schema with virtual indices = 0*) + IF n^.typ^.comp = OPM.DynArr THEN + (* element type is OPM.DynArr; finish Horner schema with virtual indices = 0*) OPM.Write(")"); WHILE i < (d^.typ^.size - 4) DIV 4 DO OPM.WriteString(" * "); Len(d, i); @@ -473,10 +419,10 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 Index(n, n^.left, MinPrec, 0); OPM.Write(CloseBracket) END - | Nguard: + | OPM.Nguard: typ := n^.typ; obj := n^.left^.obj; IF OPM.typchk IN OPM.opt THEN - IF typ^.comp = Record THEN OPM.WriteString(GuardRecFunc); + IF typ^.comp = OPM.Record THEN OPM.WriteString(GuardRecFunc); IF obj^.mnolev # OPM.level THEN (*intermediate level var-par record*) OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString("__curr->"); OPC.Ident(obj) ELSE (*local var-par record*) @@ -490,15 +436,15 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 OPC.Andent(typ); OPM.WriteString(Comma); OPM.WriteInt(typ^.extlev); OPM.Write(")") ELSE - IF typ^.comp = Record THEN (* do not cast record directly, cast pointer to record *) + IF typ^.comp = OPM.Record THEN (* do not cast record directly, cast pointer to record *) OPM.WriteString("*("); OPC.Ident(typ^.strobj); OPM.WriteString("*)"); OPC.CompleteIdent(obj) ELSE (*simply cast pointer*) OPM.Write("("); OPC.Ident(typ^.strobj); OPM.Write(")"); expr(n^.left, designPrec) END END - | Neguard: + | OPM.Neguard: IF OPM.typchk IN OPM.opt THEN - IF n^.left^.class = Nvarpar THEN OPM.WriteString("__GUARDEQR("); + IF n^.left^.class = OPM.Nvarpar THEN OPM.WriteString("__GUARDEQR("); OPC.CompleteIdent(n^.left^.obj); OPM.WriteString(Comma); TypeOf(n^.left); ELSE OPM.WriteString("__GUARDEQP("); expr(n^.left^.left, MinPrec) END ; (* __GUARDEQx includes deref *) @@ -506,8 +452,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 ELSE expr(n^.left, MinPrec) (* always lhs of assignment *) END - | Nmop: - IF n^.subcl = val THEN design(n^.left, prec) END + | OPM.Nmop: + IF n^.subcl = OPM.val THEN design(n^.left, prec) END ELSE OPM.LogWStr("unhandled case in OPV.design, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; END ; @@ -520,23 +466,23 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 OPM.Write(OpenParen); WHILE n # NIL DO typ := fp^.typ; comp := typ^.comp; form := typ^.form; mode := fp^.mode; prec := MinPrec; - IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN (* avoid cast in lvalue *) + IF (mode = OPM.VarPar) & (n^.class = OPM.Nmop) & (n^.subcl = OPM.val) THEN (* avoid cast in lvalue *) OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.WriteString("*)"); prec := 10 END ; - IF ~(n^.typ^.comp IN {Array, DynArr}) THEN - IF mode = VarPar THEN + IF ~(n^.typ^.comp IN {OPM.Array, OPM.DynArr}) THEN + IF mode = OPM.VarPar THEN IF ansi & (typ # n^.typ) THEN OPM.WriteString("(void*)") END ; OPM.Write("&"); prec := 9 ELSIF ansi THEN - IF (comp IN {Array, DynArr}) & (n^.class = Nconst) THEN + IF (comp IN {OPM.Array, OPM.DynArr}) & (n^.class = OPM.Nconst) THEN OPM.WriteString("(CHAR*)") (* force to unsigned char *) - ELSIF (form = Pointer) & (typ # n^.typ) & (n^.typ # OPT.niltyp) THEN + ELSIF (form = OPM.Pointer) & (typ # n^.typ) & (n^.typ # OPT.niltyp) THEN OPM.WriteString("(void*)") (* type extension *) END ELSE - IF (form IN {Real, LReal}) & (n^.typ^.form IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN (* real promotion *) + IF (form IN {OPM.Real, OPM.LReal}) & (n^.typ^.form IN OPM.intSet) THEN (* real promotion *) OPM.WriteString("(double)"); prec := 9 - ELSIF (form = LInt) & (n^.typ^.form < LInt) THEN (* integral promotion *) + ELSIF (form = OPM.LInt) & (n^.typ^.form < OPM.LInt) THEN (* integral promotion *) OPM.WriteString("(LONGINT)"); prec := 9 (*ELSIF (form = Int64) & (n^.typ^.form < Int64) THEN OPM.WriteString("(SYSTEM_INT64)"); prec := 9;*) @@ -544,30 +490,30 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 END ELSIF ansi THEN (* casting of params should be simplified eventually *) - IF (mode = VarPar) & (typ # n^.typ) & (prec = MinPrec) THEN OPM.WriteString("(void*)") END + IF (mode = OPM.VarPar) & (typ # n^.typ) & (prec = MinPrec) THEN OPM.WriteString("(void*)") END END; - IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN + IF (mode = OPM.VarPar) & (n^.class = OPM.Nmop) & (n^.subcl = OPM.val) THEN expr(n^.left, prec) (* avoid cast in lvalue *) - ELSIF (form = LInt) & (n^.class = Nconst) + ELSIF (form = OPM.LInt) & (n^.class = OPM.Nconst) & (n^.conval^.intval <= OPM.MaxInt) & (n^.conval^.intval >= OPM.MinInt) THEN OPM.WriteString("((LONGINT)("); expr(n, prec); OPM.WriteString("))"); - ELSE + ELSE expr(n, prec) END; - IF (comp = Record) & (mode = VarPar) THEN + IF (comp = OPM.Record) & (mode = OPM.VarPar) THEN OPM.WriteString(", "); TypeOf(n) - ELSIF comp = DynArr THEN - IF n^.class = Nconst THEN (* ap is string constant *) + ELSIF comp = OPM.DynArr THEN + IF n^.class = OPM.Nconst THEN (* ap is string constant *) OPM.WriteString(Comma); OPM.WriteString("(LONGINT)"); OPM.WriteInt(n^.conval^.intval2) ELSE aptyp := n^.typ; dim := 0; - WHILE (typ^.comp = DynArr) & (typ^.BaseTyp^.form # Byte) DO + WHILE (typ^.comp = OPM.DynArr) & (typ^.BaseTyp^.form # OPM.Byte) DO OPM.WriteString(Comma); Len(n, dim); typ := typ^.BaseTyp; aptyp := aptyp^.BaseTyp; INC(dim) END ; - IF (typ^.comp = DynArr) & (typ^.BaseTyp^.form = Byte) THEN + IF (typ^.comp = OPM.DynArr) & (typ^.BaseTyp^.form = OPM.Byte) THEN OPM.WriteString(Comma); - WHILE aptyp^.comp = DynArr DO + WHILE aptyp^.comp = OPM.DynArr DO Len(n, dim); OPM.WriteString(" * "); INC(dim); aptyp := aptyp^.BaseTyp END ; OPM.WriteString("((LONGINT)("); OPM.WriteInt(aptyp^.size); OPM.WriteString("))"); @@ -583,7 +529,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE SuperProc(n: OPT.Node): OPT.Object; VAR obj: OPT.Object; typ: OPT.Struct; BEGIN typ := n^.right^.typ; (* receiver type *) - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.form = OPM.Pointer THEN typ := typ^.BaseTyp END ; OPT.FindField(n^.left^.obj^.name, typ^.BaseTyp, obj); RETURN obj END SuperProc; @@ -601,114 +547,117 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 class := n^.class; subclass := n^.subcl; form := n^.typ^.form; l := n^.left; r := n^.right; exprPrec := Precedence (class, subclass, form, n^.typ^.comp); - IF (exprPrec <= prec) & (class IN {Nconst, Nupto, Nmop, Ndop, Ncall, Nguard, Neguard}) THEN + IF (exprPrec <= prec) & (class IN {OPM.Nconst, OPM.Nupto, OPM.Nmop, OPM.Ndop, OPM.Ncall, OPM.Nguard, OPM.Neguard}) THEN OPM.Write(OpenParen); END; CASE class OF - Nconst: + OPM.Nconst: OPC.Constant(n^.conval, form) - | Nupto: (* n^.typ = OPT.settyp *) + | OPM.Nupto: (* n^.typ = OPT.settyp *) OPM.WriteString(SetRangeFunc); expr(l, MinPrec); OPM.WriteString(Comma); expr (r, MinPrec); OPM.Write(CloseParen) - | Nmop: + | OPM.Nmop: CASE subclass OF - not: + OPM.not: OPM.Write("!"); expr(l, exprPrec) - | minus: - IF form = Set THEN OPM.Write("~") ELSE OPM.Write("-"); END ; + | OPM.minus: + IF form = OPM.Set THEN OPM.Write("~") ELSE OPM.Write("-"); END ; expr(l, exprPrec) - | is: + | OPM.is: typ := n^.obj^.typ; - IF l^.typ^.comp = Record THEN OPM.WriteString(IsFunc); OPC.TypeOf(l^.obj) + IF l^.typ^.comp = OPM.Record THEN OPM.WriteString(IsFunc); OPC.TypeOf(l^.obj) ELSE OPM.WriteString(IsPFunc); expr(l, MinPrec); typ := typ^.BaseTyp END ; OPM.WriteString(Comma); OPC.Andent(typ); OPM.WriteString(Comma); OPM.WriteInt(typ^.extlev); OPM.Write(")") - | conv: + | OPM.conv: Convert(l, form, exprPrec) - | abs: + | OPM.abs: IF SideEffects(l) THEN - IF l^.typ^.form < Real THEN - IF l^.typ^.form < LInt THEN OPM.WriteString("(int)") END ; + IF l^.typ^.form < OPM.Real THEN + IF l^.typ^.form < OPM.LInt THEN OPM.WriteString("(int)") END ; OPM.WriteString("__ABSF(") ELSE OPM.WriteString("__ABSFD(") END ELSE OPM.WriteString("__ABS(") END ; expr(l, MinPrec); OPM.Write(CloseParen) - | cap: + | OPM.cap: OPM.WriteString("__CAP("); expr(l, MinPrec); OPM.Write(CloseParen) - | odd: + | OPM.odd: OPM.WriteString("__ODD("); expr(l, MinPrec); OPM.Write(CloseParen) - | adr: (*SYSTEM*) + | OPM.adr: (*SYSTEM*) OPM.WriteString("(LONGINT)(uintptr_t)"); - IF l^.class = Nvarpar THEN OPC.CompleteIdent(l^.obj) + IF l^.class = OPM.Nvarpar THEN OPC.CompleteIdent(l^.obj) ELSE - IF (l^.typ^.form # String) & ~(l^.typ^.comp IN {Array, DynArr}) THEN OPM.Write("&") END ; + IF (l^.typ^.form # OPM.String) & ~(l^.typ^.comp IN {OPM.Array, OPM.DynArr}) THEN OPM.Write("&") END ; expr(l, exprPrec) END - | val: (*SYSTEM*) - IF (n^.typ^.form IN {LInt, Pointer, Set, ProcTyp}) & (l^.typ^.form IN {LInt, Pointer, Set, ProcTyp}) - & (n^.typ^.size = l^.typ^.size) OR ~(l^.class IN {Nvar, Nvarpar, Nfield, Nindex}) THEN + | OPM.val: (*SYSTEM*) + IF ~(l^.class IN {OPM.Nvar, OPM.Nvarpar, OPM.Nfield, OPM.Nindex}) + OR (n^.typ^.form IN {OPM.LInt, OPM.Pointer, OPM.Set, OPM.ProcTyp}) + & (l^.typ^.form IN {OPM.LInt, OPM.Pointer, OPM.Set, OPM.ProcTyp}) + & (n^.typ^.size = l^.typ^.size) + THEN OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen); - IF (n^.typ^.form IN {Pointer, ProcTyp}) OR (l^.typ^.form IN {Pointer, ProcTyp}) THEN + IF (n^.typ^.form IN {OPM.Pointer, OPM.ProcTyp}) OR (l^.typ^.form IN {OPM.Pointer, OPM.ProcTyp}) THEN OPM.WriteString("(uintptr_t)") END; expr(l, exprPrec) ELSE - IF (n^.typ^.form IN {Pointer, ProcTyp}) OR (l^.typ^.form IN {Pointer, ProcTyp}) THEN - OPM.WriteString("__VALP("); + IF (n^.typ^.form IN {OPM.Pointer, OPM.ProcTyp}) OR (l^.typ^.form IN {OPM.Pointer, OPM.ProcTyp}) THEN + OPM.WriteString("__VALP("); ELSE - OPM.WriteString("__VAL("); + OPM.WriteString("__VAL("); END; OPC.Ident(n^.typ^.strobj); OPM.WriteString(Comma); expr(l, MinPrec); OPM.Write(CloseParen) END ELSE OPM.err(200) END - | Ndop: + | OPM.Ndop: CASE subclass OF - len: + OPM.len: Len(l, r^.conval^.intval) - | in, ash, msk, bit, lsh, rot, div, mod: + | OPM.in, OPM.ash, OPM.msk, OPM.bit, OPM.lsh, OPM.rot, OPM.div, OPM.mod: CASE subclass OF - | in: + | OPM.in: OPM.WriteString("__IN(") - | ash: - IF r^.class = Nconst THEN + | OPM.ash: + IF r^.class = OPM.Nconst THEN IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ASHL(") ELSE OPM.WriteString("__ASHR(") END ELSIF SideEffects(r) THEN OPM.WriteString("__ASHF(") ELSE OPM.WriteString("__ASH(") END - | msk: + | OPM.msk: OPM.WriteString("__MASK("); - | bit: + | OPM.bit: OPM.WriteString("__BIT(") - | lsh: - IF r^.class = Nconst THEN + | OPM.lsh: + IF r^.class = OPM.Nconst THEN IF r^.conval^.intval >= 0 THEN OPM.WriteString("__LSHL(") ELSE OPM.WriteString("__LSHR(") END ELSE OPM.WriteString("__LSH(") END - | rot: - IF r^.class = Nconst THEN + | OPM.rot: + IF r^.class = OPM.Nconst THEN IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ROTL(") ELSE OPM.WriteString("__ROTR(") END ELSE OPM.WriteString("__ROT(") END - | div: + | OPM.div: IF SideEffects(n) THEN - IF form < LInt THEN OPM.WriteString("(int)") END ; + IF form < OPM.LInt THEN OPM.WriteString("(int)") END ; OPM.WriteString("__DIVF(") ELSE OPM.WriteString("__DIV(") END - | mod: - IF form < LInt THEN OPM.WriteString("(int)") END ; + | OPM.mod: + IF form < OPM.LInt THEN OPM.WriteString("(int)") END ; IF SideEffects(n) THEN OPM.WriteString("__MODF(") ELSE OPM.WriteString("__MOD(") END; @@ -717,73 +666,73 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 END ; expr(l, MinPrec); OPM.WriteString(Comma); - IF (subclass IN {ash, lsh, rot}) & (r^.class = Nconst) & (r^.conval^.intval < 0) THEN + IF (subclass IN {OPM.ash, OPM.lsh, OPM.rot}) & (r^.class = OPM.Nconst) & (r^.conval^.intval < 0) THEN OPM.WriteInt(-r^.conval^.intval) ELSE expr(r, MinPrec) END ; - IF subclass IN {lsh, rot} THEN OPM.WriteString(Comma); OPC.Ident(l^.typ^.strobj) END ; + IF subclass IN {OPM.lsh, OPM.rot} THEN OPM.WriteString(Comma); OPC.Ident(l^.typ^.strobj) END ; OPM.Write(CloseParen) - | eql .. geq: - IF l^.typ^.form IN {String, Comp} THEN + | OPM.eql .. OPM.geq: + IF l^.typ^.form IN {OPM.String, OPM.Comp} THEN OPM.WriteString("__STRCMP("); expr(l, MinPrec); OPM.WriteString(Comma); expr(r, MinPrec); OPM.Write(CloseParen); OPC.Cmp(subclass); OPM.Write("0") ELSE expr(l, exprPrec); OPC.Cmp(subclass); typ := l^.typ; - IF (typ^.form = Pointer) & (r^.typ.form # NilTyp) & (r^.typ # typ) & (r^.typ # OPT.sysptrtyp) THEN + IF (typ^.form = OPM.Pointer) & (r^.typ.form # OPM.NilTyp) & (r^.typ # typ) & (r^.typ # OPT.sysptrtyp) THEN OPM.WriteString("(void *) ") END ; expr(r, exprPrec) END ELSE - IF (subclass = and) OR ((form = Set) & ((subclass = times) OR (subclass = minus))) THEN OPM.Write(OpenParen); END; (* to silence clang warnings; -- noch *) + IF (subclass = OPM.and) OR ((form = OPM.Set) & ((subclass = OPM.times) OR (subclass = OPM.minus))) THEN OPM.Write(OpenParen); END; (* to silence clang warnings; -- noch *) expr(l, exprPrec); CASE subclass OF - times: - IF form = Set THEN OPM.WriteString(" & ") + OPM.times: + IF form = OPM.Set THEN OPM.WriteString(" & ") ELSE OPM.WriteString(" * ") END - | slash: - IF form = Set THEN OPM.WriteString(" ^ ") + | OPM.slash: + IF form = OPM.Set THEN OPM.WriteString(" ^ ") ELSE OPM.WriteString(" / "); - IF (r^.obj = NIL) OR (r^.obj^.typ^.form IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN + IF (r^.obj = NIL) OR (r^.obj^.typ^.form IN OPM.intSet) THEN OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen) END END - | and: + | OPM.and: OPM.WriteString(" && ") - | plus: - IF form = Set THEN OPM.WriteString(" | ") + | OPM.plus: + IF form = OPM.Set THEN OPM.WriteString(" | ") ELSE OPM.WriteString(" + ") END - | minus: - IF form = Set THEN OPM.WriteString(" & ~") + | OPM.minus: + IF form = OPM.Set THEN OPM.WriteString(" & ~") ELSE OPM.WriteString(" - ") END; - | or: + | OPM.or: OPM.WriteString(" || "); ELSE OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; END; expr(r, exprPrec); - IF (subclass = and) OR ((form = Set) & ((subclass = times) OR (subclass = minus))) THEN OPM.Write(CloseParen) END; (* to silence clang warnings, -- noch*) + IF (subclass = OPM.and) OR ((form = OPM.Set) & ((subclass = OPM.times) OR (subclass = OPM.minus))) THEN OPM.Write(CloseParen) END; (* to silence clang warnings, -- noch*) END - | Ncall: - IF (l^.obj # NIL) & (l^.obj^.mode = TProc) THEN - IF l^.subcl = super THEN proc := SuperProc(n) + | OPM.Ncall: + IF (l^.obj # NIL) & (l^.obj^.mode = OPM.TProc) THEN + IF l^.subcl = OPM.super THEN proc := SuperProc(n) ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(l^.obj) END ; OPC.Ident(proc); n^.obj := proc^.link - ELSIF l^.class = Nproc THEN design(l, 10) + ELSIF l^.class = OPM.Nproc THEN design(l, 10) ELSE design(l, ProcTypeVar) END ; ActualPar(r, n^.obj) ELSE design(n, prec); (* not exprPrec! *) END ; - IF (exprPrec <= prec) & (class IN {Nconst, Nupto, Nmop, Ndop, Ncall, Nguard}) THEN + IF (exprPrec <= prec) & (class IN {OPM.Nconst, OPM.Nupto, OPM.Nmop, OPM.Ndop, OPM.Ncall, OPM.Nguard}) THEN OPM.Write(CloseParen) END END expr; @@ -792,14 +741,14 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE IfStat(n: OPT.Node; withtrap: BOOLEAN; outerProc: OPT.Object); VAR if: OPT.Node; obj: OPT.Object; typ: OPT.Struct; adr: LONGINT; - BEGIN (* n^.class IN {Nifelse, Nwith} *) + BEGIN (* n^.class IN {OPM.Nifelse, OPM.Nwith} *) if := n^.left; (* name := ""; *) WHILE if # NIL DO OPM.WriteString("if "); expr(if^.left, MaxPrec); (* if *) OPM.Write(Blank); OPC.BegBlk; - IF (n^.class = Nwith) & (if^.left^.left # NIL) THEN (* watch out for const expr *) + IF (n^.class = OPM.Nwith) & (if^.left^.left # NIL) THEN (* watch out for const expr *) obj := if^.left^.left^.obj; typ := obj^.typ; adr := obj^.adr; - IF typ^.comp = Record THEN + IF typ^.comp = OPM.Record THEN (* introduce alias pointer for var records; T1 *name__ = rec; *) OPC.BegStat; OPC.Ident(if^.left^.obj); OPM.WriteString(" *"); OPM.WriteString(obj.name); OPM.WriteString("__ = (void*)"); @@ -865,7 +814,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE ImplicitReturn(n: OPT.Node): BOOLEAN; BEGIN - WHILE (n # NIL) & (n.class # Nreturn) DO n := n^.link END ; + WHILE (n # NIL) & (n.class # OPM.Nreturn) DO n := n^.link END ; RETURN n = NIL END ImplicitReturn; @@ -873,12 +822,12 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 VAR typ, base: OPT.Struct; nofdim, nofdyn: INTEGER; BEGIN typ := d^.typ^.BaseTyp; base := typ; nofdim := 0; nofdyn := 0; - WHILE base^.comp = DynArr DO INC(nofdim); INC(nofdyn); base := base^.BaseTyp END ; + WHILE base^.comp = OPM.DynArr DO INC(nofdim); INC(nofdyn); base := base^.BaseTyp END ; design(d, MinPrec); OPM.WriteString(" = __NEWARR("); - WHILE base^.comp = Array DO INC(nofdim); base := base^.BaseTyp END ; - IF (base^.comp = Record) & (OPC.NofPtrs(base) # 0) THEN + WHILE base^.comp = OPM.Array DO INC(nofdim); base := base^.BaseTyp END ; + IF (base^.comp = OPM.Record) & (OPC.NofPtrs(base) # 0) THEN OPC.Ident(base^.strobj); OPM.WriteString(DynTypExt) - ELSIF base^.form = Pointer THEN OPM.WriteString("POINTER__typ") + ELSIF base^.form = OPM.Pointer THEN OPM.WriteString("POINTER__typ") ELSE OPM.WriteString("NIL") END ; OPM.WriteString(", "); OPM.WriteString("((LONGINT)("); OPM.WriteInt(base^.size); OPM.WriteString("))"); @@ -887,8 +836,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 OPM.WriteString(", "); OPM.WriteInt(nofdyn); (* number of dynamic dimensions *) WHILE typ # base DO OPM.WriteString(", "); - IF typ^.comp = DynArr THEN - IF x^.class = Nconst THEN OPM.WriteString("(LONGINT)("); expr(x, MinPrec); OPM.WriteString(")") + IF typ^.comp = OPM.DynArr THEN + IF x^.class = OPM.Nconst THEN OPM.WriteString("(LONGINT)("); expr(x, MinPrec); OPM.WriteString(")") ELSE OPM.WriteString("(LONGINT)"); expr(x, 10) END ; x := x^.link @@ -901,12 +850,12 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE DefineTDescs(n: OPT.Node); BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO OPC.TDescDecl(n^.typ); n := n^.link END + WHILE (n # NIL) & (n^.class = OPM.Ninittd) DO OPC.TDescDecl(n^.typ); n := n^.link END END DefineTDescs; PROCEDURE InitTDescs(n: OPT.Node); BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO OPC.InitTDesc(n^.typ); n := n^.link END + WHILE (n # NIL) & (n^.class = OPM.Ninittd) DO OPC.InitTDesc(n^.typ); n := n^.link END END InitTDescs; PROCEDURE stat(n: OPT.Node; outerProc: OPT.Object); @@ -914,9 +863,9 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 BEGIN WHILE (n # NIL) & OPM.noerr DO OPM.errpos := n^.conval^.intval; - IF n^.class # Ninittd THEN OPC.BegStat; END; + IF n^.class # OPM.Ninittd THEN OPC.BegStat; END; CASE n^.class OF - Nenter: + OPM.Nenter: IF n^.obj = NIL THEN (* enter module *) INC(OPM.level); stat(n^.left, outerProc); DEC(OPM.level); OPC.GenEnumPtrs(OPT.topScope^.scope); @@ -931,12 +880,12 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 OPC.EnterProc(proc); stat(n^.right, proc); OPC.ExitProc(proc, TRUE, ImplicitReturn(n^.right)); END - | Ninittd: (* done in enter module *) - | Nassign: + | OPM.Ninittd: (* done in enter module *) + | OPM.Nassign: CASE n^.subcl OF - assign: + OPM.assign: l := n^.left; r := n^.right; - IF l^.typ^.comp = Array THEN (* includes string assignment but not COPY *) + IF l^.typ^.comp = OPM.Array THEN (* includes string assignment but not COPY *) OPM.WriteString(MoveFunc); expr(r, MinPrec); OPM.WriteString(Comma); expr(l, MinPrec); OPM.WriteString(Comma); IF r^.typ = OPT.stringtyp THEN OPM.WriteInt(r^.conval^.intval2) @@ -944,51 +893,51 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 END ; OPM.Write(CloseParen) ELSE - IF (l^.typ^.form = Pointer) & (l^.obj # NIL) & (l^.obj^.adr = 1) & (l^.obj^.mode = Var) THEN + IF (l^.typ^.form = OPM.Pointer) & (l^.obj # NIL) & (l^.obj^.adr = 1) & (l^.obj^.mode = OPM.Var) THEN l^.obj^.adr := 0; design(l, MinPrec); l^.obj^.adr := 1; (* avoid cast of WITH-variable *) - IF r^.typ^.form # NilTyp THEN OPM.WriteString(" = (void*)") + IF r^.typ^.form # OPM.NilTyp THEN OPM.WriteString(" = (void*)") ELSE OPM.WriteString(" = ") END ELSE design(l, MinPrec); OPM.WriteString(" = ") END ; IF l^.typ = r^.typ THEN expr(r, MinPrec) - ELSIF (l^.typ^.form = Pointer) & (r^.typ^.form # NilTyp) & (l^.typ^.strobj # NIL) THEN + ELSIF (l^.typ^.form = OPM.Pointer) & (r^.typ^.form # OPM.NilTyp) & (l^.typ^.strobj # NIL) THEN OPM.Write("("); OPC.Ident(l^.typ^.strobj); OPM.Write(")"); expr(r, MinPrec) - ELSIF l^.typ^.comp = Record THEN + ELSIF l^.typ^.comp = OPM.Record THEN OPM.WriteString("*("); OPC.Andent(l^.typ); OPM.WriteString("*)&"); expr(r, 9) ELSE expr(r, MinPrec) END END - | newfn: - IF n^.left^.typ^.BaseTyp^.comp = Record THEN + | OPM.newfn: + IF n^.left^.typ^.BaseTyp^.comp = OPM.Record THEN OPM.WriteString("__NEW("); design(n^.left, MinPrec); OPM.WriteString(", "); OPC.Andent(n^.left^.typ^.BaseTyp); OPM.WriteString(")") - ELSIF n^.left^.typ^.BaseTyp^.comp IN {Array, DynArr} THEN + ELSIF n^.left^.typ^.BaseTyp^.comp IN {OPM.Array, OPM.DynArr} THEN NewArr(n^.left, n^.right) END - | incfn, decfn: - expr(n^.left, MinPrec); OPC.Increment(n^.subcl = decfn); expr(n^.right, MinPrec) - | inclfn, exclfn: - expr(n^.left, MinPrec); OPC.SetInclude(n^.subcl = exclfn); OPM.WriteString(SetOfFunc); expr(n^.right, MinPrec); + | OPM.incfn, OPM.decfn: + expr(n^.left, MinPrec); OPC.Increment(n^.subcl = OPM.decfn); expr(n^.right, MinPrec) + | OPM.inclfn, OPM.exclfn: + expr(n^.left, MinPrec); OPC.SetInclude(n^.subcl = OPM.exclfn); OPM.WriteString(SetOfFunc); expr(n^.right, MinPrec); OPM.Write(CloseParen) - | copyfn: + | OPM.copyfn: OPM.WriteString(CopyFunc); expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); Len(n^.left, 0); OPM.Write(CloseParen) - | (*SYSTEM*)movefn: + | (*SYSTEM*)OPM.movefn: OPM.WriteString(MoveFunc); expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); expr(n^.right^.link, MinPrec); OPM.Write(CloseParen) - | (*SYSTEM*)getfn: + | (*SYSTEM*)OPM.getfn: OPM.WriteString(GetFunc); expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(CloseParen) - | (*SYSTEM*)putfn: + | (*SYSTEM*)OPM.putfn: OPM.WriteString(PutFunc); expr(n^.left, MinPrec); OPM.WriteString(Comma); expr(n^.right, MinPrec); OPM.WriteString(Comma); OPC.Ident(n^.right^.typ^.strobj); OPM.Write(CloseParen) - | (*SYSTEM*)getrfn, putrfn: OPM.err(200) - | (*SYSTEM*)sysnewfn: + | (*SYSTEM*)OPM.getrfn, OPM.putrfn: OPM.err(200) + | (*SYSTEM*)OPM.sysnewfn: OPM.WriteString("__SYSNEW("); design(n^.left, MinPrec); OPM.WriteString(", "); expr(n^.right, MinPrec); @@ -996,53 +945,53 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 ELSE OPM.LogWStr("unhandled case in OPV.expr, n^.subcl = "); OPM.LogWNum(n^.subcl, 0); OPM.LogWLn; END - | Ncall: - IF (n^.left^.obj # NIL) & (n^.left^.obj^.mode = TProc) THEN - IF n^.left^.subcl = super THEN proc := SuperProc(n) + | OPM.Ncall: + IF (n^.left^.obj # NIL) & (n^.left^.obj^.mode = OPM.TProc) THEN + IF n^.left^.subcl = OPM.super THEN proc := SuperProc(n) ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(n^.left^.obj) END ; OPC.Ident(proc); n^.obj := proc^.link - ELSIF n^.left^.class = Nproc THEN design(n^.left, 10) + ELSIF n^.left^.class = OPM.Nproc THEN design(n^.left, 10) ELSE design(n^.left, ProcTypeVar) END ; ActualPar(n^.right, n^.obj) - | Nifelse: - IF n^.subcl # assertfn THEN IfStat(n, FALSE, outerProc) + | OPM.Nifelse: + IF n^.subcl # OPM.assertfn THEN IfStat(n, FALSE, outerProc) ELSIF assert THEN OPM.WriteString("__ASSERT("); expr(n^.left^.left^.left, MinPrec); OPM.WriteString(Comma); OPM.WriteInt(n^.left^.right^.right^.conval^.intval); OPM.Write(CloseParen); OPC.EndStat END - | Ncase: + | OPM.Ncase: INC(exit.level); CaseStat(n, outerProc); DEC(exit.level) - | Nwhile: + | OPM.Nwhile: INC(exit.level); OPM.WriteString("while "); expr(n^.left, MaxPrec); OPM.Write(Blank); OPC.BegBlk; stat(n^.right, outerProc); OPC.EndBlk; DEC(exit.level) - | Nrepeat: + | OPM.Nrepeat: INC(exit.level); OPM.WriteString("do "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk0; OPM.WriteString(" while (!"); expr(n^.right, 9); OPM.Write(CloseParen); DEC(exit.level) - | Nloop: + | OPM.Nloop: saved := exit; exit.level := 0; exit.label := -1; OPM.WriteString("for (;;) "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk; IF exit.label # -1 THEN OPC.BegStat; OPM.WriteString("exit__"); OPM.WriteInt(exit.label); OPM.Write(":"); OPC.EndStat END ; exit := saved - | Nexit: + | OPM.Nexit: IF exit.level = 0 THEN OPM.WriteString(Break) ELSE IF exit.label = -1 THEN exit.label := nofExitLabels; INC(nofExitLabels) END ; OPM.WriteString("goto exit__"); OPM.WriteInt(exit.label) END - | Nreturn: + | OPM.Nreturn: IF OPM.level = 0 THEN IF mainprog THEN OPM.WriteString("__FINI") ELSE OPM.WriteString("__ENDMOD") END ELSE IF n^.left # NIL THEN (* Make local copy of result before ExitProc deletes dynamic vars *) OPM.WriteString("_o_result = "); - IF (n^.left^.typ^.form = Pointer) & (n^.obj^.typ # n^.left^.typ) THEN + IF (n^.left^.typ^.form = OPM.Pointer) & (n^.obj^.typ # n^.left^.typ) THEN OPM.WriteString("(void*)"); expr(n^.left, 10) ELSE expr(n^.left, MinPrec) @@ -1054,22 +1003,22 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 OPM.WriteString("return"); END END - | Nwith: + | OPM.Nwith: IfStat(n, n^.subcl = 0, outerProc) - | Ntrap: + | OPM.Ntrap: OPC.Halt(n^.right^.conval^.intval) ELSE (* this else is necessary cause it can happen that n^.class is something which is not handled, - like Nconst (7) + like OPM.Nconst (7) which I actually experienced - when compiling Texts0.Mod on raspberry pi + when compiling Texts0.OPM.Mod on raspberry pi it generates __CASECHK and cause Halt, noch *) OPM.LogWStr("unhandled case in OPV.expr, n^.class = "); OPM.LogWNum(n^.class, 0); OPM.LogWLn; END ; - IF ~(n^.class IN {Nenter, Ninittd, Nifelse, Nwith, Ncase, Nwhile, Nloop}) THEN OPC.EndStat END ; + IF ~(n^.class IN {OPM.Nenter, OPM.Ninittd, OPM.Nifelse, OPM.Nwith, OPM.Ncase, OPM.Nwhile, OPM.Nloop}) THEN OPC.EndStat END ; n := n^.link END END stat;