(* Paco, Copyright 2000 - 2002, Patrik Reali, ETH Zurich *) MODULE PCOM; (** AUTHOR "prk"; PURPOSE "Parallel Compiler: symbol file plug-in"; *) (* PaCo, OM Symbol File Generator Warning: the SF tags must still be fine-tuned - remove SFcproc and fill hole - is SFtypSptr used? This file doesn't match exactly the OM-Format from mf/tk! SymFile = {modname} 0X [SFConst {Structure name val}] [SFvar {[SFreadonly] Structure name}] [SFxproc {Structure name ParList}] (* [SFlproc {Structure name ParList}] *) [SFoperator {Structure name ParList}] [SFcproc {Structure name ParList code}] [SFalias {Structure name}] [SFtyp {Structure}] SFEnd. ParList = {[SFvar] Structure name} SFEnd. Structure = Basic | UserStr | oldstr | modno (name | 0X oldimpstrn). Basic = SFtypBool .. SFtypNilTyp. UserStr = [SFinvisible][SFsysflag flag] UserStr2. UserStr2 = (SFtypOpenArr | SFtypDynArr) Structure name | SFtypArray Structure name sizen | SFtypPointer Structure name | SFtypProcTyp Structure name ParList | SFtypRecord Structure name prion flagsn RecStr RecDef = {[SFreadonly] Structure name}[SFtproc {Structure name ParList}] SFend. name object name written with 0X compression (last char incremented by 80X) initializers start with "&" record bodies @Body records invisible fields and methods are exported with name "" prio: any LONGINT flags: SET bit 0 Protectable bit 2 Active bit 3 Safe oldstr internal structure numbering ]-oo, 0] (!!! OM ]-oo, -1] !!!) on first export of an UserStr, a refnr is assigned, used then for further exports oldimpstr external structure numbering [0, +oo[ on first re-export of a structure, a refnr is assigned and then used for all the succesive exports Every imported module has an own re-export numbering. 1, 2, 4: Size of the value n: compressed number (WriteNum/ReadNum) *) IMPORT SYSTEM, Modules, StringPool, PCM, PCS, PCT, PCBT, PCLIR; CONST Trace = FALSE; TraceCalls = FALSE; (*exported procedures*) TraceImport = FALSE; StrictChecks = TRUE; (*some more sanity checks*) TraceFPName = "D1"; TraceFP = TRUE; ImportedModuleFlag = {}; (* ImportedModuleFlag = {PCT.Overloading}; *) (* ProgTools.Enumerate 01 SFtypBool SFtypChar8 SFtypInt8 SFtypInt16 SFtypInt32 SFtypInt64 SFtypFloat32 SFtypFloat64 SFtypSet SFtypString SFtypNoTyp SFtypNilTyp SFtypByte SFtypSptr SFmod1 ~ ProgTools.Enum 01 SFtypBool SFtypChar8 SFtypChar16 SFtypChar32 SFtypInt8 SFtypInt16 SFtypInt32 SFtypInt64 SFtypFloat32 SFtypFloat64 SFtypSet SFtypString SFtypNoTyp SFtypNilTyp SFtypByte SFtypSptr SFmod1 ~ *) (* Symbol File Tags *) UndefTag = -1; (* SFtypBool=01H; SFtypChar8=02H; SFtypInt8=03H; SFtypInt16=04H; SFtypInt32=05H; SFtypInt64=06H; SFtypFloat32=07H; SFtypFloat64=08H; SFtypSet=09H; SFtypString=0AH; SFtypNoTyp=0BH; SFtypNilTyp=0CH; SFtypByte=0DH; SFtypSptr=0EH; SFmod1=0FH; *) SFtypBool = 1; SFtypChar8 = 2; SFtypChar16 = 3; SFtypChar32 = 4; SFtypInt8 = 5; SFtypInt16 = 6; SFtypInt32 = 7; SFtypInt64 = 8; SFtypFloat32 = 9; SFtypFloat64 = 10; SFtypSet = 11; SFtypString = 12; SFtypNoTyp = 13; SFtypNilTyp = 14; SFtypByte = 15; SFtypSptr = 16; SFmod1 = 17; SFlastStruct = SFtypSptr; SFmodOther=2DH; SFtypOpenArr=2EH; SFtypDynArr=2FH; SFtypArray=30H; SFtypPointer=31H; SFtypRecord=32H; SFtypProcTyp=33H; SFsysflag=34H; SFinvisible=35H; SFreadonly=36H; SFobjflag = 37H; (* fof: very (!) bad idea to have same number for two type flags *) SFconst=37H; SFvar=38H; SFlproc=39H; SFxproc=3AH; SFoperator=3BH; SFtproc=3CH; SFcproc = SFtproc; SFalias=3DH; SFtyp=3EH; SFend= 3FH; (** fof >> *) SFtypOpenEnhArr = 40H; SFtypDynEnhArr = 41H; SFtypTensor=42H; SFtypStaticEnhArray = 43H; (*fof*) (** << fof *) (* workaround: handle inlined operators *) InlineMarker = 0ABH; SFdelegate = 5; (*Fingerprints/Obj Modes*) FPMvar=1; FPMpar=1; FPMvarpar=2; FPMconst=3; FPMfield=4; FPMtype=5; FPMxproc=7; FPMcproc=9; FPMmethod=13; FPMinit=14; (*Fingerprints/Type Forms*) FPFbyte = 1; FPFbool=2; FPFchar8=3; FPFint8typ=4; FPFint16typ=5; FPFint32typ=6; FPFfloat32typ=7; FPFfloat64typ=8; FPFsettyp=9; FPFstringtyp=10; FPFnotyp = 12; FPFpointer=13; FPFproc=14; FPFcomp=15; FPFint64typ=16; FPFchar16typ = 17; FPFchar32typ = 18; FPFbasic=1; FPFstaticarr=2; FPFdynarr=4; FPFopenarr=5; FPFrecord=6; FPintern=0; FPextern=1; FPexternR=2; FPothervis =3; FPfalse=0; FPtrue=1; FPhasBody = 2H; FPprotected = 10H; FPactive = 20H; FPdelegate = 5; FPsystemType = 6; empty = -1; (*empty string index*) readonly = PCT.Internal + {PCT.PublicR}; TYPE ReadStringProc = PROCEDURE (VAR R: PCM.SymReader; VAR string: ARRAY OF CHAR); StringBuf = ARRAY 256 OF CHAR; ImportList = POINTER TO ARRAY OF StringPool.Index; Symbol* = OBJECT (PCM.Attribute) (*attributes for PCT.Symbol*) VAR fp*: LONGINT; (*fingerprint*) sibling: PCT.Symbol; END Symbol; Struct* = OBJECT (PCM.Attribute) (*attributes for PCT.Struct*) VAR fp*, pbfp*, pvfp*: LONGINT; (*fingerprint*) fpdone* {UNTRACED} : PCT.Module; (*module relative to which the fp has been computed*) strref*: LONGINT; (*import: index for struct array*) tag: LONGINT; (*tag->export/import number*) uref*: LONGINT; mod*: PCT.Module; (*defining module*) PROCEDURE & Init*(mod: PCT.Module); BEGIN fpdone := NIL; tag := UndefTag; fp := 0; pbfp := 0; pbfp := 0; IF mod # NIL THEN SELF.mod := mod.scope.owner END (* canonical representation *) END Init; END Struct; StructArray = POINTER TO ARRAY OF PCT.Struct; Module* = OBJECT (PCM.Attribute) (*attributes for PCT.Module*) VAR nofimp: LONGINT; import: PCT.ModuleArray; (*import: list of all modules imported by SELF, [0..nofimp[*) nofstr: LONGINT; struct: StructArray; (*import: list of own structures, [0..nofstr[ *) nofreimp: LONGINT; reimp: StructArray; (*import of main: list of structs used by main, [0..nofreimp[*) expnumber: LONGINT; (*export of main: this module reference [1..oo[ ; OM uses mode for this*) changed: BOOLEAN; (*self-import: imported obj doesn't exist anymore*) PROCEDURE & Init*; BEGIN changed:=FALSE; nofimp:=0; nofstr:=0; nofreimp:=0; expnumber:=0; NEW(struct, 32); END Init; END Module; VAR predefStruct: ARRAY SFlastStruct+1 OF PCT.Struct; (* FPvis: ARRAY 5 OF SHORTINT; *) FParray: ARRAY 6 OF SHORTINT; altSelf: PCS.Name; (*predefined strings*) Ninterfaces, NpatchPointer0: LONGINT; (** ========== Symbol Table Checker ============== *) (** ---------- Fingerprinting -------------- *) PROCEDURE FPrint(VAR fp: LONGINT; val: LONGINT); BEGIN fp:=SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, ROT(fp, 7)) / SYSTEM.VAL(SET, val)) END FPrint; PROCEDURE FPrintSet(VAR fp: LONGINT; set: SET); BEGIN FPrint(fp, SYSTEM.VAL(LONGINT, set)) END FPrintSet; PROCEDURE FPrintReal(VAR fp: LONGINT; real: REAL); BEGIN FPrint(fp, SYSTEM.VAL(LONGINT, real)) END FPrintReal; PROCEDURE FPrintLReal(VAR fp: LONGINT; lr: LONGREAL); VAR l, h: LONGINT; BEGIN SYSTEM.GET(ADDRESSOF(lr)+4, l); SYSTEM.GET(ADDRESSOF(lr), h); FPrint(fp, l); FPrint(fp, h); END FPrintLReal; PROCEDURE FPrintName*(VAR fp: LONGINT; name: ARRAY OF CHAR); VAR i: INTEGER; ch: CHAR; BEGIN i:=0; REPEAT ch:=name[i]; FPrint(fp, ORD(ch)); INC(i) UNTIL ch=0X END FPrintName; PROCEDURE FPrintVis(VAR fp: LONGINT; vis: SET); BEGIN IF vis = PCT.Public THEN FPrint(fp, FPextern) ELSIF vis = readonly THEN FPrint(fp, FPexternR) ELSIF vis = PCT.Internal THEN FPrint(fp, FPintern) ELSE FPrint(fp, FPothervis + SYSTEM.VAL(LONGINT, vis)) (* HALT(99) *) END END FPrintVis; PROCEDURE FPrintSign(VAR fp: LONGINT; par: PCT.Parameter; self: PCT.Parameter; ret: PCT.Struct; current: PCT.Module; isOperator: BOOLEAN); PROCEDURE FPrintPar(VAR fp: LONGINT; par: PCT.Parameter; current: PCT.Module); VAR str: StringBuf; BEGIN IF par.ref THEN FPrint(fp, FPMvarpar) ELSE FPrint(fp, FPMpar) END; IF par.type # NIL THEN FPrintTyp0(par.type, current); FPrint(fp, par.type.sym(Struct).fp) END; IF isOperator & (par.type # NIL) & (par.type.owner # NIL) THEN StringPool.GetString(par.type.owner.name, str); FPrintName(fp, str); END; END FPrintPar; BEGIN FPrintTyp0(ret, current); FPrint(fp, ret.sym(Struct).fp); IF self # NIL THEN FPrintPar(fp, self, current) END; WHILE (par#self) DO FPrintPar(fp, par, current); par:=par.nextPar END; END FPrintSign; PROCEDURE FPrintMeth(VAR pbfp, pvfp: LONGINT; mth, init, body: PCT.Method; current: PCT.Module); VAR fp: LONGINT; oAttr: Symbol; str: StringBuf; BEGIN IF (mth.vis # PCT.Internal) THEN IF mth.sym=NIL THEN NEW(oAttr); mth.sym:=oAttr ELSE oAttr := mth.sym(Symbol) END; fp:=0; FPrint(fp, FPMmethod); StringPool.GetString(mth.name, str); FPrintName(fp, str); FPrintSign(fp, mth.scope.firstPar, mth.self, mth.type, current, FALSE); (* IF mth = init THEN FPrint(fp, -1) END; *) oAttr.fp:=fp; (* mfix *) FPrint(fp, mth.adr(PCBT.Method).mthNo); IF mth # body THEN FPrint(pbfp, fp); FPrint(pvfp, fp) END END END FPrintMeth; PROCEDURE FPrintRecord(typ: PCT.Record; current: PCT.Module); VAR p: PCT.Symbol; fld: PCT.Variable; adr, i, flags, fp, pbfp, pvfp: LONGINT; tAttr: Struct; oAttr: Symbol; scope: PCT.RecScope; intf: PCT.Interface; name: ARRAY 32 OF CHAR; dump: BOOLEAN; str: StringBuf; BEGIN IF TraceFP THEN PCT.GetTypeName(typ, name); dump := name = TraceFPName END; tAttr := typ.sym(Struct); pvfp := tAttr.fp; pbfp := tAttr.fp; IF TraceFP & dump THEN PCM.LogWLn; PCM.LogWStr("FPRec, Base "); PCM.LogWHex(pvfp) END; scope := typ.scope; IF typ.intf # NIL THEN FOR i := 0 TO LEN(typ.intf)-1 DO intf := typ.intf[i]; FPrintTyp(intf, current); tAttr := intf.sym(Struct); FPrint(pvfp, tAttr.pvfp); FPrint(pbfp, tAttr.pbfp); END END; IF typ.brec#NIL THEN tAttr := typ.brec.sym(Struct); FPrint(pvfp, tAttr.pvfp); FPrint(pbfp, tAttr.pbfp); END; IF TraceFP & dump THEN PCM.LogWLn; PCM.LogWStr("FPRec, Init "); PCM.LogWHex(pvfp); PCM.LogWStr(" "); PCM.LogWHex(pbfp) END; p := scope.sorted; WHILE p # NIL DO IF p IS PCT.Method THEN WITH p: PCT.Method DO FPrintMeth(pbfp, pvfp, p, scope.initproc, scope.body, current); IF TraceFP & dump THEN PCM.LogWLn; PCM.LogWStr("FPRec, Mth "); PCM.LogWHex(pvfp); PCM.LogWStr(" "); PCM.LogWHex(pbfp); PCM.LogWStr(" "); PCM.LogWStr0(p.name); PCM.LogWStr(" "); PCM.LogWNum(p.adr(PCBT.Method).mthNo); PCM.LogWStr(" "); IF p = scope.body THEN PCM.LogWStr("B") END; IF p = scope.initproc THEN PCM.LogWStr("&") END END END END; p := p.sorted END; fld := scope.firstVar; WHILE fld#NIL DO FPrintTyp(fld.type, current); tAttr := fld.type.sym(Struct); IF fld.vis#PCT.Internal THEN fp:=0; FPrint(fp, FPMfield); StringPool.GetString(fld.name, str); FPrintName(fp, str); FPrintVis(fp, fld.vis); IF PCM.Untraced IN fld.flags THEN FPrint(fp, PCM.Untraced) END; FPrint(fp, tAttr.fp); IF fld.sym = NIL THEN NEW(oAttr); fld.sym := oAttr ELSE oAttr := fld.sym(Symbol) END; oAttr.fp:=fp; adr := fld.adr(PCBT.Variable).offset; FPrint(pbfp, tAttr.pbfp); FPrint(pbfp, adr); FPrint(pvfp, tAttr.pvfp); FPrint(pvfp, adr); FPrint(pvfp, fp); FPrint(pbfp, fp); ELSE fp := 0; IF PCM.Untraced IN fld.flags THEN FPrint(fp, PCM.Untraced) END; FPrint(pvfp, fp) (* seems an error to me, I would use FPrint(pvfp, tAttr.fp) *) END; IF TraceFP & dump THEN PCM.LogWLn; PCM.LogWStr("FPRec, Fld "); PCM.LogWHex(pvfp); PCM.LogWStr(" "); PCM.LogWHex(pbfp); PCM.LogWStr(" "); PCM.LogWStr0(fld.name); PCM.LogWStr(" "); PCM.LogWNum(adr); END; fld := fld.nextVar END; IF ~(PCT.exclusive IN typ.mode) & (typ.brec # NIL) & (PCT.exclusive IN typ.brec.mode)THEN INCL(typ.mode, PCT.exclusive) END; flags := 0; IF scope.body # NIL THEN INC(flags, FPhasBody) END; IF PCT.active IN typ.mode THEN INC(flags, FPactive) END; IF PCT.exclusive IN typ.mode THEN INC(flags, FPprotected) END; FPrint(pbfp, flags); IF TraceFP & dump THEN PCM.LogWLn; PCM.LogWStr("FPRec, Flg "); PCM.LogWHex(pvfp); PCM.LogWStr(" "); PCM.LogWHex(pbfp); PCM.LogWHex(flags) END; tAttr := typ.sym(Struct); tAttr.pbfp := pbfp; tAttr.pvfp := pvfp; (* replace typ.pbfp with pbfp and typ.pvfp with pvfp *) END FPrintRecord; PROCEDURE FPrintTyp0(typ: PCT.Struct; current: PCT.Module); (* calculate fingerprint without looking at record fields, private and public fingerprints *) VAR fp, i: LONGINT; mode: SHORTINT; rec: PCT.Record; intf: PCT.Interface; tAttr: Struct; base: PCT.Struct; name: ARRAY 32 OF CHAR; dump: BOOLEAN; str: StringBuf; PROCEDURE Name; (*has side effects on the local variables!!!*) (* VAR str: StringBuf; *) BEGIN IF (tAttr.mod # NIL) & (tAttr.mod.scope # current.scope) THEN (*imported*) StringPool.GetString(tAttr.mod.name, str); FPrintName(fp, str); IF typ.owner#NIL THEN StringPool.GetString(typ.owner.name, str); FPrintName(fp, str) ELSE FPrint(fp, 0) END END; IF dump THEN PCM.LogWLn; PCM.LogWStr("FPTyp0, Name "); PCM.LogWHex(fp); PCM.LogWStr(" "); PCM.LogWStr0(current.name); PCM.LogWStr(" "); PCM.LogWStr0(tAttr.mod.name); PCM.LogWStr(" "); PCM.LogWStr(str); END END Name; BEGIN ASSERT(typ#NIL); IF ~(typ IS PCT.Basic) & (typ # PCT.String) & (typ # PCT.NilType) & (typ # PCT.NoType) THEN IF TraceFP THEN PCT.GetTypeName(typ, name); dump := name = TraceFPName END; IF typ.sym=NIL THEN NEW(tAttr, current); typ.sym:=tAttr (* ;PCM.LogWLn; PCM.LogWStr(" struc0 "); IF typ.owner # NIL THEN PCM.LogWStr0(typ.owner.name) END *) ELSE tAttr:=typ.sym(Struct) END; IF tAttr.fpdone # current THEN tAttr.fpdone := NIL END; (* reset fpdone: fp can be changed without changing it calling through FPSign! *) fp:=0; IF typ IS PCT.Pointer THEN FPrint(fp, FPFpointer); FPrint(fp, FPFbasic); ASSERT(typ.flags = {}); Name; tAttr.fp:=fp; base := typ(PCT.Pointer).base; FPrintTyp0(base, current); FPrint(tAttr.fp, base.sym(Struct).fp); ELSIF typ IS PCT.Record THEN FPrint(fp, FPFcomp); FPrint(fp, FPFrecord); IF PCT.SystemType IN typ.flags THEN FPrint(fp, FPsystemType) END; rec := typ(PCT.Record); Name; tAttr.fp:=fp; IF rec.intf # NIL THEN FOR i := 0 TO LEN(rec.intf)-1 DO intf := rec.intf[i]; FPrintTyp0(intf, current); FPrint(tAttr.fp, intf.sym(Struct).fp) END END; IF rec.brec # NIL THEN FPrintTyp0(rec.brec, current); FPrint(tAttr.fp, rec.brec.sym(Struct).fp) END; IF dump & (rec.brec # NIL) THEN PCM.LogWLn; PCM.LogWStr("FPTyp0, has base ") END ELSIF typ IS PCT.Array THEN WITH typ: PCT.Array DO mode := typ.mode; FPrint(fp, FPFcomp); FPrint(fp, FParray[mode]); ASSERT(typ.flags = {}); Name; tAttr.fp:=fp; IF mode IN {PCT.static, PCT.open} THEN FPrintTyp0(typ.base, current); FPrint(tAttr.fp, typ.base.sym(Struct).fp); IF mode=PCT.static THEN FPrint(tAttr.fp, typ.len) END END; tAttr.pbfp:=tAttr.fp; tAttr.pvfp:=tAttr.fp END (** fof >> *) ELSIF typ IS PCT.EnhArray THEN (*fof*) WITH typ: PCT.EnhArray DO mode := typ.mode; FPrint( fp, FPFcomp ); FPrint( fp, FParray[mode] ); (*ASSERT(typ.flags = {});*) Name; tAttr.fp := fp; IF mode IN {PCT.static, PCT.open} THEN FPrintTyp0( typ.base, current ); FPrint( tAttr.fp, typ.base.sym( Struct ).fp ); IF mode = PCT.static THEN FPrint( tAttr.fp, typ.len ) END END; tAttr.pbfp := tAttr.fp; tAttr.pvfp := tAttr.fp END ELSIF typ IS PCT.Tensor THEN WITH typ: PCT.Tensor DO FPrint( fp, FPFcomp ); Name; tAttr.fp := fp; FPrintTyp0( typ.base, current ); FPrint( tAttr.fp, typ.base.sym( Struct ).fp ); tAttr.pbfp := tAttr.fp; tAttr.pvfp := tAttr.fp END; (** << fof *) ELSIF typ IS PCT.Delegate THEN WITH typ: PCT.Delegate DO FPrint(fp, FPFproc); FPrint(fp, FPFbasic); IF ~(PCT.StaticMethodsOnly IN typ.flags) THEN FPrint(fp, FPdelegate) END; Name; tAttr.fp:=fp; FPrintSign(tAttr.fp, typ.scope.firstPar, NIL, typ.return, current, FALSE); tAttr.pbfp:=tAttr.fp; tAttr.pvfp:=tAttr.fp END END; IF dump THEN PCM.LogWLn; PCM.LogWStr("FPTyp0, End "); PCM.LogWHex(tAttr.fp) END END END FPrintTyp0; PROCEDURE FPrintTyp*(typ: PCT.Struct; current: PCT.Module); (* fpdone 0: not done yet >0: done for module fpdone-1 =-1: built in type *) VAR tAttr: Struct; name: ARRAY 32 OF CHAR; BEGIN current := current.scope.owner; (* canonical representation *) IF typ.sym=NIL THEN NEW(tAttr, current); typ.sym:=tAttr (* ;PCM.LogWLn; PCM.LogWStr(" struct "); IF typ.owner # NIL THEN PCM.LogWStr0(typ.owner.name) END *) ELSE tAttr:=typ.sym(Struct) END; IF ~(typ IS PCT.Basic) & (tAttr.fpdone # current) THEN IF TraceCalls THEN PCT.GetTypeName(typ, name); PCM.LogWLn; PCM.LogWStr("->FPrintTyp "); PCM.LogWStr(name); END; FPrintTyp0(typ, current); IF ~(typ IS PCT.Record) THEN tAttr.fpdone := current END; IF typ IS PCT.Pointer THEN FPrintTyp(typ(PCT.Pointer).base, current) ELSIF typ IS PCT.Array THEN FPrintTyp(typ(PCT.Array).base, current) (** fof >> *) ELSIF typ IS PCT.EnhArray THEN FPrintTyp( typ( PCT.EnhArray ).base, current ) (*fof*) ELSIF typ IS PCT.Tensor THEN FPrintTyp( typ( PCT.Tensor ).base, current ) (*fof*) (** << fof *) ELSIF typ IS PCT.Record THEN WITH typ: PCT.Record DO FPrintTyp(typ.btyp, current); IF (typ.brec # NIL) & (typ.brec.sym(Struct).fpdone # current) THEN PCT.GetTypeName(typ, name); (* PCM.LogWLn; PCM.LogWStr(" FPTyp, warning "); PCM.LogWStr(name); *) FPrintTyp(typ.brec, current) END; FPrintRecord(typ, current) END END; tAttr.fpdone:=current; IF TraceCalls THEN PCM.LogWLn; PCM.LogWStr("<-FPrintTyp "); PCM.LogWStr(name); END; IF TraceFP THEN PCT.GetTypeName(typ, name); IF name = TraceFPName THEN PCM.LogWLn; PCM.LogWStr("FPTyp "); PCM.LogWHex(tAttr.fp); PCM.LogWStr(" "); PCM.LogWHex(tAttr.pvfp); PCM.LogWStr(" "); PCM.LogWHex(tAttr.pbfp); END END END; END FPrintTyp; (** fof >> *) PROCEDURE FPrintConstEnhArray( VAR fp: LONGINT; val: PCT.Value ); BEGIN IF val.vis # PCT.Internal THEN PCM.Error( -1, -1, "const arrays not fingerprinted yet" ) END; (* otherwise a change does not change the module *) END FPrintConstEnhArray; (** << fof *) PROCEDURE FPrintObj*(obj: PCT.Symbol; current: PCT.Module); VAR fp, len, pos: LONGINT; con: PCT.Const; oAttr: Symbol; c: PCLIR.AsmBlock; str: StringBuf; BEGIN current := current.scope.owner; (* canonical representation *) (*PCM.LogWLn; PCM.LogWStr("FPrintObj "); PCM.LogWStr(obj.name);*) StringPool.GetString(obj.name, str); IF TraceCalls THEN PCM.LogWLn; PCM.LogWStr("->FPrintObj "); PCM.LogWStr(str); END; fp:=0; IF obj.sym=NIL THEN NEW(oAttr); obj.sym:=oAttr ELSE oAttr:=obj.sym(Symbol) END; IF obj IS PCT.Value THEN FPrint(fp, FPMconst); FPrintName(fp, str); FPrintVis(fp, obj.vis); IF obj.type.sym # NIL THEN (** fof 070731*) FPrint(fp, obj.type.sym(Struct).fp); END; (** fof 070731 *) FPrint(fp, FPFbasic); con:=obj(PCT.Value).const; IF con.type=PCT.Bool THEN IF con.bool THEN FPrint(fp, FPtrue) ELSE FPrint(fp, FPfalse) END ELSIF con.type=PCT.Char8 THEN FPrint(fp, con.int) ELSIF con.type=PCT.Int64 THEN FPrintLReal(fp, SYSTEM.VAL(LONGREAL, con.long)) ELSIF PCT.IsCardinalType(con.type) THEN FPrint(fp, con.int) ELSIF con.type=PCT.Set THEN FPrintSet(fp, con.set) ELSIF con.type=PCT.Float32 THEN FPrintReal(fp, SHORT(con.real)) ELSIF con.type=PCT.Float64 THEN FPrintLReal(fp, con.real) ELSIF con.type=PCT.String THEN FPrintName(fp, con.str^) (** fof >> *) ELSIF con.type IS PCT.EnhArray THEN FPrintConstEnhArray( fp, obj( PCT.Value ) ); (** << fof *) ELSE HALT(99) END ELSIF obj IS PCT.GlobalVar THEN FPrint(fp, FPMvar); FPrintName(fp, str); FPrintVis(fp, obj.vis); FPrintTyp(obj.type, current); FPrint(fp, obj.type.sym(Struct).fp); ELSIF (obj IS PCT.Proc)&(obj.vis=PCT.Public) THEN WITH obj: PCT.Proc DO IF PCT.Inline IN obj.flags THEN FPrint(fp, FPMcproc); FPrintName(fp, str); FPrintVis(fp, obj.vis); FPrintSign(fp, obj.scope.firstPar, NIL, obj.type, current, PCT.Operator IN obj.flags); c := obj.scope.code(PCLIR.AsmInline).code; WHILE c # NIL DO len := c.len; pos := 0; FPrint(fp, len); WHILE pos < len DO FPrint(fp, ORD(c.code[pos])); INC(pos) END; c := c.next END; ELSE FPrint(fp, FPMxproc); FPrintName(fp, str); FPrintVis(fp, obj.vis); FPrintSign(fp, obj.scope.firstPar, NIL, obj.type, current, PCT.Operator IN obj.flags) END END ELSIF obj IS PCT.Type THEN FPrint(fp, FPMtype); FPrintName(fp, str); FPrintVis(fp, obj.vis); FPrintTyp(obj.type, current); FPrint(fp, obj.type.sym(Struct).fp); END; oAttr.fp:=fp; IF TraceCalls THEN PCM.LogWLn; PCM.LogWStr("<-FPrintObj "); PCM.LogWStr(str); END END FPrintObj; (* ========== Symbol File Saver ============== *) PROCEDURE Export*(VAR r: PCM.Rider; M: PCT.Module; new, extend, skipImport: BOOLEAN; VAR msg: ARRAY OF CHAR); VAR name: StringBuf; oldM: PCT.Module; nofstruct: LONGINT; newsym, changed, extended: BOOLEAN; MAttr: Module; impList: ImportList; PROCEDURE TypeChanged(new, old: PCT.Struct): BOOLEAN; VAR newstr, oldstr: Struct; BEGIN IF (new IS PCT.Record) THEN (* if type composition different -> fp different! *) newstr := new.sym(Struct); oldstr := old.sym(Struct); RETURN (newstr.pbfp # oldstr.pbfp) OR (newstr.pvfp # oldstr.pvfp) ELSIF (new IS PCT.Pointer) THEN RETURN TypeChanged(new(PCT.Pointer).base, old(PCT.Pointer).base) ELSIF (new IS PCT.Array) THEN RETURN TypeChanged(new(PCT.Array).base, old(PCT.Array).base) (** fof >> *) ELSIF (new IS PCT.EnhArray) THEN (*fof*) RETURN TypeChanged( new( PCT.EnhArray ).base, old( PCT.EnhArray ).base ) ELSIF (new IS PCT.Tensor) THEN RETURN TypeChanged( new( PCT.Tensor ).base, old( PCT.Tensor ).base ) (** << fof *) END; RETURN FALSE END TypeChanged; PROCEDURE CompareSymbol(new: PCT.Symbol; e, s: BOOLEAN); VAR old: PCT.Symbol; newsym: Symbol; BEGIN IF Trace THEN PCM.LogWLn; PCM.LogWStr("PCOM.Compare "); PCM.LogWStr0(new.name) END; FPrintObj(new, M); (*always compute the fp, will be used by other compiler components*) newsym := new.sym(Symbol); old := newsym.sibling; IF old # NIL THEN (* an old version exists .... *) FPrintObj(old, M); (* operators are not checked for changes *) IF ~(PCT.Operator IN new.flags) THEN IF (old.sym(Symbol).fp # newsym.fp) OR ((new IS PCT.Type) OR (new.type IS PCT.Record) & (new.type.owner = NIL)) & TypeChanged(new.type, old.type) THEN changed:=TRUE; PCM.ErrorN(402, PCM.InvalidPosition, new.name) END END ELSIF new.vis # PCT.Internal THEN (*new export*) extended:=TRUE; PCM.ErrorN(403, PCM.InvalidPosition, new.name) END END CompareSymbol; PROCEDURE OutParList(p: PCT.Parameter); (* export procedure parameters. Methods: self is already exported *) BEGIN WHILE (p # NIL) & (p.name # PCT.SelfName) DO IF PCT.WinAPIParam IN p.flags THEN (* ejz *) PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.WinAPIParam) ELSIF PCT.CParam IN p.flags THEN (* fof for Linux *) PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.CParam) END; IF p.ref THEN PCM.SymWNum(r, SFvar); END; (** fof >> *) IF PCM.ReadOnly IN p.flags THEN (* fof *) PCM.SymWNum(r, SFreadonly); END; (** << fof *) OutObj(p); p := p.nextPar END; PCM.SymWNum(r,SFend) END OutParList; PROCEDURE OutConst(c: PCT.Const); VAR type: PCT.Struct; BEGIN type := c.type; IF type = PCT.Char8 THEN PCM.SymWNum(r, c.int) ELSIF type = PCT.Int64 THEN PCM.SymWLReal(r, SYSTEM.VAL(LONGREAL, c.long)) ELSIF PCT.IsCardinalType(type) THEN PCM.SymWNum(r, c.int) ELSIF type = PCT.Float32 THEN PCM.SymWReal(r, SHORT(c.real)) ELSIF type = PCT.Float64 THEN PCM.SymWLReal(r, c.real) ELSIF type = PCT.String THEN PCM.SymWString(r, c.str^) ELSIF type = PCT.Bool THEN PCM.SymWNum(r, SYSTEM.VAL(SHORTINT, c.bool)) ELSIF type = PCT.Set THEN PCM.SymWNum(r, SYSTEM.VAL(LONGINT, c.set)) (** fof >> *) ELSIF type IS PCT.EnhArray THEN PCM.Error( 200, -1, "const arrays cannot be exported yet" ); (** << fof *) ELSE HALT(99) END END OutConst; PROCEDURE OutImpMod(name: ARRAY OF CHAR; mAttr: Module); VAR m: Module; index: StringPool.Index; BEGIN IF mAttr.expnumber = 0 THEN (*first export from this module*) (* PCM.SymWMod(r, name); (*real name, not alias*) *) StringPool.GetIndex(name, index); AddImport(impList, index); (* m := mAttr.main.sym(Module); ASSERT(mAttr.main = M); *) m := M.sym(Module); INC(m.expnumber); mAttr.expnumber := m.expnumber; mAttr.nofreimp := 0 END END OutImpMod; PROCEDURE OutRecord(rec: PCT.Record); VAR scope: PCT.RecScope; str: StringBuf; fld: PCT.Variable; mth: PCT.Method; first: BOOLEAN; BEGIN scope := rec.scope; PCM.SymWSet(r, rec.mode); PCM.SymW(r, CHR(rec.prio)); fld := scope.firstVar; WHILE fld # NIL DO (*fields*) IF PCM.Untraced IN fld.flags THEN PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.Untraced) END; IF fld.vis=readonly THEN PCM.SymWNum(r, SFreadonly) END; OutStruct(fld.type); IF fld.vis=PCT.Internal THEN PCM.SymWString(r, "") ELSE StringPool.GetString(fld.name, str); PCM.SymWString(r, str) END; fld := fld.nextVar END; mth := scope.firstMeth; first := TRUE; WHILE mth # NIL DO (*methods*) IF ~(PCT.copy IN mth.flags) THEN IF first THEN PCM.SymWNum(r, SFtproc); first := FALSE END; IF PCT.RealtimeProc IN mth.flags THEN PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.RealtimeProc) END; (* ug *) OutStruct(mth.type); IF mth.vis = PCT.Internal THEN PCM.SymWString(r, "") END; IF mth = scope.initproc THEN PCM.SymW(r, "&") END; StringPool.GetString(mth.name, str); PCM.SymWString(r, str); IF mth.self.ref THEN PCM.SymWNum(r, SFvar) END; OutStruct(mth.self.type); PCM.SymWString(r, PCT.SelfNameStr); OutParList(mth.scope.firstPar); (* Indlined methods: only meant for Indexer *) IF (PCT.Inline IN mth.flags) & (PCT.Indexer IN mth.flags) THEN PCM.SymWNum(r, InlineMarker); OutInline(mth.scope.code); END; END; mth := mth.nextMeth END; PCM.SymWNum(r, SFend) END OutRecord; PROCEDURE OutStruct(typ: PCT.Struct); VAR tAttr: Struct; mAttr: Module; name: StringBuf; ptyp: PCT.Delegate; i: LONGINT; mname, tname: ARRAY 64 OF CHAR; BEGIN IF typ.sym=NIL THEN NEW(tAttr, M); typ.sym:=tAttr (* ;PCM.LogWLn; PCM.LogWStr(" outstr "); IF typ.owner # NIL THEN PCM.LogWStr0(typ.owner.name) END *) ELSE tAttr := typ.sym(Struct) END; ASSERT((tAttr.mod = NIL) OR (tAttr.mod = tAttr.mod.scope.owner), 500); ASSERT(M = M.scope.owner, 501); IF (tAttr.mod # NIL) & (tAttr.mod # M) THEN (*imported, reexport*) mAttr := tAttr.mod.sym(Module); IF StrictChecks THEN i := 0; WHILE (M.imports[i].sym # mAttr) DO INC(i) END; (*check if in imports -> initialized*) StringPool.GetString(M.imports[i].name, mname); PCT.GetTypeName(typ, tname); i := 0; WHILE (mAttr.struct[i] # typ) DO INC(i) END; (*check typ in struct -> initialized*) END; StringPool.GetString(tAttr.mod.name, name); OutImpMod(name, mAttr); IF mAttr.expnumber > (SFmodOther - SFmod1) THEN PCM.SymWNum(r, SFmodOther); PCM.SymWNum(r, mAttr.expnumber-1) (* ;Out.Ln; Out.String("has more than "); Out.Int(SFmodOther - SFmod1, 0); Out.String("imports "); *) ELSE PCM.SymWNum(r, SFmod1+mAttr.expnumber-1) END; (* IF mAttr.expnumber > 31 THEN PCM.SymWNum(r, SFmodOther); PCM.SymWNum(r, mAttr.expnumber-1) ELSE PCM.SymWNum(r, SFmod1+mAttr.expnumber-1) END; *) IF tAttr.tag = UndefTag THEN StringPool.GetString(typ.owner.name, name); PCM.SymWString(r, name); tAttr.tag := mAttr.nofreimp; INC(mAttr.nofreimp) ELSE PCM.SymW(r, 0X); PCM.SymWNum(r, tAttr.tag) END ELSIF typ IS PCT.Basic THEN PCM.SymWNum(r, tAttr.tag) ELSIF (typ=PCT.String)OR(typ=PCT.NilType)OR(typ=PCT.NoType) THEN PCM.SymWNum(r, tAttr.tag) ELSIF tAttr.tag # UndefTag THEN PCM.SymWNum(r, -tAttr.tag) ELSE tAttr.tag := nofstruct; INC(nofstruct); IF (typ.owner # NIL) & (typ.owner.vis = PCT.Internal) THEN PCM.SymWNum(r, SFinvisible) ELSIF (typ IS PCT.Record) & (typ.owner = NIL) THEN PCM.SymWNum(r, SFinvisible) (*inconsistency in symfile*) END; name:=""; IF typ.owner#NIL THEN StringPool.GetString(typ.owner.name, name) END; IF typ IS PCT.Delegate THEN ptyp := typ(PCT.Delegate); IF ~(PCT.StaticMethodsOnly IN ptyp.flags) THEN PCM.SymWNum(r, SFsysflag); PCM.SymWNum(r, SFdelegate) END; PCM.SymWNum(r, SFtypProcTyp); OutStruct(ptyp.return); PCM.SymWString(r, name); PCM.SymWSet(r, ptyp.flags * {PCT.WinAPIParam, PCT.CParam, PCT.RealtimeProcType}); OutParList(ptyp.scope.firstPar) ELSIF typ IS PCT.Record THEN WITH typ: PCT.Record DO ASSERT((typ.btyp=PCT.NoType) OR (typ.btyp IS PCT.Record) OR (typ.btyp IS PCT.Pointer)); PCM.SymWNum(r, SFtypRecord); IF typ.intf # NIL THEN IF (LEN(typ.intf) > 0) & ~(PCM.ExportDefinitions IN PCM.codeOptions) THEN PCM.LogWLn; PCM.LogWStr("Warning: exports definitions, but flag not set") END; FOR i := 0 TO LEN(typ.intf)-1 DO OutStruct(typ.intf[i]) END END; OutStruct(typ.btyp); PCM.SymWString(r, name); PCM.SymWNum(r, 0); (* realtime flags ignored in PACO *) OutRecord(typ) END ELSIF typ IS PCT.Array THEN WITH typ: PCT.Array DO ASSERT(typ.mode IN {PCT.open, PCT.static}); IF typ.mode=PCT.open THEN PCM.SymWNum(r, SFtypOpenArr) ELSIF typ.mode=PCT.static THEN PCM.SymWNum(r, SFtypArray) ELSE HALT(99) END; OutStruct(typ.base); PCM.SymWString(r, name); PCM.SymWNum(r, 0); (* realtime flags ignored in PACO *) IF typ.mode=PCT.static THEN PCM.SymWNum(r, typ.len) END END (** fof >> *) ELSIF typ IS PCT.EnhArray THEN (*fof*) WITH typ: PCT.EnhArray DO ASSERT ( typ.mode IN {PCT.open, PCT.static} ); IF typ.mode = PCT.open THEN PCM.SymWNum( r, SFtypOpenEnhArr ) ELSIF typ.mode = PCT.static THEN PCM.SymWNum( r, SFtypStaticEnhArray ) ELSE HALT( 99 ) END; OutStruct( typ.base ); PCM.SymWString( r, name ); IF typ.mode = PCT.static THEN PCM.SymWNum( r, typ.len ) END END ELSIF typ IS PCT.Tensor THEN WITH typ: PCT.Tensor DO PCM.SymWNum( r, SFtypTensor ); OutStruct( typ.base ); PCM.SymWString( r, name ); END; (** << fof *) ELSIF typ IS PCT.Pointer THEN PCM.SymWNum(r, SFtypPointer); OutStruct(typ(PCT.Pointer).base); PCM.SymWString(r, name); PCM.SymWNum(r, 0); (* realtime flags ignored in PACO *) END END END OutStruct; PROCEDURE OutObj(o: PCT.Symbol); VAR str: StringBuf; BEGIN IF PCM.Untraced IN o.flags THEN PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.Untraced) END; IF o.vis = readonly THEN PCM.SymWNum(r, SFreadonly) END; OutStruct(o.type); StringPool.GetString(o.name, str); PCM.SymWString(r, str) END OutObj; PROCEDURE OutInline(i: PCM.Attribute); VAR p: PCLIR.AsmBlock; len, pos, cnt: LONGINT; BEGIN WITH i: PCLIR.AsmInline DO ASSERT(i.fixup = NIL); p := i.code; len := 0; WHILE p # NIL DO INC(len, p.len); p := p.next END; p := i.code; pos := 0; cnt := 0; IF len = 0 THEN PCM.SymW(r, 0X) ELSE WHILE pos < len DO IF cnt = 0 THEN cnt := 255; IF len < 255 THEN cnt := len END; PCM.SymW(r, CHR(cnt)) END; IF pos >= p.len THEN DEC(len, pos); p := p.next; pos := 0 END; PCM.SymW(r, p.code[pos]); INC(pos); DEC(cnt) END END; PCM.SymW(r, 0X) END; END OutInline; PROCEDURE OutModule(m: PCT.Module); VAR first: BOOLEAN; i, j: LONGINT; str: StringBuf; mm: Module; scope: PCT.ProcScope; v: PCT.Variable; p: PCT.Proc; t: PCT.Type; c: PCT.Value; p1, p2, pTmp, t1: PCT.Symbol; BEGIN ASSERT(m.scope.state >= PCT.procdeclared); nofstruct := 0; PCM.SymWNum(r, 0); (*end of imports*) IF Trace THEN PCM.LogWLn; PCM.LogWStr("OM.OutModule/const") END; IF m.imports # NIL THEN (* reset module and structures counters before exporting *) i := 0; WHILE (i < LEN(m.imports)) & (m.imports[i] # NIL) DO IF m.imports[i].sym # NIL THEN mm := m.imports[i].sym(Module); mm.expnumber := 0; mm.nofreimp := 0; FOR j := 0 TO mm.nofstr-1 DO mm.struct[j].sym(Struct).tag := UndefTag END ELSE PCM.LogWLn; PCM.LogWStr(" no sym: "); PCM.LogWStr0(m.imports[i].name) END; INC(i) END; END; IF PCM.error THEN RETURN END; (*symfile is changed*) IF {PCT.Overloading} * m.flags # {} THEN PCM.SymWNum(r, SFsysflag); PCM.SymWNum(r, SYSTEM.VAL(LONGINT, m.flags * {PCT.Overloading})) END; p1 := NIL; p2 := NIL; t1 := NIL; c := m.scope.firstValue; first := TRUE; WHILE c # NIL DO IF ~newsym THEN CompareSymbol(c, extend, new) ELSIF c.vis # PCT.Internal THEN FPrintObj(c, M) END; IF c.vis # PCT.Internal THEN IF first THEN PCM.SymWNum(r, SFconst); first := FALSE END; OutObj(c); OutConst(c.const) END; c := c.nextVal END; v := m.scope.firstVar; first := TRUE; WHILE v # NIL DO IF ~newsym THEN CompareSymbol(v, extend, new) ELSIF v.vis # PCT.Internal THEN FPrintObj(v, M) END; IF v.vis # PCT.Internal THEN IF first THEN PCM.SymWNum(r, SFvar); first := FALSE END; OutObj(v) END; v := v.nextVar END; (* ug: hidden variables are not written to the symbol file, scope.firstHiddenVar is not traversed. *) p := m.scope.firstProc; first := TRUE; WHILE p # NIL DO IF ~newsym THEN CompareSymbol(p, extend, new) ELSIF p.vis # PCT.Internal THEN FPrintObj(p, M) END; IF (p.vis # PCT.Internal) THEN IF ~(PCT.Inline IN p.flags) & ~(PCT.Operator IN p.flags) THEN IF first THEN PCM.SymWNum(r, SFxproc); first := FALSE END; IF PCT.RealtimeProc IN p.flags THEN PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.RealtimeProc) END; (* ug *) OutStruct(p.type); StringPool.GetString(p.name, str); PCM.SymWString(r, str); OutParList(p.scope.firstPar) ELSE p.dlink := p1; p1 := p END END; p := p.nextProc END; (* IF p1 # NIL THEN PCM.SymWNum(r, SFcproc); REPEAT OutStruct(p1.type); StringPool.GetString(p1.name, str); PCM.SymWString(r, str); scope := p1(PCT.Proc).scope; OutParList(scope.firstPar); OutInline(scope.code); p1 := p1.dlink UNTIL p1 = NIL END; *) first := TRUE; IF p1 # NIL THEN REPEAT pTmp := p1.dlink; IF (PCT.Operator IN p1.flags) THEN IF first THEN PCM.SymWNum(r, SFoperator); first := FALSE END; OutStruct(p1.type); StringPool.GetString(p1.name, str); PCM.SymWString(r, str); scope := p1(PCT.Proc).scope; OutParList(scope.firstPar); IF PCT.Inline IN p1.flags THEN PCM.SymWNum(r, InlineMarker); OutInline(scope.code) END; ELSE p1.dlink := p2; p2 := p1; END; p1 := pTmp; UNTIL p1 = NIL; END; IF p2 # NIL THEN PCM.SymWNum(r, SFcproc); REPEAT IF PCT.RealtimeProc IN p2.flags THEN PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.RealtimeProc) END; (* ug *) OutStruct(p2.type); StringPool.GetString(p2.name, str); PCM.SymWString(r, str); scope := p2(PCT.Proc).scope; OutParList(scope.firstPar); OutInline(scope.code); p2 := p2.dlink; UNTIL p2 = NIL; END; t := m.scope.firstType; first := TRUE; WHILE t # NIL DO IF ~newsym THEN CompareSymbol(t, extend, new) ELSIF t.vis # PCT.Internal THEN FPrintObj(t, M) END; IF t.vis # PCT.Internal THEN IF t # t.type.owner THEN (*alias*) IF first THEN PCM.SymWNum(r, SFalias); first := FALSE END; OutObj(t) ELSE t.dlink := t1; t1 := t END END; t := t.nextType END; first := TRUE; WHILE t1 # NIL DO IF (t1.type.sym=NIL) OR (t1.type.sym(Struct).tag=UndefTag) THEN (*not exported yet*) IF first THEN PCM.SymWNum(r, SFtyp); first := FALSE END; OutStruct(t1.type) END; t1 := t1.dlink END; (* write names of directly imported modules to symbol file *) IF m.directImps # NIL THEN FOR i := 0 TO LEN(m.directImps^) - 1 DO IF m.directImps[i] # NIL THEN AddImport(impList, m.directImps[i].name); END; END; END; (* add import list *) IF impList # NIL THEN i := 0; WHILE (i < LEN(impList^)-1) & (impList[i] # -1) DO StringPool.GetString(impList[i], str); PCM.SymWMod(r, str); INC(i); END END; IF Trace THEN PCM.LogWLn; PCM.LogWStr("OM.OutModule/end") END; PCM.SymWNum(r, SFend); END OutModule; BEGIN ASSERT(M#NIL); COPY("", msg); IF PCM.error THEN RETURN END; StringPool.GetString(M.name, name); newsym := FALSE; changed := FALSE; oldM := NIL; IF ~skipImport THEN Import(M, oldM, M.name); (* import self, to check for changes *) END; IF oldM # NIL THEN changed := M.sym(Module).changed ELSE IF M.sym = NIL THEN NEW(MAttr); M.sym := MAttr; MAttr := NIL END; newsym := TRUE END; (*export*) ASSERT(M.flags - ImportedModuleFlag = {}); (*export overrides only if allowed*) OutModule(M); IF PCM.error THEN RETURN END; PCM.CloseSym(r); (*commit file*) IF changed OR extended THEN IF changed THEN IF newsym OR new THEN COPY(" new symbol file", msg) ELSE PCM.Error(155, PCM.InvalidPosition, "") END ELSIF extended THEN IF extend OR new THEN COPY(" extended symbol file", msg) ELSE PCM.Error(155, PCM.InvalidPosition, "") END END END END Export; (* ========== Symbol File Loader ============== *) (** Double structure size, copy elements into new structure *) PROCEDURE ExtendStructArray*(VAR a: StructArray); VAR b: StructArray; i: LONGINT; BEGIN IF a=NIL THEN NEW(a, 16) ELSE NEW(b, 2*LEN(a)); FOR i := 0 TO LEN(a)-1 DO b[i] := a[i] END; a := b END END ExtendStructArray; PROCEDURE AddImport(VAR list: ImportList; idx: StringPool.Index); VAR i: LONGINT; newList: ImportList; BEGIN IF list = NIL THEN NEW(list, 16); FOR i := 0 TO LEN(list^)-1 DO list[i] := -1; END; END; i := 0; WHILE (i < LEN(list^)) & (list[i] # -1) & (list[i] # idx) DO INC(i) END; IF i >= LEN(list^) THEN (* double list and append module index *) NEW(newList, 2*LEN(list^)); FOR i := 0 TO LEN(list^)-1 DO newList[i] := list[i]; END; FOR i := LEN(list^) TO LEN(newList^)-1 DO newList[i] := -1 END; newList[LEN(list^)] := idx; list := newList; ELSIF list[i] = -1 THEN (* append module index to list *) list[i] := idx; ELSE (* do nothing, module already in list *) END; END AddImport; (* ReadString - Read a 0X compressed string *) PROCEDURE ReadString(VAR R: PCM.SymReader; VAR string: ARRAY OF CHAR); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; LOOP R.Char(ch); IF ch = 0X THEN string[i] := 0X; RETURN ELSIF ch < 7FX THEN string[i]:=ch; INC(i) ELSIF ch > 7FX THEN string[i] := CHR(ORD(ch)-80H); string[i+1] := 0X; RETURN ELSE (* ch = 7FX *) EXIT END END; LOOP R.Char(ch); IF ch = 0X THEN string[i]:=0X; RETURN ELSE string[i]:=ch; INC(i) END END; END ReadString; PROCEDURE ReadStringNoZeroCompress(VAR R: PCM.SymReader; VAR string: ARRAY OF CHAR); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; REPEAT R.Char(ch); string[i] := ch; INC(i); UNTIL ch = 0X; END ReadStringNoZeroCompress; PROCEDURE ReadStrIndex(VAR r: PCM.SymReader; readString: ReadStringProc; VAR s: PCS.Name); VAR name: ARRAY 256 OF CHAR; BEGIN (* ReadString(r, name); *) readString(r, name); IF name = "" THEN s := empty ELSE StringPool.GetIndex(name, s) END END ReadStrIndex; PROCEDURE ImportComplete(m: PCT.Module); VAR attr: Module; i: LONGINT; PROCEDURE RecordComplete(r: PCT.Record); BEGIN IF r.brec # NIL THEN RecordComplete(r.brec) END; PCT.ChangeState(r.scope, PCT.complete, -1) END RecordComplete; BEGIN PCT.ChangeState(m.scope, PCT.complete, -1); attr := m.sym(Module); FOR i := 0 TO attr.nofstr-1 DO IF attr.struct[i] IS PCT.Record THEN RecordComplete(attr.struct[i](PCT.Record)) END END END ImportComplete; (** Import - Symbol Table Loader Plugin *) PROCEDURE Import*(self: PCT.Module; VAR M: PCT.Module; modname: StringPool.Index); VAR res: WORD; tag, i: LONGINT; name: PCS.Name; str: PCT.Struct; vis: SET; R: PCM.SymReader; proc: PCT.Proc; scope: PCT.ModScope; pscope: PCT.ProcScope; selfimport, zeroCompress: BOOLEAN; ver: CHAR; MAttr: Module; flag, flags: SET; type: PCT.Type; string: ARRAY 256 OF CHAR; readString: ReadStringProc; importError: BOOLEAN; PROCEDURE Assert(cond: BOOLEAN); BEGIN IF ~cond THEN importError := TRUE END; END Assert; PROCEDURE EqualNames(s1, s2: PCT.Struct): BOOLEAN; VAR res: BOOLEAN; BEGIN ASSERT(s1 # NIL); ASSERT(s2 # NIL); IF (s1 IS PCT.Array) & (s2 IS PCT.Array) THEN res := EqualNames(s1(PCT.Array).base, s2(PCT.Array).base); (** fof >> *) ELSIF (s1 IS PCT.EnhArray) & (s2 IS PCT.EnhArray) THEN (*fof*) res := EqualNames( s1( PCT.EnhArray ).base, s2( PCT.EnhArray ).base ); ELSIF (s1 IS PCT.Tensor) & (s2 IS PCT.Tensor) THEN (*fof*) res := EqualNames( s1( PCT.Tensor ).base, s2( PCT.Tensor ).base ); (** << fof *) ELSIF ~(s1 IS PCT.Array) & ~(s2 IS PCT.Array) & ~(s1 IS PCT.EnhArray) & ~(s2 IS PCT.EnhArray) &~(s1 IS PCT.Tensor) & ~(s2 IS PCT.Tensor) (* fof*) THEN IF (s1.owner # NIL) & (s2.owner # NIL) THEN res := (s1.owner.name = s2.owner.name); ELSE res := FALSE; END; ELSE res := FALSE; END; RETURN res; END EqualNames; PROCEDURE Insert(scope: PCT.Scope; obj: PCT.Symbol); VAR old: PCT.Symbol; OAttr: Symbol; p: PCT.Symbol; paramProc, paramObj: PCT.Parameter; j: LONGINT; BEGIN ASSERT(selfimport); old:=PCT.Find(scope, scope, obj.name, PCT.procdeclared, FALSE); (* not the correct operator is found: type name is used to search, but not name of module, where type is definded (not in symbol file) changes in operator signatures are not recognized, only adding and removing of operators *) IF (old # NIL) & (PCT.Operator IN obj.flags) THEN p := old; old := NIL; WHILE (p # NIL) & (p.name = obj.name) DO paramProc := p(PCT.Proc).scope.firstPar; paramObj := obj(PCT.Proc).scope.firstPar; (* check for equal parameters (only the type names are compared!) *) j := 0; WHILE (j < p(PCT.Proc).scope.parCount) & (p(PCT.Proc).scope.parCount = obj(PCT.Proc).scope.parCount) & (p(PCT.Proc).vis = obj(PCT.Proc).vis) & (paramProc.ref = paramObj.ref) & EqualNames(paramProc.type, paramObj.type) DO paramProc := paramProc.nextPar; paramObj := paramObj.nextPar; INC(j) END; IF (j = p(PCT.Proc).scope.parCount) & (p(PCT.Proc).sym = NIL) THEN old := p; p := NIL ELSE p := p.sorted END END END; IF old=NIL THEN PCM.ErrorN(401, PCM.InvalidPosition, obj.name); MAttr.changed:=TRUE ELSIF old.vis#obj.vis THEN PCM.ErrorN(401, PCM.InvalidPosition, obj.name); MAttr.changed:=TRUE ELSE ASSERT(old.sym=NIL); NEW(OAttr); old.sym:=OAttr; OAttr.sibling:=obj END END Insert; PROCEDURE GetImports; VAR name: StringPool.Index; M: PCT.Module; BEGIN ReadStrIndex(R, readString, name); WHILE name # empty DO IF (MAttr.import = NIL) OR (MAttr.nofimp = LEN(MAttr.import)) THEN PCT.ExtendModArray(MAttr.import) END; PCT.Import(self, M, name); IF M = NIL THEN PCM.ErrorN(0, 0, name) ELSE MAttr.import[MAttr.nofimp]:=M; IF M.scope.state = 0 THEN (*fresh import*) ImportComplete(M) END; INC(MAttr.nofimp); ReadStrIndex(R, readString, name) END END END GetImports; PROCEDURE InConst(): PCT.Const; VAR i: LONGINT; r: REAL; lr: LONGREAL; str: PCS.String; set: SET; c: PCT.Const; BEGIN CASE tag OF | SFtypBool: R.RawNum(i); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / Bool / "); PCM.LogWNum(i) END; IF i = 0 THEN c := PCT.False ELSE c := PCT.True END | SFtypChar8: R.RawNum(i); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / Char / "); PCM.LogWNum(i) END; c := PCT.NewIntConst(i, PCT.Char8) | SFtypInt8: R.RawNum(i); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / SInt / "); PCM.LogWNum(i) END; c := PCT.NewIntConst(i, PCT.Int8) | SFtypInt16: R.RawNum(i); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / Int / "); PCM.LogWNum(i) END; c := PCT.NewIntConst(i, PCT.Int16) | SFtypInt32: R.RawNum(i); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / LInt / "); PCM.LogWNum(i) END; c := PCT.NewIntConst(i, PCT.Int32) | SFtypInt64: R.RawLReal(lr); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / HInt / ") END; c := PCT.NewInt64Const(SYSTEM.VAL(HUGEINT, lr)) | SFtypSet: R.RawNum(SYSTEM.VAL(LONGINT, set)); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / Set / "); PCM.LogWHex(SYSTEM.VAL(LONGINT, set)) END; c := PCT.NewSetConst(set) | SFtypFloat32: R.RawReal(r); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / Real / ") END; RETURN PCT.NewFloatConst(r, PCT.Float32) | SFtypFloat64: R.RawLReal(lr); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / LongReal / ") END; c := PCT.NewFloatConst(lr, PCT.Float64) | SFtypString: readString(R, str); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InConst / String / "); PCM.LogWStr(str) END; c := PCT.NewStringConst(str) | SFtypNilTyp: END; RETURN c END InConst; PROCEDURE InParList(upper: PCT.Scope): PCT.ProcScope; VAR s: PCT.ProcScope; svar, var: BOOLEAN; name: PCS.Name; styp, str: PCT.Struct; f: LONGINT; flags: SET; (* ejz *) BEGIN styp := NIL; NEW(s); PCT.InitScope(s, upper, {}, TRUE); PCT.SetOwner(s); R.RawNum(tag); WHILE tag#SFend DO flags := {}; (* ejz *) IF tag = SFobjflag THEN R.RawNum(f); R.RawNum(tag); IF f = PCM.CParam THEN (* fof for Linux *) INCL(flags, PCT.CParam) ELSIF f = PCM.WinAPIParam THEN INCL(flags,PCT.WinAPIParam) ELSE HALT(100) END; END; IF tag=SFvar THEN var:=TRUE; R.RawNum(tag); ELSE var:=FALSE END; (** fof >> *) IF tag = SFreadonly THEN (* var const *) INCL(flags,PCM.ReadOnly); R.RawNum(tag); END; (** << fof *) InStruct(str); ReadStrIndex(R, readString, name); IF (name = PCT.SelfName) OR (name = altSelf) THEN (*move SELF to the end of the list / method only*) styp := str; svar := var ELSE s.CreatePar(PCT.Public, var, name, flags, str, 0 (* fof *), res); (* ASSERT(res = PCT.Ok) *) (* ejz *) Assert(res = PCT.Ok); END; R.RawNum(tag) END; IF styp # NIL THEN s.CreatePar(PCT.Public, svar, PCT.SelfName, {}, styp, 0 (* fof *), res); (* ASSERT(res = PCT.Ok) *) Assert(res = PCT.Ok); END; RETURN s END InParList; PROCEDURE InRecord(rec: PCT.Record; btyp: PCT.Struct; intf: PCT.Interfaces); VAR mode, vis: SET; typ: PCT.Struct; name: PCS.Name; mscope: PCT.ProcScope; s: PCT.RecScope; flags: SET; ch: CHAR; BEGIN NEW(s); PCT.SetOwner(s); PCT.InitScope(s, scope, {}, TRUE); R.RawNum(SYSTEM.VAL(LONGINT, mode)); PCT.InitRecord(rec, btyp, intf, s, PCT.interface IN mode, TRUE, TRUE, res); (* ASSERT(res = PCT.Ok); *) Assert(res = PCT.Ok); rec.mode := mode; R.Char(ch); rec.prio := ORD(ch); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("Rec / Mode / "); PCM.LogWHex(SYSTEM.VAL(LONGINT, rec.mode)); PCM.LogWLn; PCM.LogWStr("Rec / Prio / "); PCM.LogWNum(rec.prio) END; R.RawNum(tag); WHILE (tag < SFtproc) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO (*read fields*) InObj(name, vis, flags, typ); IF name = empty THEN vis := PCT.Internal; name := PCT.Anonymous END; s.CreateVar(name, vis, flags, typ, 0, (* fof *)NIL, res); (* ASSERT(res = PCT.Ok); *) Assert(res = PCT.Ok); R.RawNum(tag); END; IF tag=SFtproc THEN R.RawNum(tag); WHILE tag#SFend DO InObj(name, vis, flags, typ); IF name = empty THEN vis := PCT.Internal; ReadStrIndex(R, readString, name) END; mscope := InParList(s); s.CreateProc(name, vis, flags, mscope, typ, 0, (* fof *) res); (* ASSERT(res = PCT.Ok); *) Assert(res = PCT.Ok); (* This identifies a inlined Indexer *) R.RawNum(tag); IF tag = InlineMarker THEN INCL(flag, PCT.Inline); INCL(flag, PCT.Indexer); INCL(flag, PCT.Operator); mscope.code := InCProc(); R.RawNum(tag) END; PCT.ChangeState(mscope, PCT.structdeclared, PCM.InvalidPosition); END END; IF ~selfimport THEN PCT.AddRecord(M.scope, rec) END; END InRecord; PROCEDURE InStruct(VAR typ: PCT.Struct); VAR i, len, strref, typtag, typadr: LONGINT; vis: SET; name: PCS.Name; btyp: PCT.Struct; arr: PCT.Array; type: PCT.Type; mod: PCT.Module; typname: PCS.Name; proc: PCT.Delegate; r, rec: PCT.Record; ptr: PCT.Pointer; modAttr: Module; tAttr: Struct; sysflag: LONGINT; sf: SET; intf: ARRAY 32 OF PCT.Interface; c: CHAR; earr: PCT.EnhArray; tensor: PCT.Tensor; readonly: LONGINT; (*fof*) flags: LONGINT; (*!!! when loading the user structures, no fix is used, but dummy elements !!!*) BEGIN IF tag <= 0 THEN (*oldstruct*) ASSERT(MAttr.struct[-tag]#NIL); (*IF MAttr.struct[-tag] = NIL THEN PCDebug.ToDo(PCM.NotImplemented); RETURN unknownType END;*) typ := MAttr.struct[-tag]; IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InStruct / OldStr "); PCM.LogWNum(-tag) END ELSIF tag <= SFlastStruct THEN (*BasicStructure*) typ := predefStruct[tag] ;IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InStruct / Basic "); IF typ.owner # NIL THEN PCM.LogWStr0(typ.owner.name) ELSE PCM.LogWNum(tag) END END ELSIF tag <= SFmodOther THEN (*modno ( structname | 0X oldimpstruct)*) IF tag = SFmodOther THEN R.RawNum(tag) ELSE tag := tag-SFmod1 END; (*tag = [0 .. +oo[ *) mod := MAttr.import[tag]; ReadStrIndex(R, readString, typname); modAttr := mod.sym(Module); IF typname # empty THEN (*first import of struct*) i := 0; WHILE (i= LEN(MAttr.struct) THEN ExtendStructArray(MAttr.struct) END; vis := PCT.Public; sysflag := 0; IF tag = SFinvisible THEN vis := PCT.Internal; R.RawNum(tag) END; IF tag = SFsysflag THEN R.RawNum(sysflag); R.RawNum(tag) END; typtag := tag; R.RawNum(tag); (*first create the structure, to be used in recursive structs*) CASE typtag OF | SFtypOpenArr, SFtypArray: NEW(arr); typ := arr (** fof >> *) | SFtypOpenEnhArr, SFtypStaticEnhArray: NEW( earr ); typ := earr | SFtypTensor: NEW(tensor); typ := tensor; (** << fof *) | SFtypPointer: NEW(ptr); typ := ptr | SFtypRecord: NEW(rec); typ := rec; IF (strref > 0) & (MAttr.struct[strref-1] IS PCT.Pointer) THEN ptr := MAttr.struct[strref-1](PCT.Pointer); IF ptr.base = NIL THEN INC(NpatchPointer0); PCT.InitPointer(ptr, rec, res); (* ASSERT(res = PCT.Ok) *) Assert(res = PCT.Ok); END; END; | SFtypProcTyp: NEW(proc); typ := proc END; (* ASSERT((sysflag = 0) OR (sysflag = SFdelegate)); *) MAttr.struct[strref] := typ; NEW(tAttr, M); typ.sym:=tAttr; tAttr.strref := strref; (* IF ~selfimport THEN tAttr.mod:=M END; (*only for imported structures: where from*) *) InStruct(btyp); (* now load the struct, late fixes*) CASE typtag OF | SFtypOpenArr: PCT.InitOpenArray(arr, btyp, res); (* ASSERT(res = PCT.Ok); *) Assert(res = PCT.Ok); ReadStrIndex(R, readString, name); R.RawNum(flags); (* realtime flags , ignored in PACO *) IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InStruct / User / OpenArr "); IF name # empty THEN PCM.LogWStr0(name) END END (** fof >> *) | SFtypOpenEnhArr: PCT.InitOpenEnhArray( earr, btyp, {PCT.open}, res ); (* ASSERT(res = PCT.Ok); *) Assert( res = PCT.Ok ); ReadStrIndex( R, readString, name ); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr( "InStruct / User / OpenEnhArr " ); IF name # empty THEN PCM.LogWStr0( name ) END END | SFtypTensor: PCT.InitTensor(tensor,btyp,res); Assert( res = PCT.Ok ); ReadStrIndex( R, readString, name ); | SFtypStaticEnhArray: (*fof*) ReadStrIndex( R, readString, name ); R.RawNum( len ); PCT.InitStaticEnhArray( earr, len, btyp, {PCT.static}, res ); (* ASSERT(res = PCT.Ok); *) Assert( res = PCT.Ok ); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr( "InStruct / User / Array " ); PCM.LogWNum( len ); IF name # empty THEN PCM.LogWStr0( name ) END END (** << fof *) | SFtypArray: ReadStrIndex(R, readString, name); R.RawNum(flags); (* realtime flags , ignored in PACO *) R.RawNum(len); PCT.InitStaticArray(arr, len, btyp, res); (* ASSERT(res = PCT.Ok); *) Assert(res = PCT.Ok); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InStruct / User / Array "); PCM.LogWNum(len); IF name # empty THEN PCM.LogWStr0(name) END END | SFtypPointer: IF ptr.base # NIL THEN ASSERT(ptr.base = btyp) ELSE PCT.InitPointer(ptr, btyp, res); (* ASSERT(res = PCT.Ok) *) Assert(res = PCT.Ok); END; ReadStrIndex(R, readString, name); R.RawNum(flags); (* realtime flags , ignored in PACO *) IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InStruct / User / Pointer "); IF name # empty THEN PCM.LogWStr0(name) END END | SFtypRecord: LOOP IF btyp IS PCT.Pointer THEN WITH btyp: PCT.Pointer DO r := btyp.baseR; IF PCT.interface IN r.mode THEN INC(Ninterfaces); intf[i] := btyp; INC(i) ELSE EXIT END END ELSE EXIT END; R.RawNum(tag); InStruct(btyp) END; ReadStrIndex(R, readString, name); R.RawNum(flags); (* realtime flags , ignored in PACO *) InRecord(rec, btyp, intf); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InStruct / User / Record "); IF name # empty THEN PCM.LogWStr0(name) END END | SFtypProcTyp: ReadStrIndex(R, readString, name); R.RawNum(SYSTEM.VAL(LONGINT, sf)); IF sysflag # SFdelegate THEN INCL (sf, PCT.StaticMethodsOnly) END; PCT.InitDelegate(proc, btyp, InParList(scope), sf, res); (* ASSERT(res = PCT.Ok); *) Assert(res = PCT.Ok); PCT.ChangeState(proc.scope, PCT.structdeclared, -1); IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InStruct / User / Proc "); IF name # empty THEN PCM.LogWStr0(name) END END END; IF name # empty THEN IF ~selfimport THEN scope.CreateType(name, vis, typ, 0(*fof*), res); (* ASSERT(res = PCT.Ok) *) Assert(res = PCT.Ok); ELSE NEW(type); PCT.InitType(type, name, vis, typ); Insert(scope, type) END END END END InStruct; PROCEDURE InCProc(): PCLIR.AsmInline; VAR inline: PCLIR.AsmInline; p: PCLIR.AsmBlock; ch: CHAR; pos, len: LONGINT; BEGIN NEW(inline); R.Char(ch); REPEAT IF p = NIL THEN NEW(p); inline.code := p ELSE NEW(p.next); p := p.next END; len := ORD(ch); p.len := len; pos := 0; WHILE pos < len DO R.Char(p.code[pos]); INC(pos) END; R.Char(ch) UNTIL ch = 0X; RETURN inline END InCProc; PROCEDURE InObj(VAR idx: PCS.Name; VAR vis: SET; VAR flag: SET; VAR typ: PCT.Struct); VAR f: LONGINT; name: ARRAY 32 OF CHAR; BEGIN flag := {}; vis:=PCT.Public; IF tag=SFobjflag THEN R.RawNum(f); R.RawNum(tag); IF f = PCM.Untraced THEN flag := {f} ELSIF f = PCM.RealtimeProc THEN flag := {PCT.RealtimeProc} (* ug *) ELSE PCM.LogWLn; PCM.LogWStr("PCOM.InObj: unknown objflag"); END END; IF tag=SFreadonly THEN R.RawNum(tag); vis := readonly END; InStruct(typ); readString(R, name); IF name = "" THEN idx := empty ELSIF name[0] = "&" THEN flag := {PCT.Constructor}; i := 0; REPEAT name[i] := name[i+1]; INC(i) UNTIL name[i] = 0X; StringPool.GetIndex(name, idx) ELSE StringPool.GetIndex(name, idx) END; IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("InObj: "); PCM.LogWStr(name) END END InObj; BEGIN IF Trace THEN PCM.LogWLn; PCM.LogWStr("OM.Import") END; i := 0; M:=NIL; selfimport:=FALSE; StringPool.GetString(modname, string); IF ~PCM.OpenSymFile(string, R, ver, zeroCompress) THEN RETURN END; IF zeroCompress THEN readString := ReadString; ELSE readString := ReadStringNoZeroCompress; END; IF (self # NIL) & (self.sym = NIL) THEN (*first import, create symfile related structures*) NEW(MAttr); self.sym:=MAttr; END; IF (self # NIL) & (self.name = modname) THEN selfimport:=TRUE; M := self; MAttr:=M.sym(Module); MAttr.nofreimp:=0; scope:=M.scope; ELSE NEW(scope); PCT.SetOwner(scope); M := PCT.NewModule(modname, TRUE, {}, scope); NEW(MAttr); M.sym:=MAttr END; IF ~selfimport & (self # NIL) THEN self.AddImport(M) END; IF (ver = PCM.FileVersion) OR (ver=PCM.FileVersionOC) THEN R.RawSet(flags); ELSE PCM.Error(151, PCM.InvalidPosition, ""); M := NIL; RETURN END; GetImports; IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("Import "); PCM.LogWStr(string) END; FOR i := 0 TO MAttr.nofimp-1 DO ASSERT(MAttr.import # NIL, 500); ASSERT(MAttr.import[i] # NIL, 501); ASSERT(MAttr.import[i].sym # NIL, 502); MAttr.import[i].sym(Module).nofreimp := 0 END; (*reset reimports*) R.RawNum(tag); flag := {}; IF tag = SFsysflag THEN R.RawNum(SYSTEM.VAL(LONGINT, flag)); R.RawNum(tag); END; IF ~selfimport THEN PCT.InitScope(scope, NIL, flag, TRUE) END; IF tag=SFconst THEN R.RawNum(tag); WHILE (tag < SFvar) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO InObj(name, vis, flag, str); IF ~selfimport THEN scope.CreateValue(name, vis, InConst(), 0, (* fof *) res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok) *) ELSE Insert(scope, PCT.NewValue(name, vis, InConst())) END; R.RawNum(tag) END END; IF Trace THEN PCM.LogWLn; PCM.LogWStr("OM.Import var....") END; IF tag=SFvar THEN R.RawNum(tag); WHILE (tag < SFxproc) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO InObj(name, vis, flag, str); IF ~selfimport THEN scope.CreateVar(name, vis, flag, str, 0, (* fof *) NIL, res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok)) *) ELSE Insert(scope, PCT.NewGlobalVar(vis, name, flag, str, res)); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok) *) END; R.RawNum(tag) END END; IF Trace THEN PCM.LogWLn; PCM.LogWStr("OM.Import xproc....") END; IF tag=SFxproc THEN R.RawNum(tag); WHILE (tag < (*SFcproc*) SFoperator) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO InObj(name, vis, flag, str); pscope := InParList(scope); IF ~selfimport THEN scope.CreateProc(name, vis, flag, pscope, str, 0, (* fof *) res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok) *) ELSE proc := PCT.NewProc(vis, name, flag, pscope, str, res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok); *) Insert(scope, proc); END; PCT.ChangeState(pscope, PCT.structdeclared, -1); R.RawNum(tag) END END; IF tag=SFoperator THEN R.RawNum(tag); WHILE (tag < SFcproc) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO InObj(name, vis, flag, str); pscope := InParList(scope); INCL(flag, PCT.Operator); R.RawNum(tag); IF tag = InlineMarker THEN INCL(flag, PCT.Inline); pscope.code := InCProc(); R.RawNum(tag); END; IF ~selfimport THEN scope.CreateProc(name, vis, flag, pscope, str, 0, (* fof *)res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok); *) ELSE proc := PCT.NewProc(vis, name, flag, pscope, str, res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok); *) Insert(scope, proc); END; PCT.ChangeState(pscope, PCT.structdeclared, -1); (* R.RawNum(tag) *) END END; IF tag = SFcproc THEN R.RawNum(tag); WHILE (tag < SFalias) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO InObj(name, vis, flag, str); pscope := InParList(scope); INCL(flag, PCT.Inline); IF ~selfimport THEN scope.CreateProc(name, vis, flag, pscope, str, 0, (* fof *) res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok) *) ELSE Insert(scope, PCT.NewProc(vis, name, flag, pscope, str, res)); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok) *) END; pscope.code := InCProc(); PCT.ChangeState(pscope, PCT.structdeclared, -1); R.RawNum(tag) END END; IF tag=SFalias THEN R.RawNum(tag); WHILE (tag < SFtyp) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO InStruct(str); ReadStrIndex(R, readString, name); IF ~selfimport THEN scope.CreateType(name, PCT.Public, str, 0, (* fof *)res); Assert(res = PCT.Ok); (* ASSERT(res = PCT.Ok) *) ELSE NEW(type); PCT.InitType(type, name, PCT.Public, str); Insert(scope, type) END; R.RawNum(tag) END END; IF tag=SFtyp THEN R.RawNum(tag); WHILE (tag < SFend) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) (* fof *) DO InStruct(str); R.RawNum(tag) END END; IF importError THEN M := NIL ELSE ImportComplete(M) END END Import; (* ========== Initialisation ============ *) PROCEDURE Cleanup; BEGIN PCT.RemoveImporter(Import) END Cleanup; PROCEDURE InitBasic(t: PCT.Struct; tag, fp: LONGINT); VAR sAttr: Struct; BEGIN NEW(sAttr, NIL); sAttr.tag := tag; t.sym := sAttr; sAttr.fp:=fp; sAttr.pbfp := fp; IF t.size # NIL THEN sAttr.pvfp := t.size(PCBT.Size).size ELSE sAttr.pvfp := tag END; predefStruct[tag] := t; END InitBasic; PROCEDURE Init; BEGIN (*Built-In types*) InitBasic(PCT.NoType, SFtypNoTyp, FPFnotyp); PCT.NoType.sym(Struct).pvfp := SFtypNoTyp; InitBasic(PCT.Bool, SFtypBool, FPFbool); InitBasic(PCT.Char8, SFtypChar8, FPFchar8); InitBasic(PCT.Char16, SFtypChar16, FPFchar16typ); InitBasic(PCT.Char32, SFtypChar32, FPFchar32typ); InitBasic(PCT.Int8, SFtypInt8, FPFint8typ); InitBasic(PCT.Int16, SFtypInt16, FPFint16typ); InitBasic(PCT.Int32, SFtypInt32, FPFint32typ); InitBasic(PCT.Int64, SFtypInt64, FPFint64typ); InitBasic(PCT.Float32, SFtypFloat32, FPFfloat32typ); InitBasic(PCT.Float64, SFtypFloat64, FPFfloat64typ); InitBasic(PCT.Set, SFtypSet, FPFsettyp); InitBasic(PCT.String, SFtypString, FPFstringtyp); PCT.String.sym(Struct).pvfp := SFtypString; (*InitBasic(PCT.PtrTyp, 0);*) (*not initialized: NilTyp, UndefTyp (have special pvfp)*) (*Built-In types, system*) InitBasic(PCT.Ptr, SFtypSptr, FPFpointer); InitBasic(PCT.Byte, SFtypByte, FPFbyte); FParray[PCT.open]:=FPFopenarr; FParray[PCT.static]:=FPFstaticarr; PCT.AddImporter(Import); END Init; PROCEDURE CreateString(VAR idx: StringPool.Index; str: ARRAY OF CHAR); (*to insert string constants*) BEGIN StringPool.GetIndex(str, idx) END CreateString; BEGIN Modules.InstallTermHandler(Cleanup); Init; IF Trace THEN PCM.LogWLn; PCM.LogWStr("PCOM.Trace on") END; IF TraceImport THEN PCM.LogWLn; PCM.LogWStr("PCOM.TraceImport on") END; CreateString(altSelf, "@SELF") END PCOM. (* 15.11.06 ug Procedure Export with additional parameter skipImport that suppresses the import of the old symbol file 11.06.02 prk emit modified symbol file message to main log (not kernel log) 22.02.02 prk unicode support 08.02.02 prk use Aos instead of Oberon modules 05.02.02 prk PCT.Find cleanup 22.01.02 prk ToDo list moved to PCDebug 18.01.02 prk AosFS used instead of Files 22.11.01 prk improved flag handling 19.11.01 prk definitions 17.11.01 prk more flexible type handling of integer constants 16.11.01 prk constant folding of reals done with maximal precision 14.11.01 prk include sysflag in fingerprint 29.08.01 prk PCT functions: return "res" instead of taking "pos" 27.08.01 prk scope.unsorted list removed; use var, proc, const and type lists instead 17.08.01 prk overloading 09.08.01 prk Symbol Table Loader Plugin 11.07.01 prk support for fields and methods with same name in scope 06.07.01 prk mark object explicitly 05.07.01 prk import interface redesigned 04.07.01 prk scope flags added, remove imported 02.07.01 prk access flags, new design 27.06.01 prk StringPool cleaned up 27.06.01 prk ProcScope.CreatePar added 15.06.01 prk support for duplicate scope entries 13.06.01 prk export of empty inlines fixed 06.06.01 prk use string pool for object names 08.05.01 prk PCT interface cleanup. Use InitX instead of New*, allows type extension 26.04.01 prk separation of RECORD and OBJECT in the parser 02.04.01 prk ExtendModArray, ExtendStructArray exported 30.03.01 prk object file version changed to 01X 25.03.01 prk limited HUGEINT implementation (as abstract type) 22.02.01 prk self reference for methods: use pointer-based self if possible (i.e. if object is dynamic and method definitions in super-class is not record-based). *)