vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 00:32:24 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Update compiler source to V2.

Browse source
This commit is contained in:
David Brown 2016-06-16 13:58:01 +01:00
parent efefcf0fb4
commit efb7b6b030
9 changed files with 1023 additions and 1177 deletions
Download patch file Download diff file Expand all files Collapse all files

129
src/compiler/OPB.Mod
View file

@ -12,13 +12,13 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
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;
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;
@ -29,8 +29,8 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
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;
Pointer = 13; ProcTyp = 14;
Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18;
Comp = (*15*)19;*)
intSet = {SInt..LInt(*, Int8..Int64*)}; realSet = {Real, LReal};
@ -51,7 +51,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
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;
@ -69,11 +69,11 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
typSize*: PROCEDURE(typ: OPT.Struct);
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
@ -94,31 +94,31 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
node^.obj := obj; node^.typ := obj^.typ;
RETURN node
END NewLeaf;
PROCEDURE Construct*(class: SHORTINT; VAR x: OPT.Node; y: OPT.Node);
VAR node: OPT.Node;
BEGIN
node := OPT.NewNode(class); node^.typ := OPT.notyp;
node^.left := x; node^.right := y; x := node
END Construct;
PROCEDURE Link*(VAR x, last: OPT.Node; y: OPT.Node);
BEGIN
IF x = NIL THEN x := y ELSE last^.link := y END ;
WHILE y^.link # NIL DO y := y^.link END ;
last := y
END Link;
PROCEDURE BoolToInt(b: BOOLEAN): LONGINT;
BEGIN
IF b THEN RETURN 1 ELSE RETURN 0 END
END BoolToInt;
PROCEDURE IntToBool(i: LONGINT): BOOLEAN;
BEGIN
IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
END IntToBool;
PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node;
VAR x: OPT.Node;
BEGIN
@ -181,7 +181,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
x := OPT.NewNode(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
@ -198,7 +198,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str;
RETURN x
END NewString;
PROCEDURE CharToString(n: OPT.Node);
VAR ch: CHAR;
BEGIN
@ -248,7 +248,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
END ;
BindNodes(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 ;
@ -258,7 +258,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
ELSE err(83); x^.typ := OPT.undftyp
END
END Field;
PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN);
PROCEDURE GTT(t0, t1: OPT.Struct);
@ -297,7 +297,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
END ;
IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END
END TypTest;
PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node);
VAR f: INTEGER; k: LONGINT;
BEGIN f := x^.typ^.form;
@ -337,10 +337,10 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
END ;
x^.intval := OPM.ConstNotAlloc
END CheckRealType;
PROCEDURE MOp*(op: SHORTINT; VAR x: OPT.Node);
VAR f: INTEGER; typ: OPT.Struct; z: OPT.Node;
PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; z: OPT.Node): OPT.Node;
VAR node: OPT.Node;
BEGIN
@ -409,9 +409,9 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
END ;
z^.typ := OPT.booltyp
| adr: (*SYSTEM.ADR*)
IF (z^.class = Nconst) & (f = Char) & (z^.conval^.intval >= 20H) THEN
CharToString(z); f := String
END ;
IF (z^.class = Nconst) & (f = Char) & (z^.conval^.intval >= 20H) THEN
CharToString(z); f := String
END;
IF (z^.class < Nconst) OR (f = String) THEN z := NewOp(op, typ, z)
ELSE err(127)
END ;
@ -428,7 +428,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
END ;
x := z
END MOp;
PROCEDURE CheckPtr(x, y: OPT.Node);
VAR g: INTEGER; p, q, t: OPT.Struct;
BEGIN g := y^.typ^.form;
@ -641,7 +641,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
| plus:
IF f IN 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
IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN
INC(xval^.intval, yval^.intval); SetIntType(x)
ELSE err(206)
END
@ -658,7 +658,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
| minus:
IF f IN intSet THEN
IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR
(yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN
(yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN
DEC(xval^.intval, yval^.intval); SetIntType(x)
ELSE err(207)
END
@ -920,7 +920,7 @@ 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)
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
k := x^.conval^.intval;
@ -958,7 +958,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
END ;
x^.typ := OPT.settyp
END SetElem;
PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node); (* x := y *)
VAR f, g: INTEGER; y, p, q: OPT.Struct;
BEGIN
@ -976,24 +976,24 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
CASE f OF
Undef, String:
(* | Int8:
IF (ynode.typ.size > OPM.Int8Size) THEN
IF (ynode.typ.size > OPM.Int8Size) THEN
IF OPM.Verbose THEN OPM.LogWStr("f of int8"); OPM.LogWLn END;
err(113)
err(113)
END
| Int16:
IF (ynode.typ.size > OPM.Int16Size) THEN
IF (ynode.typ.size > OPM.Int16Size) THEN
IF OPM.Verbose THEN OPM.LogWStr("f of int16"); OPM.LogWLn END;
err(113)
err(113)
END
| Int32:
IF (ynode.typ.size > OPM.Int32Size) THEN
IF (ynode.typ.size > OPM.Int32Size) THEN
IF OPM.Verbose THEN OPM.LogWStr("f of int32"); OPM.LogWLn END;
err(113)
err(113)
END
| Int64:
IF ynode.typ.size > OPM.Int64Size THEN
IF ynode.typ.size > OPM.Int64Size THEN
IF OPM.Verbose THEN OPM.LogWStr("f of int64"); OPM.LogWLn END;
err(113)
err(113)
END*)
| Byte:
IF ~(g IN {Byte, Char, SInt}) THEN err(113) END
@ -1034,8 +1034,18 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
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 (g = String) & (x^.BaseTyp = OPT.chartyp) THEN (*check length of string*)
IF ynode^.conval^.intval2 > x^.n THEN err(114) END ;
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
@ -1046,7 +1056,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
IF q = NIL THEN err(113) END
ELSE err(113)
END
ELSE (*DynArr*) err(113)
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;
@ -1055,18 +1065,18 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *)
Convert(ynode, x)
END
END CheckAssign;
PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN);
BEGIN
(*
avoid unnecessary intermediate variables in voc
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
*)
END CheckLeaf;
PROCEDURE StPar0*(VAR par0: OPT.Node; fctno: INTEGER); (* par0: first param of standard proc *)
VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node;
BEGIN x := par0; f := x^.typ^.form;
@ -1099,7 +1109,7 @@ avoid unnecessary intermediate variables in voc
MOp(abs, x)
| capfn: (*CAP*)
MOp(cap, x)
| ordfn: (*ORD*)
| ordfn: (*ORD*)
IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
ELSIF f = Char THEN Convert(x, OPT.inttyp)
ELSE err(111)
@ -1151,7 +1161,7 @@ avoid unnecessary intermediate variables in voc
END
ELSE err(110)
END
| chrfn: (*CHR*)
| 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)
ELSE err(111); x^.typ := OPT.chartyp
@ -1177,7 +1187,7 @@ avoid unnecessary intermediate variables in voc
ELSIF f = Char THEN Convert(x, OPT.linttyp)
ELSE err(111)
END
| incfn, decfn: (*INC, DEC*)
| incfn, decfn: (*INC, DEC*)
IF NotVar(x) THEN err(112)
ELSIF ~(f IN intSet) THEN err(111)
ELSIF x^.readonly THEN err(76)
@ -1248,14 +1258,14 @@ avoid unnecessary intermediate variables in voc
PROCEDURE StPar1*(VAR par0: OPT.Node; x: OPT.Node; fctno: SHORTINT); (* x: second parameter of standard proc *)
VAR f, L: INTEGER; typ: OPT.Struct; p, t: OPT.Node;
PROCEDURE NewOp(class, subcl: SHORTINT; left, right: OPT.Node): OPT.Node;
VAR node: OPT.Node;
BEGIN
node := OPT.NewNode(class); node^.subcl := subcl;
node^.left := left; node^.right := right; RETURN node
END NewOp;
BEGIN p := par0; f := x^.typ^.form;
CASE fctno OF
incfn, decfn: (*INC DEC*)
@ -1465,13 +1475,15 @@ avoid unnecessary intermediate variables in voc
END ;
par0 := p
END StFct;
PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN);
VAR f: INTEGER;
BEGIN (* ftyp^.comp = 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 err(-301) END (* ... warning 301 *)
IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..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 ftyp # atyp THEN
@ -1495,7 +1507,7 @@ avoid unnecessary intermediate variables in voc
IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = 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
@ -1535,7 +1547,7 @@ avoid unnecessary intermediate variables in voc
END
END
END Param;
PROCEDURE StaticLink*(dlev: SHORTINT);
VAR scope: OPT.Object;
BEGIN
@ -1566,7 +1578,7 @@ avoid unnecessary intermediate variables in voc
x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc;
x^.left := procdec; x^.right := stat; procdec := x
END Enter;
PROCEDURE Return*(VAR x: OPT.Node; proc: OPT.Object);
VAR node: OPT.Node;
BEGIN
@ -1581,7 +1593,7 @@ avoid unnecessary intermediate variables in voc
END Return;
PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node);
VAR z: OPT.Node;
VAR z: OPT.Node; subcl: SHORTINT;
BEGIN
IF x^.class >= Nconst THEN err(56) END ;
CheckAssign(x^.typ, y);
@ -1599,9 +1611,16 @@ avoid unnecessary intermediate variables in voc
y^.typ := OPT.chartyp; y^.conval^.intval := 0;
Index(x, NewIntConst(0))
END ;
BindNodes(Nassign, OPT.notyp, x, y); x^.subcl := assign
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
ELSE
subcl := assign
END;
BindNodes(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
@ -1610,7 +1629,7 @@ avoid unnecessary intermediate variables in voc
IF inittd = NIL THEN inittd := node ELSE last^.link := node END ;
last := node
END Inittd;
BEGIN
maxExp := log(MAX(LONGINT) DIV 2 + 1); maxExp := exp
END OPB.

115
src/compiler/OPC.Mod
View file

@ -1,17 +1,17 @@
MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
(* C source code generator version
(* C source code generator version
30.4.2000 jt, synchronized with BlackBox version, in particular
various promotion rules changed (long) => (LONGINT), xxxL avoided
*)
IMPORT OPT, OPM, version;
IMPORT OPT, OPM, Configuration;
CONST demoVersion = FALSE;
CONST
(* structure forms *)
Byte = 1; Bool = 2; Char = 3;
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;
@ -23,7 +23,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
Comp = 19;
*)
(*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14;
Pointer = 13; ProcTyp = 14;
Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18;
Comp = (*15*)19;*)
@ -184,7 +184,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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
@ -257,7 +257,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
END DeclareObj;
PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *)
BEGIN
BEGIN
IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN
OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H)
ELSE Ident(typ^.strobj)
@ -265,7 +265,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
END Andent;
PROCEDURE Undefined(obj: OPT.Object): BOOLEAN;
BEGIN
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;
@ -302,7 +302,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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.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
@ -365,7 +365,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
IF obj^.mode = TProc THEN
BegStat;
OPM.WriteString("__INITBP(");
Ident(typ); OPM.WriteString(Comma); Ident(obj);
Ident(typ); OPM.WriteString(Comma); Ident(obj);
Str1(", #)", obj^.adr DIV 10000H);
EndStat
END ;
@ -431,7 +431,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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 OPM.currFile = OPM.HeaderFile THEN
IF obj^.vis = external THEN
DefineTProcTypes(obj);
OPM.WriteString(Extern); empty := FALSE;
@ -518,10 +518,10 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
WHILE field # NIL DO DefineType(field^.typ); field := field^.link END
END
END ;
IF (obj # NIL) & Undefined(obj) THEN
IF (obj # NIL) & Undefined(obj) THEN
OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1);
obj^.linkadr := ProcessingType;
DeclareBase(obj); OPM.Write(Blank);
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 *)
@ -536,10 +536,11 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
END DefineType;
PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER;
BEGIN i := 0;
VAR i: INTEGER; r: BOOLEAN;
BEGIN i := 0;
WHILE x[i+1] = y[i] DO INC(i) END ;
RETURN y[i] = 0X
r := y[i] = 0X;
RETURN r;
END Prefixed;
PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER);
@ -550,7 +551,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
(* 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
IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN
OPM.WriteString("#define "); Ident(obj);
DeclareParams(obj^.link, TRUE);
OPM.Write(Tab);
@ -591,7 +592,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
VAR nofptrs: LONGINT;
o: OPT.Object;
BEGIN
BegStat; OPM.WriteString("__TDESC(");
BegStat; OPM.WriteString("__TDESC(");
Andent(typ);
Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ));
OPM.Write('"');
@ -613,7 +614,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT);
BEGIN
CASE base OF
CASE base OF
| 2: INC(adr, adr MOD 2)
| 4: INC(adr, (-adr) MOD 4)
| 8: INC(adr, (-adr) MOD 8)
@ -655,9 +656,9 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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")
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;
@ -751,7 +752,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
ELSE
LOOP
DeclareBase(obj);
IF showParamNames THEN
IF showParamNames THEN
OPM.Write(Blank); DeclareObj(obj, FALSE)
ELSE
COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name)
@ -857,30 +858,26 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
PROCEDURE GenHeaderMsg;
VAR i: INTEGER;
BEGIN
OPM.WriteString("/*"); OPM.WriteString(HeaderMsg);
OPM.Write(" "); OPM.WriteString(version.versionLong); OPM.Write (" "); (* noch *)
FOR i := 0 TO OPM.MaxSet (*31*) DO (*noch*)
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.extsf: OPM.Write("e")
| OPM.newsf: OPM.Write("s")
| OPM.mainprog: OPM.Write("m")
| OPM.inxchk: OPM.Write("x")
| OPM.vcpp: OPM.Write("v")
| OPM.ranchk: OPM.Write("r")
| OPM.typchk: OPM.Write("t")
| OPM.assert: OPM.Write("a")
| OPM.ansi: OPM.Write("k")
| OPM.ptrinit: OPM.Write("p")
| OPM.include0: OPM.Write("i")
| OPM.lineno: OPM.Write("l")
| OPM.useparfile: OPM.Write("P")
| OPM.dontasm: OPM.Write("S")
| OPM.dontlink: OPM.Write("c")
| OPM.mainlinkstat: OPM.Write("M")
| 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")
| 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
@ -888,7 +885,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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;
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;
@ -903,6 +900,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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;
@ -911,6 +909,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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);
@ -940,8 +939,8 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
IF obj # NIL THEN
InitImports(obj^.left);
IF (obj^.mode = Mod) & (obj^.mnolev # 0) THEN
BegStat; OPM.WriteString("__IMPORT(");
OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name);
BegStat; OPM.WriteString("__MODULE_IMPORT(");
OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name);
OPM.Write(CloseParen); EndStat
END ;
InitImports(obj^.right)
@ -960,7 +959,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
OPM.WriteString("void EnumPtrs(void (*P)(void*))")
ELSE
OPM.WriteString("void EnumPtrs(P)"); OPM.WriteLn;
OPM.Write(Tab); OPM.WriteString("void (*P)();");
OPM.Write(Tab); OPM.WriteString("void (*P)();");
END ;
OPM.WriteLn;
BegBlk
@ -995,7 +994,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
OPM.WriteLn; OPM.WriteString(Export);
IF mainprog THEN
IF ansi THEN
OPM.WriteString("main(int argc, char **argv)"); OPM.WriteLn;
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
@ -1008,7 +1007,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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")');
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);
@ -1050,6 +1049,15 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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;
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*)
@ -1080,7 +1088,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
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;
BegStat;
IF var^.typ^.comp = Array THEN
OPM.WriteString(DupArrFunc);
Ident(var); OPM.WriteString(Comma);
@ -1263,7 +1271,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
END;
OPM.WriteString(Colon);
END Case;
PROCEDURE SetInclude* (exclude: BOOLEAN);
BEGIN
IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END;
@ -1286,7 +1294,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
IF dim # 0 THEN OPM.WriteInt(dim) END
ELSE (* array *)
WHILE dim > 0 DO array := array^.BaseTyp; DEC(dim) END ;
OPM.WriteInt(array^.n); OPM.PromoteIntConstToLInt()
OPM.WriteString("((LONGINT)("); OPM.WriteInt(array^.n); OPM.WriteString("))");
END
END Len;
@ -1313,7 +1321,6 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
OPM.WriteInt(con^.intval)
(* | Int8, Int16, Int32, Int64:
OPM.WriteInt(con^.intval)*)
| Real:
OPM.WriteReal(con^.realval, "f")
| LReal:
@ -1397,7 +1404,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *)
Enter("volatile");
Enter("while");
(* what about common predefined names from cpp as e.g.
(* what about common predefined names from cpp as e.g.
Operating System: ibm, gcos, os, tss and unix
Hardware: interdata, pdp11, u370, u3b,
u3b2, u3b5, u3b15, u3b20d,

985
src/compiler/OPM.cmdln.Mod
View file

File diff suppressed because it is too large Load diff

44
src/compiler/OPP.Mod
View file

@ -2,7 +2,7 @@ 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;
@ -27,7 +27,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
(* Structure forms *)
Undef = 0; Byte = 1; Bool = 2; Char = 3;
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;
@ -42,7 +42,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
Comp = (*15*)19;*)
intSet = {SInt..LInt(*, Int8..Int64*)};
(* composite structure forms *)
Basic = 1; Array = 2; DynArr = 3; Record = 4;
@ -58,7 +58,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
(* node subclasses *)
super = 1;
(* module visibility of objects *)
internal = 0; external = 1; externalR = 2;
@ -70,7 +70,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
RECORD
low, high: LONGINT
END ;
VAR
sym, level: SHORTINT;
LoopLevel: INTEGER;
@ -116,7 +116,7 @@ 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
err(50); x := OPB.NewIntConst(1)
err(50); x := OPB.NewIntConst(1)
END
END ConstExpression;
@ -129,7 +129,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
ELSE vis := internal
END
END CheckMark;
PROCEDURE CheckSysFlag(VAR sysflag: INTEGER; default: INTEGER);
VAR x: OPT.Node; sf: LONGINT;
BEGIN
@ -256,7 +256,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
END
END
END PointerType;
PROCEDURE FormalParameters(VAR firstPar: OPT.Object; VAR resTyp: OPT.Struct);
VAR mode: SHORTINT;
par, first, last, res: OPT.Object; typ: OPT.Struct;
@ -338,7 +338,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
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
@ -443,7 +443,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
END ;
IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END
END StandProcCall;
PROCEDURE Element(VAR x: OPT.Node);
VAR y: OPT.Node;
BEGIN Expression(x);
@ -469,7 +469,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
END ;
CheckSym(rbrace)
END Sets;
PROCEDURE Factor(VAR x: OPT.Node);
VAR fpar, id: OPT.Object; apar: OPT.Node;
BEGIN
@ -573,7 +573,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
CheckSym(rparen);
IF rec = NIL THEN rec := OPT.NewStr(Comp, 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 ;
@ -595,7 +595,11 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
ext := OPT.NewExt(); proc^.conval^.ext := ext; n := 0;
IF sym = string THEN
WHILE OPS.str[n] # 0X DO ext[n+1] := OPS.str[n]; INC(n) END ;
ext^[0] := CHR(n); OPS.Get(sym)
ext^[0] := CHR(n); OPS.Get(sym);
(*
Console.String("Code procedure, length "); Console.Int(n,1); Console.Ln;
Console.String(' "'); Console.String(ext^); Console.String('"'); Console.Ln;
*)
ELSE
LOOP
IF sym = number THEN c := OPS.intval; INC(n);
@ -666,7 +670,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
ELSE
IF fwd # NIL THEN err(1); fwd := NIL END ;
OPT.OpenScope(0, NIL); OPT.topScope^.right := recTyp^.link; OPT.Insert(name, proc);
recTyp^.link := OPT.topScope^.right; OPT.CloseScope;
recTyp^.link := OPT.topScope^.right; OPT.CloseScope;
END ;
INC(level); OPT.OpenScope(level, proc);
OPT.Insert(objName, proc^.link); proc^.link^.mode := objMode; proc^.link^.typ := objTyp;
@ -685,7 +689,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
ELSE err(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 *)
@ -766,7 +770,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
PROCEDURE CasePart(VAR x: OPT.Node);
VAR n: INTEGER; low, high: LONGINT; e: BOOLEAN;
tab: CaseTable; cases, lab, y, lastcase: OPT.Node;
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)
@ -786,8 +790,8 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
ELSE low := 1; high := 0
END ;
e := sym = else;
IF e THEN OPS.Get(sym); StatSeq(y)
ELSE
IF e THEN OPS.Get(sym); StatSeq(y)
ELSE
y := NIL;
OPM.Mark(-307, OPM.curpos); (* notice about no else symbol; -- noch *)
END ;
@ -796,7 +800,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
cases^.conval^.intval := low; cases^.conval^.intval2 := high;
IF e THEN cases^.conval^.setval := {1} ELSE cases^.conval^.setval := {} END
END CasePart;
PROCEDURE SetPos(x: OPT.Node);
BEGIN
x^.conval := OPT.NewConst(); x^.conval^.intval := pos
@ -1048,7 +1052,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *)
OPS.Init; LoopLevel := 0; level := 0; OPS.Get(sym);
IF sym = module THEN OPS.Get(sym) ELSE err(16) END ;
IF sym = ident THEN
OPM.LogW(" "); OPM.LogWStr(OPS.name);
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);
LOOP

18
src/compiler/OPS.Mod
View file

@ -1,11 +1,11 @@
MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *)
IMPORT OPM;
CONST
MaxStrLen* = 256;
MaxIdLen = 256;
TYPE
Name* = ARRAY MaxIdLen OF CHAR;
String* = ARRAY MaxStrLen OF CHAR;
@ -13,12 +13,12 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *)
(* name, str, numtyp, intval, realval, lrlval are implicit results of Get *)
VAR
name*: Name;
str*: String;
numtyp*: INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *)
intval*: LONGINT; (* integer value or string length *)
name*: Name;
str*: String;
numtyp*: INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *)
intval*: LONGINT; (* integer value or string length *)
realval*: REAL;
lrlval*: LONGREAL;
lrlval*: LONGREAL;
(*symbols:
| 0 1 2 3 4
@ -62,7 +62,7 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *)
PROCEDURE err(n: INTEGER);
BEGIN OPM.err(n)
END err;
PROCEDURE Str(VAR sym: SHORTINT);
VAR i: INTEGER; och: CHAR;
BEGIN i := 0; och := ch;
@ -110,7 +110,7 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *)
ELSE err(2); RETURN 0
END
END Ord;
BEGIN (* ("0" <= ch) & (ch <= "9") *)
i := 0; m := 0; n := 0; d := 0;
LOOP (* read mantissa *)

457
src/compiler/OPT.Mod
View file

@ -4,148 +4,154 @@ MODULE OPT; (* NW, RC 6.3.89 / 23.1.92 *) (* object model 24.2.94 *)
2002-08-20 jt: NewStr: txtpos remains 0 for structs read from symbol file
*)
IMPORT
OPS, OPM;
IMPORT OPS, OPM;
CONST
MaxConstLen* = OPS.MaxStrLen;
MaxConstLen* = OPS.MaxStrLen;
TYPE
Const* = POINTER TO ConstDesc;
Object* = POINTER TO ObjDesc;
Struct* = POINTER TO StrDesc;
Node* = POINTER TO NodeDesc;
ConstExt* = POINTER TO OPS.String;
Const* = POINTER TO ConstDesc;
Object* = POINTER TO ObjDesc;
Struct* = POINTER TO StrDesc;
Node* = POINTER TO NodeDesc;
ConstExt* = POINTER TO OPS.String;
ConstDesc* = RECORD
ext*: ConstExt; (* string or code for code proc *)
intval*: LONGINT; (* constant value or adr, proc par size, text position or least case label *)
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 ;
ConstDesc* = RECORD
ext*: ConstExt; (* string or code for code proc *)
intval*: LONGINT; (* constant value or adr, proc par size, text position or least case label *)
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 ;
ObjDesc* = RECORD
left*, right*, link*, scope*: Object;
name*: OPS.Name;
leaf*: BOOLEAN;
mode*, mnolev*: SHORTINT; (* mnolev < 0 -> mno = -mnolev *)
vis*: SHORTINT; (* internal, external, externalR *)
history*: SHORTINT; (* relevant if name # "" *)
used*, fpdone*: BOOLEAN;
fprint*: LONGINT;
typ*: Struct;
conval*: Const;
adr*, linkadr*: LONGINT;
x*: INTEGER (* linkadr and x can be freely used by the backend *)
END ;
ObjDesc* = RECORD
left*, right*: Object;
link*, scope*: Object;
name*: OPS.Name;
leaf*: BOOLEAN;
mode*, mnolev*: SHORTINT; (* mnolev < 0 -> mno = -mnolev *)
vis*: SHORTINT; (* internal, external, externalR *)
history*: SHORTINT; (* relevant if name # "" *)
used*, fpdone*: BOOLEAN;
fprint*: LONGINT;
typ*: Struct;
conval*: Const;
adr*, linkadr*: LONGINT;
x*: INTEGER (* linkadr and x can be freely used by the backend *)
END ;
StrDesc* = RECORD
form*, comp*, mno*, extlev*: SHORTINT;
ref*, sysflag*: INTEGER;
n*, size*, align*, txtpos*: LONGINT; (* align is alignment for records and len offset for dynarrs *)
allocated*, pbused*, pvused*, fpdone, idfpdone: BOOLEAN;
idfp, pbfp*, pvfp*:LONGINT;
BaseTyp*: Struct;
link*, strobj*: Object
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 ;
NodeDesc* = RECORD
left*, right*, link*: Node;
class*, subcl*: SHORTINT;
readonly*: BOOLEAN;
typ*: Struct;
obj*: Object;
conval*: Const
END ;
NodeDesc* = RECORD
left*, right*, link*: Node;
class*, subcl*: SHORTINT;
readonly*: BOOLEAN;
typ*: Struct;
obj*: Object;
conval*: Const
END ;
CONST
maxImps = 64; (* must be <= MAX(SHORTINT) *)
maxStruct = OPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *)
FirstRef = (*20*)16; (* comp + 1 *)
maxImps = 64; (* must be <= MAX(SHORTINT) *)
maxStruct = OPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *)
FirstRef = (*20*)16; (* comp + 1 *)
VAR
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;
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 *)
SYSimported*: BOOLEAN;
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;
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 *)
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;
(* 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;
(* 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;*)
(*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;
(* 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;
(*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;
(*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;
(* 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;
(* 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
nextTag, reffp: LONGINT;
nofr, minr, nofm: INTEGER;
self: BOOLEAN;
ref: ARRAY maxStruct OF Struct;
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 ;
ImpCtxt = RECORD
nextTag, reffp: LONGINT;
nofr, minr, nofm: INTEGER;
self: BOOLEAN;
ref: ARRAY maxStruct OF Struct;
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 ;
ExpCtxt = RECORD
reffp: LONGINT;
ref: INTEGER;
nofm: SHORTINT;
locmno: ARRAY maxImps OF SHORTINT (* index is global mno *)
END ;
ExpCtxt = RECORD
reffp: LONGINT;
ref: INTEGER;
nofm: SHORTINT;
locmno: ARRAY maxImps OF SHORTINT (* index is global mno *)
END ;
VAR
universe, syslink: Object;
impCtxt: ImpCtxt;
expCtxt: ExpCtxt;
nofhdfld: LONGINT;
newsf, findpc, extsf, sfpresent, symExtended, symNew: BOOLEAN;
universe, syslink: Object;
impCtxt: ImpCtxt;
expCtxt: ExpCtxt;
nofhdfld: LONGINT;
newsf, findpc: BOOLEAN;
extsf, sfpresent: BOOLEAN;
symExtended, symNew: BOOLEAN;
PROCEDURE err(n: INTEGER);
BEGIN OPM.err(n)
@ -244,7 +250,7 @@ END Find;
PROCEDURE FindField*(VAR name: OPS.Name; typ: Struct; VAR res: Object);
VAR obj: Object;
BEGIN
BEGIN
WHILE typ # NIL DO obj := typ^.link;
WHILE obj # NIL DO
IF name < obj^.name THEN obj := obj^.left
@ -288,17 +294,16 @@ PROCEDURE ^IdFPrint*(typ: Struct);
PROCEDURE DebugStruct(btyp: Struct);
BEGIN
OPM.LogWLn;
IF btyp = NIL THEN OPM.LogWStr("btyp is nil"); OPM.LogWLn END;
OPM.LogWStr("btyp^.strobji^.name = "); OPM.LogWStr(btyp^.strobj^.name); OPM.LogWLn;
OPM.LogWStr("btyp^.form = "); OPM.LogWNum(btyp^.form, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.comp = "); OPM.LogWNum(btyp^.comp, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.mno = "); OPM.LogWNum(btyp^.mno, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.extlev = "); OPM.LogWNum(btyp^.extlev, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.size = "); OPM.LogWNum(btyp^.size, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.align = "); OPM.LogWNum(btyp^.align, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.txtpos = "); OPM.LogWNum(btyp^.txtpos, 0); OPM.LogWLn;
OPM.LogWLn;
IF btyp = NIL THEN OPM.LogWStr("btyp is nil"); OPM.LogWLn END;
OPM.LogWStr("btyp^.strobji^.name = "); OPM.LogWStr(btyp^.strobj^.name); OPM.LogWLn;
OPM.LogWStr("btyp^.form = "); OPM.LogWNum(btyp^.form, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.comp = "); OPM.LogWNum(btyp^.comp, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.mno = "); OPM.LogWNum(btyp^.mno, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.extlev = "); OPM.LogWNum(btyp^.extlev, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.size = "); OPM.LogWNum(btyp^.size, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.align = "); OPM.LogWNum(btyp^.align, 0); OPM.LogWLn;
OPM.LogWStr("btyp^.txtpos = "); OPM.LogWNum(btyp^.txtpos, 0); OPM.LogWLn;
END DebugStruct;
PROCEDURE FPrintSign(VAR fp: LONGINT; result: Struct; par: Object);
@ -306,8 +311,8 @@ PROCEDURE FPrintSign(VAR fp: LONGINT; result: Struct; par: Object);
BEGIN
IdFPrint(result); OPM.FPrint(fp, result^.idfp);
WHILE (par # NIL) (*& (par^.typ # NIL)*) DO (* !!! *)
OPM.FPrint(fp, par^.mode);
IdFPrint(par^.typ);
OPM.FPrint(fp, par^.mode);
IdFPrint(par^.typ);
OPM.FPrint(fp, par^.typ^.idfp);
(* par^.name and par^.adr not considered *)
par := par^.link
@ -326,7 +331,7 @@ BEGIN
END ;
IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN
IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp)
ELSIF c = Array THEN
ELSIF c = Array THEN
IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp); OPM.FPrint(idfp, typ^.n)
ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ^.link)
END ;
@ -366,7 +371,7 @@ 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
ELSE
FPrintHdFld(fld^.typ, fld, fld^.adr + adr)
END ;
fld := fld^.link
@ -453,26 +458,26 @@ BEGIN
END
END FPrintObj;
PROCEDURE FPrintErr*(obj: Object; errno: INTEGER);
PROCEDURE FPrintErr*(obj: Object; errcode: INTEGER);
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 ;
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 ;
IF errno = 249 THEN
IF OPM.noerr THEN err(errno) END
ELSIF errno = 253 THEN (* extension *)
IF ~symNew & ~symExtended & ~extsf THEN err(errno) END ;
symExtended := TRUE
ELSE
IF ~symNew & ~newsf THEN err(errno) END ;
symNew := TRUE
END
IF obj^.mnolev # 0 THEN
COPY(GlbMod[-obj^.mnolev]^.name, OPM.objname); i := 0;
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 ;
IF errcode = 249 THEN
IF OPM.noerr THEN err(errcode) END
ELSIF errcode = 253 THEN (* extension *)
IF ~symNew & ~symExtended & ~extsf THEN err(errcode) END ;
symExtended := TRUE
ELSE
IF ~symNew & ~newsf THEN err(errcode) END ;
symNew := TRUE
END
END FPrintErr;
(*-------------------------- Import --------------------------*)
@ -625,20 +630,20 @@ 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
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 := ""
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
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;
@ -648,11 +653,11 @@ BEGIN
typ := old^.typ; typ^.link := NIL; typ^.sysflag := 0;
typ^.fpdone := FALSE; typ^.idfpdone := FALSE
END
ELSE
typ := NewStr(Undef, Basic)
ELSE
typ := NewStr(Undef, Basic)
END
END ;
impCtxt.ref[ref] := typ; impCtxt.old[ref] := old;
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;
@ -662,27 +667,27 @@ BEGIN
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)
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();
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
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);
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; (* !!! *)
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;
@ -692,16 +697,16 @@ BEGIN
last := fld; InsertImport(fld, typ^.link, dummy);
impCtxt.nextTag := OPM.SymRInt()
END ;
WHILE impCtxt.nextTag # Send DO
fld := InTProc(mno);
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;
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
@ -709,40 +714,40 @@ END ;
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 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 *)
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
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
ELSIF impCtxt.self THEN
obj^.history := removed
ELSE
obj^.history := same
END ;
INC(ref)
END ;
@ -774,12 +779,12 @@ END InStruct;
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;
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
ELSE
obj^.mode := Var;
IF tag = Srvar THEN obj^.vis := externalR END ;
InStruct(obj^.typ)
@ -852,7 +857,7 @@ END InStruct;
BEGIN i := 0;
REPEAT ch := name[i]; OPM.SymWCh(ch); INC(i) UNTIL ch = 0X
END OutName;
PROCEDURE OutMod(mno: INTEGER);
BEGIN
IF expCtxt.locmno[mno] < 0 THEN (* new mod *)
@ -950,7 +955,7 @@ END InStruct;
| pvmodified: FPrintErr(strobj, 251)
| 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 ;
@ -974,10 +979,10 @@ END InStruct;
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;
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;
ELSE OPM.LogWStr("unhandled case at OPT.OutStr, typ^.form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn;
END
END
END OutStr;
@ -1017,8 +1022,8 @@ END InStruct;
| 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;
ELSE
OPM.LogWStr("unhandled case at OPT.OutObj, obj^.history = "); OPM.LogWNum(obj^.history, 0); OPM.LogWLn;
END ;
CASE obj^.mode OF
| Con:
@ -1043,8 +1048,8 @@ END InStruct;
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;
ELSE
OPM.LogWStr("unhandled case at OPT.OutObj, obj.mode = "); OPM.LogWNum(obj.mode, 0); OPM.LogWLn;
END
END
END ;
@ -1066,17 +1071,17 @@ END InStruct;
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 ;
newsf := FALSE; symNew := FALSE; (* because of call to FPrintErr from OPL *)
IF ~OPM.noerr OR findpc THEN
OPM.DeleteNewSym
END
IF ~OPM.noerr OR findpc THEN
OPM.DeleteNewSym
END
(* OPM.RegisterNewSym is called in OP2 after writing the object file *)
END
END
@ -1202,7 +1207,7 @@ Objects:
Mod | scope Module
Head | txtpos owner firstvar Scope anchor
TProc | index sizes firstpar scope leaf Bound procedure, index = 10000H*mthno+entry, entry adr set in back-end
Structures:
form comp | n BaseTyp link mno txtpos sysflag
@ -1238,7 +1243,7 @@ stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat|
Nloop|Nexit|Nreturn|Nwith|Ntrap.
class subcl obj left right link
class subcl obj left right link
---------------------------------------------------------
design Nvar var nextexpr
@ -1255,7 +1260,7 @@ design Nvar var nextexpr
expr design
Nconst const (val = node^.conval)
Nupto expr expr nextexpr
Nupto expr expr nextexpr
Nmop not expr nextexpr
minus expr nextexpr
is tsttype expr nextexpr
@ -1322,8 +1327,8 @@ stat NIL
Ncase expr casestat stat
Nwhile expr stat stat
Nrepeat stat expr stat
Nloop stat stat
Nexit stat
Nloop stat stat
Nexit stat
Nreturn proc nextexpr stat (proc = NIL for mod)
Nwith ifstat stat stat
Ntrap expr stat

135
src/compiler/OPV.Mod
View file

@ -1,4 +1,4 @@
MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
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
31.1.2007 jt synchronized with BlackBox version, in particular:
@ -6,7 +6,7 @@ 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;
@ -31,8 +31,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
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;
(*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 *)
@ -57,38 +57,38 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
super = 1;
UndefinedType = 0; (* named type not yet defined *)
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 *)
DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *)
DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *)
OpenParen = "(";
CloseParen = ")";
OpenBracket = "[";
OpenParen = "(";
CloseParen = ")";
OpenBracket = "[";
CloseBracket = "]";
Blank = " ";
Comma = ", ";
Deref = "*";
EntierFunc = "__ENTIER(";
IsFunc = "__IS(";
IsPFunc = "__ISP(";
Blank = " ";
Comma = ", ";
Deref = "*";
EntierFunc = "__ENTIER(";
IsFunc = "__IS(";
IsPFunc = "__ISP(";
GuardPtrFunc = "__GUARDP(";
GuardRecFunc = "__GUARDR(";
TypeFunc = "__TYPEOF(";
SetOfFunc = "__SETOF(";
TypeFunc = "__TYPEOF(";
SetOfFunc = "__SETOF(";
SetRangeFunc = "__SETRNG(";
CopyFunc = "__COPY(";
MoveFunc = "__MOVE(";
GetFunc = "__GET(";
PutFunc = "__PUT(";
DynTypExt = "__typ";
WithChk = "__WITHCHK";
Break = "break";
ElseStat = "else ";
CopyFunc = "__COPY(";
MoveFunc = "__MOVE(";
GetFunc = "__GET(";
PutFunc = "__PUT(";
DynTypExt = "__typ";
WithChk = "__WITHCHK";
Break = "break";
ElseStat = "else ";
MinPrec = -1;
MaxPrec = 12;
MinPrec = -1;
MaxPrec = 12;
ProcTypeVar = 11; (* precedence number when a call is made with a proc type variable *)
internal = 0;
@ -145,7 +145,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
IF (typ^.strobj = NIL) & (typ^.align MOD 10000H = 0) THEN INC(recno); INC(base, recno * 10000H) END ;
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)
typ^.sysflag := typ^.sysflag MOD 100H + SHORT((offset - off0)*100H)
ELSIF c = Array THEN
TypSize(typ^.BaseTyp);
typ^.size := typ^.n * typ^.BaseTyp^.size;
@ -160,7 +160,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
btyp := typ^.BaseTyp; TypSize(btyp);
IF btyp^.comp = DynArr THEN typ^.size := btyp^.size + 4 (* describes dim not size *)
ELSE typ^.size := 8
END ;
END
END
END
END TypSize;
@ -173,7 +173,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
mainprog := OPM.mainprog IN OPM.opt;
ansi := OPM.ansi IN OPM.opt
END Init;
PROCEDURE ^Traverse (obj, outerScope: OPT.Object; exported: BOOLEAN);
PROCEDURE GetTProcNum(obj: OPT.Object);
@ -284,6 +284,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
RETURN 9
| is, abs, cap, odd, cc:
RETURN 10
ELSE
OPM.LogWStr("unhandled case in OPV.Precedence Nmop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn;
END
| Ndop:
CASE subclass OF
@ -307,8 +309,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
RETURN 0
| len, in, ash, msk, bit, lsh, rot:
RETURN 10
ELSE
OPM.LogWStr("unhandled case in OPV.Precedence, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn;
ELSE
OPM.LogWStr("unhandled case in OPV.Precedence Ndop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn;
END;
| Nupto:
RETURN 10
@ -355,7 +357,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
IF from < 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 >= SInt) & (from <= 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)
@ -474,7 +476,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
| 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 = 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*)
@ -497,7 +499,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
| Neguard:
IF OPM.typchk IN OPM.opt THEN
IF n^.left^.class = Nvarpar THEN OPM.WriteString("__GUARDEQR(");
OPC.CompleteIdent(n^.left^.obj); OPM.WriteString(Comma); TypeOf(n^.left);
OPC.CompleteIdent(n^.left^.obj); OPM.WriteString(Comma); TypeOf(n^.left);
ELSE OPM.WriteString("__GUARDEQP("); expr(n^.left^.left, MinPrec)
END ; (* __GUARDEQx includes deref *)
OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(")")
@ -543,14 +545,16 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
ELSIF ansi THEN
(* casting of params should be simplified eventually *)
IF (mode = VarPar) & (typ # n^.typ) & (prec = MinPrec) THEN OPM.WriteString("(void*)") END
END ;
IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN expr(n^.left, prec) (* avoid cast in lvalue *)
ELSE expr(n, prec)
END ;
IF (form = LInt) & (n^.class = Nconst)
& (n^.conval^.intval <= OPM.MaxInt) & (n^.conval^.intval >= OPM.MinInt) THEN
OPM.PromoteIntConstToLInt()
ELSIF (comp = Record) & (mode = VarPar) THEN
END;
IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN
expr(n^.left, prec) (* avoid cast in lvalue *)
ELSIF (form = LInt) & (n^.class = Nconst)
& (n^.conval^.intval <= OPM.MaxInt) & (n^.conval^.intval >= OPM.MinInt) THEN
OPM.WriteString("((LONGINT)("); expr(n, prec); OPM.WriteString("))");
ELSE
expr(n, prec)
END;
IF (comp = Record) & (mode = VarPar) THEN
OPM.WriteString(", "); TypeOf(n)
ELSIF comp = DynArr THEN
IF n^.class = Nconst THEN (* ap is string constant *)
@ -566,7 +570,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
WHILE aptyp^.comp = DynArr DO
Len(n, dim); OPM.WriteString(" * "); INC(dim); aptyp := aptyp^.BaseTyp
END ;
OPM.WriteInt(aptyp^.size); OPM.PromoteIntConstToLInt()
OPM.WriteString("((LONGINT)("); OPM.WriteInt(aptyp^.size); OPM.WriteString("))");
END
END
END ;
@ -613,7 +617,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
| minus:
IF form = Set THEN OPM.Write("~") ELSE OPM.Write("-"); END ;
expr(l, exprPrec)
| is:
| is:
typ := n^.obj^.typ;
IF l^.typ^.comp = Record THEN OPM.WriteString(IsFunc); OPC.TypeOf(l^.obj)
ELSE OPM.WriteString(IsPFunc); expr(l, MinPrec); typ := typ^.BaseTyp
@ -638,7 +642,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
| odd:
OPM.WriteString("__ODD("); expr(l, MinPrec); OPM.Write(CloseParen)
| adr: (*SYSTEM*)
OPM.WriteString("(LONGINT)");
OPM.WriteString("(LONGINT)(uintptr_t)");
IF l^.class = Nvarpar THEN OPC.CompleteIdent(l^.obj)
ELSE
IF (l^.typ^.form # String) & ~(l^.typ^.comp IN {Array, DynArr}) THEN OPM.Write("&") END ;
@ -648,9 +652,17 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
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.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
OPM.WriteString("(uintptr_t)")
END;
expr(l, exprPrec)
ELSE
OPM.WriteString("__VAL("); OPC.Ident(n^.typ^.strobj); OPM.WriteString(Comma);
IF (n^.typ^.form IN {Pointer, ProcTyp}) OR (l^.typ^.form IN {Pointer, ProcTyp}) THEN
OPM.WriteString("__VALP(");
ELSE
OPM.WriteString("__VAL(");
END;
OPC.Ident(n^.typ^.strobj); OPM.WriteString(Comma);
expr(l, MinPrec); OPM.Write(CloseParen)
END
ELSE OPM.err(200)
@ -760,7 +772,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
| Ncall:
IF (l^.obj # NIL) & (l^.obj^.mode = TProc) THEN
IF l^.subcl = super THEN proc := SuperProc(n)
ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(l^.obj)
ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(l^.obj)
END ;
OPC.Ident(proc);
n^.obj := proc^.link
@ -784,7 +796,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
if := n^.left; (* name := ""; *)
WHILE if # NIL DO
OPM.WriteString("if "); expr(if^.left, MaxPrec); (* if *)
OPM.Write(Blank); OPC.BegBlk;
OPM.Write(Blank); OPC.BegBlk;
IF (n^.class = 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
@ -869,18 +881,18 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
ELSIF base^.form = Pointer THEN OPM.WriteString("POINTER__typ")
ELSE OPM.WriteString("NIL")
END ;
OPM.WriteString(", "); OPM.WriteInt(base^.size); OPM.PromoteIntConstToLInt(); (* element size *)
OPM.WriteString(", "); OPM.WriteString("((LONGINT)("); OPM.WriteInt(base^.size); OPM.WriteString("))");
OPM.WriteString(", "); OPM.WriteInt(OPC.Base(base)); (* element alignment *)
OPM.WriteString(", "); OPM.WriteInt(nofdim); (* total number of dimensions = number of additional parameters *)
OPM.WriteString(", "); OPM.WriteInt(nofdim); (* total number of dimensions = number of additional parameters *)
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 expr(x, MinPrec); OPM.PromoteIntConstToLInt()
IF x^.class = Nconst THEN OPM.WriteString("(LONGINT)("); expr(x, MinPrec); OPM.WriteString(")")
ELSE OPM.WriteString("(LONGINT)"); expr(x, 10)
END ;
x := x^.link
ELSE OPM.WriteInt(typ^.n); OPM.PromoteIntConstToLInt()
ELSE OPM.WriteString("(LONGINT)"); OPM.WriteInt(typ^.n)
END ;
typ := typ^.BaseTyp
END ;
@ -1027,14 +1039,19 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
IF OPM.level = 0 THEN
IF mainprog THEN OPM.WriteString("__FINI") ELSE OPM.WriteString("__ENDMOD") END
ELSE
OPC.ExitProc(outerProc, FALSE, FALSE);
OPM.WriteString("return");
IF n^.left # NIL THEN OPM.Write(Blank);
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
OPM.WriteString("(void*)"); expr(n^.left, 10)
ELSE
expr(n^.left, MinPrec)
END
END;
OPM.WriteString(";"); OPM.WriteLn; OPC.BegStat;
OPC.ExitProc(outerProc, FALSE, FALSE);
OPM.WriteString("return _o_result");
ELSE
OPM.WriteString("return");
END
END
| Nwith:
@ -1050,7 +1067,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96
when compiling Texts0.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;
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 ;
n := n^.link

177
src/compiler/Vishap.Mod
View file

@ -1,37 +1,14 @@
MODULE voc; (* J. Templ 3.2.95 *)
MODULE Vishap; (* J. Templ 3.2.95 *)
IMPORT
SYSTEM, Unix, Kernel := Kernel0,
SYSTEM, Heap, Platform, Configuration,
OPP, OPB, OPT,
OPV, OPC, OPM,
extTools, Strings, vt100;
VAR mname : ARRAY 256 OF CHAR; (* noch *)
VAR mname : ARRAY 256 OF CHAR; (* noch *)
PROCEDURE -signal(sig: LONGINT; func: Unix.SignalHandler)
"signal(sig, func)";
PROCEDURE -fin()
"SYSTEM_FINALL()";
PROCEDURE -halt(): LONGINT
"SYSTEM_halt";
(*
PROCEDURE -gclock()
"SYSTEM_gclock = 1";
*)
PROCEDURE Trap(sig, code: LONGINT; scp: Unix.SigCtxPtr);
BEGIN fin();
IF sig = 3 THEN Unix.Exit(0)
ELSE
IF (sig = 4) & (halt() = -15) THEN OPM.LogWStr(" --- voc: internal error"); OPM.LogWLn END ;
Unix.Exit(2)
END
END Trap;
PROCEDURE Module*(VAR done: BOOLEAN);
VAR ext, new: BOOLEAN; p: OPT.Node;
BEGIN
@ -45,83 +22,111 @@ VAR mname : ARRAY 256 OF CHAR; (* noch *)
OPC.Init;
OPV.Module(p);
IF OPM.noerr THEN
(*IF (OPM.mainprog IN OPM.opt) & (OPM.modName # "SYSTEM") THEN*)
IF (OPM.mainProg OR OPM.mainLinkStat) & (OPM.modName # "SYSTEM") THEN
OPM.DeleteNewSym;
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.Green) END;
OPM.LogWStr(" main program");
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END;
OPM.DeleteNewSym;
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.Green) END;
OPM.LogWStr(" Main program.");
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END;
ELSE
IF new THEN
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.Green) END;
OPM.LogWStr(" new symbol file");
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END;
OPM.RegisterNewSym
ELSIF ext THEN OPM.LogWStr(" extended symbol file"); OPM.RegisterNewSym
IF new THEN
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.Green) END;
OPM.LogWStr(" New symbol file.");
IF ~OPM.notColorOutput THEN vt100.SetAttr(vt100.ResetAll) END;
OPM.RegisterNewSym
ELSIF ext THEN
OPM.LogWStr(" Extended symbol file.");
OPM.RegisterNewSym
END
END;
ELSE OPM.DeleteNewSym
ELSE
OPM.DeleteNewSym
END
END
END ;
END;
OPM.CloseFiles; OPT.Close;
OPM.LogWLn; done := OPM.noerr;
OPM.LogWLn;
done := OPM.noerr;
END Module;
PROCEDURE PropagateElementaryTypeSizes;
BEGIN
OPT.bytetyp.size := OPM.ByteSize;
OPT.sysptrtyp.size := OPM.PointerSize;
OPT.chartyp.size := OPM.CharSize;
OPT.settyp.size := OPM.SetSize;
OPT.realtyp.size := OPM.RealSize;
OPT.inttyp.size := OPM.IntSize;
OPT.linttyp.size := OPM.LIntSize;
OPT.lrltyp.size := OPM.LRealSize;
OPT.sinttyp.size := OPM.SIntSize;
OPT.booltyp.size := OPM.BoolSize;
END PropagateElementaryTypeSizes;
PROCEDURE Translate*;
VAR done: BOOLEAN;
VAR modulesobj: ARRAY 2048 OF CHAR; (* here we hold all modules name given on the command line, to add corresponding .o files to the external compiler options *)
VAR
done: BOOLEAN;
modulesobj: ARRAY 2048 OF CHAR; (* here we hold all modules name given on the command line, to add corresponding .o files to the external compiler options *)
BEGIN
modulesobj := "";
OPM.OpenPar; (* gclock(); slightly faste rtranslation but may lead to opening "too many files" *)
OPT.bytetyp.size := OPM.ByteSize;
(*OPT.int8typ.size := 1;
OPT.int16typ.size := 2;
OPT.int32typ.size := 4;
OPT.int64typ.size := 8;*)
OPT.sysptrtyp.size := OPM.PointerSize;
OPT.chartyp.size := OPM.CharSize;
OPT.settyp.size := OPM.SetSize;
OPT.realtyp.size := OPM.RealSize;
OPT.inttyp.size := OPM.IntSize;
OPT.linttyp.size := OPM.LIntSize;
OPT.lrltyp.size := OPM.LRealSize;
OPT.sinttyp.size := OPM.SIntSize;
OPT.booltyp.size := OPM.BoolSize;
LOOP
OPM.Init(done, mname);
IF ~done THEN EXIT END ;
OPM.InitOptions;
Kernel.GC(FALSE);
Module(done);
IF ~done THEN Unix.Exit(1) END;
IF OPM.OpenPar() THEN
(* gclock(); slightly faster translation but may lead to opening "too many files" *)
(* noch *)
IF done THEN
IF ~OPM.dontAsm THEN
extTools.Assemble(OPM.modName);
IF ~(OPM.mainProg OR OPM.mainLinkStat) THEN Strings.Append(" ",modulesobj); Strings.Append(OPM.modName, modulesobj); Strings.Append(".o ", modulesobj) END;
LOOP
OPM.Init(done, mname); (* Get next module name from command line *)
IF ~done THEN RETURN END ;
IF ~OPM.dontLink & (OPM.mainProg OR OPM.mainLinkStat) THEN
extTools.LinkMain (OPM.modName, OPM.mainLinkStat, modulesobj);
END;
END;
END
OPM.InitOptions; (* Get options ofr this module *)
PropagateElementaryTypeSizes;
(* Compile source to .c and .h files *)
Heap.GC(FALSE);
Module(done);
IF ~done THEN
OPM.LogWLn; OPM.LogWStr("Module compilation failed."); OPM.LogWLn;
Platform.Exit(1)
END;
END (* loop *)
(* 'assemble' (i.e. c compile) .c to object or executable. *)
IF ~OPM.dontAsm THEN
IF OPM.dontLink THEN
(* If not linking, just assemble each module. *)
extTools.Assemble(OPM.modName)
ELSE
IF ~(OPM.mainProg OR OPM.mainLinkStat) THEN
(* Assemble non main rogram and add object name to link list *)
extTools.Assemble(OPM.modName);
Strings.Append(" ", modulesobj);
Strings.Append(OPM.modName, modulesobj);
Strings.Append(Configuration.objext, modulesobj)
ELSE
(* Assemble and link main program *)
extTools.LinkMain (OPM.modName, OPM.mainLinkStat, modulesobj)
END
END
END
END (* loop *)
END
END Translate;
PROCEDURE Trap(sig: INTEGER);
BEGIN
Heap.FINALL();
IF sig = 3 THEN
Platform.Exit(0)
ELSE
IF (sig = 4) & (Platform.HaltCode = -15) THEN
OPM.LogWStr(" --- Vishap Oberon: internal error");
OPM.LogWLn
END ;
Platform.Exit(2)
END
END Trap;
BEGIN
signal(2, Trap); (* interrupt *)
signal(3, Trap); (* quit *)
signal(4, Trap); (* illegal instruction, HALT *)
Platform.SetInterruptHandler(Trap);
Platform.SetQuitHandler(Trap);
Platform.SetBadInstructionHandler(Trap);
OPB.typSize := OPV.TypSize; OPT.typSize := OPV.TypSize; Translate
END voc.
END Vishap.

140
src/compiler/extTools.Mod
View file

@ -1,88 +1,74 @@
MODULE extTools;
IMPORT Args, Unix, Strings, Console, version;
(*
INCLUDEPATH = -Isrc/lib/system/gnuc/x86_64
CCOPT = -fPIC $(INCLUDEPATH) -g
CLOBERONOPTS = -fPIC $(INCLUDEPATH) -L. -L/usr/lib -lOberon -static -g
CC = cc $(CCOPT) -c
*)
CONST compiler="gcc";
VAR incPath0, incPath1, ccOpt, ccString, CFLAGS, tmp0, tmp1 : ARRAY 1023 OF CHAR;
IMPORT Strings, Console, Configuration, Platform, OPM;
PROCEDURE Assemble*(m : ARRAY OF CHAR);
VAR cmd : ARRAY 1023 OF CHAR;
cc : ARRAY 1023 OF CHAR;
ext : ARRAY 5 OF CHAR;
VAR compilationOptions, CFLAGS: ARRAY 1023 OF CHAR;
PROCEDURE execute(title: ARRAY OF CHAR; cmd: ARRAY OF CHAR);
VAR r, status, exitcode: INTEGER;
BEGIN
COPY (ccString, cc);
Strings.Append (" -c ", cc);
COPY(cc, cmd);
Strings.Append (" ", cmd);
Strings.Append (ccOpt, cmd);
ext := ".c";
Strings.Append (ext, m);
Strings.Append(m, cmd);
(*Console.Ln; Console.String (cmd); Console.Ln;*)
Unix.system(cmd);
END Assemble;
IF OPM.Verbose THEN Console.String(title); Console.String(cmd); Console.Ln END;
r := Platform.System(cmd);
status := r MOD 128;
exitcode := r DIV 256;
IF exitcode > 127 THEN exitcode := exitcode - 256 END; (* Handle signed exit code *)
IF r # 0 THEN
Console.String(title); Console.String(cmd); Console.Ln;
Console.String("-- failed: status "); Console.Int(status,1);
Console.String(", exitcode "); Console.Int(exitcode,1);
Console.String("."); Console.Ln;
IF (status = 0) & (exitcode = 127) THEN
Console.String("Is the C compiler in the current command path?"); Console.Ln
END;
IF status # 0 THEN Platform.Halt(status) ELSE Platform.Halt(exitcode) END
END;
END execute;
PROCEDURE LinkMain*(VAR m : ARRAY OF CHAR; statically : BOOLEAN; additionalopts : ARRAY OF CHAR);
VAR lpath : ARRAY 1023 OF CHAR;
cc : ARRAY 1023 OF CHAR;
ccopt : ARRAY 1023 OF CHAR;
cmd : ARRAY 1023 OF CHAR;
ext : ARRAY 5 OF CHAR;
BEGIN
(*
gcc -g -o hello hello.c -I $RPATH/src/lib/system/gnuc/x86_64 -I. -I$RPATH -lOberon -L. -L$RPATH -static
*)
cmd := "";
cc := "";
ext := ".c";
COPY(ccString, cc);
COPY (cc, cmd);
Strings.Append(" ", cmd);
Strings.Append(m, cmd);
Strings.Append(ext, cmd);
Strings.Append(additionalopts, cmd);
IF statically THEN Strings.Append(" -static ", cmd) END;
Strings.Append(" -o ", cmd);
Strings.Append(m, cmd);
Strings.Append(" ", cmd);
PROCEDURE Assemble*(moduleName: ARRAY OF CHAR);
VAR
cmd: ARRAY 1023 OF CHAR;
BEGIN
cmd := Configuration.compile;
Strings.Append(compilationOptions, cmd);
Strings.Append("-c ", cmd);
Strings.Append(moduleName, cmd);
Strings.Append(".c", cmd);
execute("Assemble: ", cmd);
END Assemble;
Strings.Append (" -lVishapOberon -L. -L", ccOpt);
Strings.Append (version.prefix, ccOpt);
Strings.Append ("/lib ", ccOpt);
Strings.Append(ccOpt, cmd);
Console.Ln; Console.String(cmd); Console.Ln; (* may be it's feasible to add debug mode later *)
Unix.system(cmd);
END LinkMain;
PROCEDURE LinkMain*(VAR moduleName: ARRAY OF CHAR; statically: BOOLEAN; additionalopts: ARRAY OF CHAR);
VAR
cmd: ARRAY 1023 OF CHAR;
BEGIN
cmd := Configuration.compile;
Strings.Append(" ", cmd);
Strings.Append(compilationOptions, cmd);
Strings.Append(moduleName, cmd);
Strings.Append(".c ", cmd);
Strings.Append(additionalopts, cmd);
IF statically THEN
Strings.Append(Configuration.staticLink, cmd)
END;
Strings.Append(Configuration.objflag, cmd);
Strings.Append(moduleName, cmd);
Strings.Append(Configuration.linkflags, cmd);
Strings.Append(Configuration.installdir, cmd);
Strings.Append('/lib"', cmd);
Strings.Append(Configuration.libspec, cmd);
execute("Assemble and link: ", cmd);
END LinkMain;
BEGIN
incPath0 := "src/lib/system/linux/";
Strings.Append (compiler, incPath0);
incPath1 := "lib/voc/obj ";
ccOpt := " -fPIC -g ";
COPY ("-I ", tmp1);
Strings.Append (version.prefix, tmp1);
Strings.Append("/", tmp1);
Strings.Append(incPath0, tmp1);
Strings.Append("/", tmp1);
Strings.Append(version.arch, tmp1);
Strings.Append(" -I ", tmp1);
Strings.Append(version.prefix, tmp1);
Strings.Append("/", tmp1);
Strings.Append(incPath1, tmp1);
Strings.Append(tmp1, ccOpt);
Args.GetEnv("CFLAGS", CFLAGS);
Strings.Append (CFLAGS, ccOpt);
Strings.Append (" ", ccOpt);
ccString := compiler;
Strings.Append (" ", ccString);
Strings.Append(' -I "', compilationOptions);
Strings.Append(Configuration.installdir, compilationOptions);
Strings.Append('/include" ', compilationOptions);
Platform.GetEnv("CFLAGS", CFLAGS);
Strings.Append (CFLAGS, compilationOptions);
Strings.Append (" ", compilationOptions);
END extTools.