vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 05:12:26 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions
compiler/src/voc/OPT.Mod
Norayr Chilingarian 6a1eccd316 voc compiler first commit 
Former-commit-id: 760d826948
2013-09-27 22:34:17 +04:00

1243 lines
48 KiB
Modula-2
Raw Blame History

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;
CONST
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;
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 ;
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 ;
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 = 16;
VAR
typSize*: PROCEDURE(typ: Struct);
topScope*: Object;
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 *)
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;
(* 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;
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 ;
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;
PROCEDURE err(n: INTEGER);
BEGIN OPM.err(n)
END err;
PROCEDURE NewConst*(): Const;
VAR const: Const;
BEGIN NEW(const); RETURN const
END NewConst;
PROCEDURE NewObj*(): Object;
VAR obj: Object;
BEGIN NEW(obj); RETURN obj
END NewObj;
PROCEDURE NewStr*(form, comp: SHORTINT): 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
END NewStr;
PROCEDURE NewNode*(class: SHORTINT): Node;
VAR node: Node;
BEGIN NEW(node); node^.class := class; RETURN node
END NewNode;
PROCEDURE NewExt*(): ConstExt;
VAR ext: ConstExt;
BEGIN NEW(ext); RETURN ext
END NewExt;
PROCEDURE OpenScope*(level: SHORTINT; owner: 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
END OpenScope;
PROCEDURE CloseScope*;
BEGIN topScope := topScope^.left
END CloseScope;
PROCEDURE Init*(VAR name: OPS.Name; opt: SET);
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
END Init;
PROCEDURE Close*;
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
END Close;
PROCEDURE FindImport*(mod: Object; VAR res: 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
END FindImport;
PROCEDURE Find*(VAR res: 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
END Find;
PROCEDURE FindField*(VAR name: OPS.Name; typ: Struct; VAR res: 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
END FindField;
PROCEDURE Insert*(VAR name: OPS.Name; VAR obj: Object);
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
END Insert;
(*-------------------------- Fingerprinting --------------------------*)
PROCEDURE FPrintName(VAR fp: LONGINT; VAR name: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT ch := name[i]; OPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X
END FPrintName;
PROCEDURE ^IdFPrint*(typ: Struct);
PROCEDURE FPrintSign(VAR fp: LONGINT; result: Struct; par: Object);
(* depends on assignment compatibility of params only *)
BEGIN
IdFPrint(result); OPM.FPrint(fp, result^.idfp);
WHILE par # NIL DO
OPM.FPrint(fp, par^.mode); IdFPrint(par^.typ); OPM.FPrint(fp, par^.typ^.idfp);
(* par^.name and par^.adr not considered *)
par := par^.link
END
END FPrintSign;
PROCEDURE IdFPrint*(typ: Struct); (* idfp codifies assignment compatibility *)
VAR btyp: Struct; strobj: Object; idfp: LONGINT; f, c: INTEGER;
BEGIN
IF ~typ^.idfpdone THEN
typ^.idfpdone := TRUE; (* may be recursive, temporary idfp is 0 in that case *)
idfp := 0; f := typ^.form; c := typ^.comp; OPM.FPrint(idfp, f); OPM.FPrint(idfp, c);
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
IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp)
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 ;
typ^.idfp := idfp
END
END IdFPrint;
PROCEDURE FPrintStr*(typ: Struct);
VAR f, c: INTEGER; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: LONGINT;
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)
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;
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
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 ;
FPrintTProcs(obj^.right)
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
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:
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
END FPrintObj;
PROCEDURE FPrintErr*(obj: Object; errno: 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
END FPrintErr;
(*-------------------------- Import --------------------------*)
PROCEDURE InsertImport*(obj: Object; VAR root, old: Object);
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
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
END InName;
PROCEDURE InMod(VAR mno: SHORTINT); (* mno is global *)
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)
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;
BEGIN
CASE f OF
| Byte, Char, Bool:
OPM.SymRCh(ch); conval^.intval := ORD(ch)
| 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
END
END InConstant;
PROCEDURE ^InStruct(VAR typ: Struct);
PROCEDURE InSign(mno: SHORTINT; VAR res: Struct; VAR par: Object);
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
END InSign;
PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *)
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
END InFld;
PROCEDURE InTProc(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *)
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
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;
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 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)
END ;
IF ref = impCtxt.minr THEN
WHILE ref < impCtxt.nofr 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
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);
IF impCtxt.self THEN
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
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; 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
END
END Import;
(*-------------------------- Export --------------------------*)
PROCEDURE OutName(VAR name: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
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 *)
OPM.SymWInt(Smname);
expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm);
OutName(GlbMod[mno].name)
ELSE OPM.SymWInt(-expCtxt.locmno[mno])
END
END OutMod;
PROCEDURE ^OutStr(typ: Struct);
PROCEDURE ^OutFlds(fld: Object; adr: LONGINT; visible: BOOLEAN);
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
j := nofhdfld; OutHdFld(btyp, fld, adr);
IF j # nofhdfld THEN i := 1;
WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO
INC(adr, btyp^.size); OutHdFld(btyp, fld, adr); INC(i)
END
END
END
ELSIF OPM.ExpHdPtrFld & ((typ^.form = 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
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 ;
OutStr(fld^.typ); OutName(fld^.name); OPM.SymWInt(fld^.adr)
ELSE OutHdFld(fld^.typ, fld, fld^.adr + adr)
END ;
fld := fld^.link
END
END OutFlds;
PROCEDURE OutSign(result: Struct; par: Object);
BEGIN
OutStr(result);
WHILE par # NIL DO
IF par^.mode = Var THEN OPM.SymWInt(Svalpar) ELSE OPM.SymWInt(Svarpar) END ;
OutStr(par^.typ);
OPM.SymWInt(par^.adr);
OutName(par^.name); par := par^.link
END ;
OPM.SymWInt(Send)
END OutSign;
PROCEDURE OutTProcs(typ: Struct; obj: Object);
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
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
OPM.SymWInt(Stpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name);
OPM.SymWInt(obj^.adr DIV 10000H)
ELSE
OPM.SymWInt(Shdtpro);
OPM.SymWInt(obj^.adr DIV 10000H)
END
END
END ;
OutTProcs(typ, obj^.right)
END
END OutTProcs;
PROCEDURE OutStr(typ: Struct); (* OPV.TypeAlloc already applied *)
VAR strobj: Object;
BEGIN
IF typ^.ref < expCtxt.ref THEN OPM.SymWInt(-typ^.ref)
ELSE
OPM.SymWInt(Sstruct);
typ^.ref := expCtxt.ref; INC(expCtxt.ref);
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)
ELSE (* checked in OutObj or correct indirect export *)
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 ;
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)
END
END
END
END OutStr;
PROCEDURE OutConstant(obj: Object);
VAR f: INTEGER; rval: REAL;
BEGIN
f := obj^.typ^.form; OPM.SymWInt(f);
CASE f OF
| Bool, Char:
OPM.SymWCh(CHR(obj^.conval^.intval))
| SInt, Int, LInt:
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)
END
END OutConstant;
PROCEDURE OutObj(obj: Object);
VAR i, j: INTEGER; ext: ConstExt;
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
CASE obj^.history OF
| inserted: FPrintErr(obj, 253)
| same: (* ok *)
| pbmodified: FPrintErr(obj, 252)
| pvmodified: FPrintErr(obj, 251)
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)
END
END
END ;
OutObj(obj^.right)
END
END OutObj;
PROCEDURE Export*(VAR ext, new: BOOLEAN);
VAR i: INTEGER; nofmod: SHORTINT; done: BOOLEAN;
BEGIN
symExtended := FALSE; symNew := FALSE; nofmod := nofGmod;
Import("@self", SelfName, done); nofGmod := nofmod;
IF OPM.noerr THEN (* ~OPM.noerr => ~done *)
OPM.NewSym(SelfName);
IF OPM.noerr THEN
OPM.SymWInt(Smname); OutName(SelfName);
expCtxt.reffp := 0; expCtxt.ref := FirstRef;
expCtxt.nofm := 1; expCtxt.locmno[0] := 0;
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.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
(* OPM.RegisterNewSym is called in OP2 after writing the object file *)
END
END
END Export; (* no new symbol file if ~OPM.noerr or findpc *)
PROCEDURE InitStruct(VAR typ: Struct; form: SHORTINT);
BEGIN
typ := NewStr(form, 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;
PROCEDURE EnterBoolConst(name: OPS.Name; value: LONGINT);
VAR obj: Object;
BEGIN
Insert(name, obj); obj^.conval := NewConst();
obj^.mode := 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^.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
END EnterTyp;
PROCEDURE EnterProc(name: OPS.Name; num: INTEGER);
VAR obj: Object;
BEGIN Insert(name, obj);
obj^.mode := 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);
undftyp^.BaseTyp := undftyp;
(*initialization of module SYSTEM*)
EnterTyp("BYTE", Byte, OPM.ByteSize, bytetyp);
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);
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 *)
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[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
END OPT.
Objects:
mode | adr conval link scope leaf
------------------------------------------------
Undef | Not used
Var | vadr next regopt Glob or loc var or proc value parameter
VarPar| vadr next regopt Procedure var parameter
Con | val Constant
Fld | off next Record field
Typ | Named type
LProc | entry sizes firstpar scope leaf Local procedure, entry adr set in back-end
XProc | entry sizes firstpar scope leaf External procedure, entry adr set in back-end
SProc | fno sizes Standard procedure
CProc | code firstpar scope Code procedure
IProc | entry sizes scope leaf Interrupt procedure, entry adr set in back-end
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
----------------------------------------------------------------------------------
Undef Basic |
Byte Basic |
Bool Basic |
Char Basic |
SInt Basic |
Int Basic |
LInt Basic |
Real Basic |
LReal Basic |
Set Basic |
String Basic |
NilTyp Basic |
NoTyp Basic |
Pointer Basic | PBaseTyp mno txtpos sysflag
ProcTyp Basic | ResTyp params mno txtpos sysflag
Comp Array | nofel ElemTyp mno txtpos sysflag
Comp DynArr| dim ElemTyp mno txtpos sysflag
Comp Record| nofmth RBaseTyp fields mno txtpos sysflag
Nodes:
design = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc.
expr = design|Nconst|Nupto|Nmop|Ndop|Ncall.
nextexpr = NIL|expr.
ifstat = NIL|Nif.
casestat = Ncaselse.
sglcase = NIL|Ncasedo.
stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat|
Nloop|Nexit|Nreturn|Nwith|Ntrap.
class subcl obj left right link
---------------------------------------------------------
design Nvar var nextexpr
Nvarpar varpar nextexpr
Nfield field design nextexpr
Nderef design nextexpr
Nindex design expr nextexpr
Nguard design nextexpr (typ = guard type)
Neguard design nextexpr (typ = guard type)
Ntype type nextexpr
Nproc normal proc nextexpr
super proc nextexpr
expr design
Nconst const (val = node^.conval)
Nupto expr expr nextexpr
Nmop not expr nextexpr
minus expr nextexpr
is tsttype expr nextexpr
conv expr nextexpr
abs expr nextexpr
cap expr nextexpr
odd expr nextexpr
adr expr nextexpr SYSTEM.ADR
cc Nconst nextexpr SYSTEM.CC
val expr nextexpr SYSTEM.VAL
Ndop times expr expr nextexpr
slash expr expr nextexpr
div expr expr nextexpr
mod expr expr nextexpr
and expr expr nextexpr
plus expr expr nextexpr
minus expr expr nextexpr
or expr expr nextexpr
eql expr expr nextexpr
neq expr expr nextexpr
lss expr expr nextexpr
leq expr expr nextexpr
grt expr expr nextexpr
geq expr expr nextexpr
in expr expr nextexpr
ash expr expr nextexpr
msk expr Nconst nextexpr
len design Nconst nextexpr
bit expr expr nextexpr SYSTEM.BIT
lsh expr expr nextexpr SYSTEM.LSH
rot expr expr nextexpr SYSTEM.ROT
Ncall fpar design nextexpr nextexpr
nextexpr NIL
expr
ifstat NIL
Nif expr stat ifstat
casestat Ncaselse sglcase stat (minmax = node^.conval)
sglcase NIL
Ncasedo Nconst stat sglcase
stat NIL
Ninittd stat (of node^.typ)
Nenter proc stat stat stat (proc=NIL for mod)
Nassign assign design expr stat
newfn design stat
incfn design expr stat
decfn design expr stat
inclfn design expr stat
exclfn design expr stat
copyfn design expr stat
getfn design expr stat SYSTEM.GET
putfn expr expr stat SYSTEM.PUT
getrfn design Nconst stat SYSTEM.GETREG
putrfn Nconst expr stat SYSTEM.PUTREG
sysnewfn design expr stat SYSTEM.NEW
movefn expr expr stat SYSTEM.MOVE
(right^.link = 3rd par)
Ncall fpar design nextexpr stat
Nifelse ifstat stat stat
Ncase expr casestat stat
Nwhile expr stat stat
Nrepeat stat expr stat
Nloop stat stat
Nexit stat
Nreturn proc nextexpr stat (proc = NIL for mod)
Nwith ifstat stat stat
Ntrap expr stat
Reference in a new issue View git blame Copy permalink