MODULE PCOM;
IMPORT
SYSTEM, Modules, StringPool, PCM, PCS, PCT, PCBT, PCLIR, Diagnostics;
CONST
Trace = FALSE;
TraceCalls = FALSE;
TraceImport = FALSE;
StrictChecks = TRUE;
TraceFPName = "D1";
TraceFP = TRUE;
ImportedModuleFlag = {};
UndefTag = -1;
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;
SFconst=37H; SFvar=38H;
SFlproc=39H; SFxproc=3AH; SFoperator=3BH; SFtproc=3CH; SFcproc = SFtproc;
SFalias=3DH; SFtyp=3EH;
SFend= 3FH;
SFtypOpenEnhArr = 40H; SFtypDynEnhArr = 41H; SFtypTensor=42H; SFtypStaticEnhArray = 43H;
InlineMarker = 0ABH;
SFdelegate = 5;
FPMvar=1; FPMpar=1; FPMvarpar=2; FPMconst=3; FPMfield=4; FPMtype=5; FPMxproc=7; FPMcproc=9;
FPMmethod=13;
FPMinit=14;
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;
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)
VAR
fp*: LONGINT;
sibling: PCT.Symbol;
END Symbol;
Struct* = OBJECT (PCM.Attribute)
VAR
fp*, pbfp*, pvfp*: LONGINT;
fpdone* {UNTRACED} : PCT.Module;
strref*: LONGINT;
tag: LONGINT;
uref*: LONGINT;
mod*: PCT.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
END Init;
END Struct;
StructArray = POINTER TO ARRAY OF PCT.Struct;
Module* = OBJECT (PCM.Attribute)
VAR
nofimp: LONGINT; import: PCT.ModuleArray;
nofstr: LONGINT; struct: StructArray;
nofreimp: LONGINT; reimp: StructArray;
expnumber: LONGINT;
changed: BOOLEAN;
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;
FParray: ARRAY 6 OF SHORTINT;
altSelf: PCS.Name;
Ninterfaces, NpatchPointer0: LONGINT;
PROCEDURE FPrint(VAR fp: LONGINT; val: LONGINT);
BEGIN fp:=SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, SYSTEM.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(SYSTEM.ADR(lr)+4, l); SYSTEM.GET(SYSTEM.ADR(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))
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);
oAttr.fp:=fp;
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)
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;
END FPrintRecord;
PROCEDURE FPrintTyp0(typ: PCT.Struct; current: PCT.Module);
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;
BEGIN
IF (tAttr.mod # NIL) & (tAttr.mod.scope # current.scope) THEN
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
ELSE tAttr:=typ.sym(Struct) END;
IF tAttr.fpdone # current THEN tAttr.fpdone := NIL END;
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
ELSIF typ IS PCT.EnhArray THEN
WITH typ: PCT.EnhArray DO
mode := typ.mode;
FPrint( fp, FPFcomp ); FPrint( fp, FParray[mode] );
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;
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);
VAR tAttr: Struct; name: ARRAY 32 OF CHAR;
BEGIN
current := current.scope.owner;
IF typ.sym=NIL THEN NEW(tAttr, current); typ.sym:=tAttr
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)
ELSIF typ IS PCT.EnhArray THEN
FPrintTyp( typ( PCT.EnhArray ).base, current )
ELSIF typ IS PCT.Tensor THEN
FPrintTyp( typ( PCT.Tensor ).base, current )
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);
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;
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;
END FPrintConstEnhArray;
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;
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
FPrint(fp, obj.type.sym(Struct).fp);
END;
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^)
ELSIF con.type IS PCT.EnhArray THEN
FPrintConstEnhArray( fp, obj( PCT.Value ) );
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;
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
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)
ELSIF (new IS PCT.EnhArray) THEN
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 )
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);
newsym := new.sym(Symbol); old := newsym.sibling;
IF old # NIL THEN
FPrintObj(old, M);
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, Diagnostics.Invalid, new.name)
END
END
ELSIF new.vis # PCT.Internal THEN
extended:=TRUE; PCM.ErrorN(403, Diagnostics.Invalid, new.name)
END
END CompareSymbol;
PROCEDURE OutParList(p: PCT.Parameter);
BEGIN
WHILE (p # NIL) & (p.name # PCT.SelfName) DO
IF PCT.WinAPIParam IN p.flags THEN
PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.WinAPIParam)
ELSIF PCT.CParam IN p.flags THEN
PCM.SymWNum(r, SFobjflag); PCM.SymWNum(r, PCM.CParam)
END;
IF p.ref THEN PCM.SymWNum(r, SFvar); END;
IF PCM.ReadOnly IN p.flags THEN
PCM.SymWNum(r, SFreadonly);
END;
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))
ELSIF type IS PCT.EnhArray THEN
PCM.Error( 200, -1, "const arrays cannot be exported yet" );
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
StringPool.GetIndex(name, index);
AddImport(impList, index);
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
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
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;
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);
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
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
mAttr := tAttr.mod.sym(Module);
IF StrictChecks THEN
i := 0;
WHILE (M.imports[i].sym # mAttr) DO INC(i) END;
StringPool.GetString(M.imports[i].name, mname);
PCT.GetTypeName(typ, tname);
i := 0;
WHILE (mAttr.struct[i] # typ) DO INC(i) END;
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)
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)
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);
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);
IF typ.mode=PCT.static THEN PCM.SymWNum(r, typ.len) END
END
ELSIF typ IS PCT.EnhArray THEN
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;
ELSIF typ IS PCT.Pointer THEN
PCM.SymWNum(r, SFtypPointer); OutStruct(typ(PCT.Pointer).base);
PCM.SymWString(r, name);
PCM.SymWNum(r, 0);
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);
IF Trace THEN PCM.LogWLn; PCM.LogWStr("OM.OutModule/const") END;
IF m.imports # NIL THEN
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;
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;
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;
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;
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;
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
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
IF first THEN PCM.SymWNum(r, SFtyp); first := FALSE END;
OutStruct(t1.type)
END;
t1 := t1.dlink
END;
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;
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);
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;
ASSERT(M.flags - ImportedModuleFlag = {});
OutModule(M);
IF PCM.error THEN RETURN END;
PCM.CloseSym(r);
IF changed OR extended THEN
IF changed THEN
IF newsym OR new THEN COPY(" new symbol file", msg) ELSE PCM.Error(155, Diagnostics.Invalid, "") END
ELSIF extended THEN
IF extend OR new THEN COPY(" extended symbol file", msg) ELSE PCM.Error(155, Diagnostics.Invalid, "") END
END
END
END Export;
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
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
list[i] := idx;
ELSE
END;
END AddImport;
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 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);
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;
PROCEDURE Import*(self: PCT.Module; VAR M: PCT.Module; modname: StringPool.Index);
VAR
tag, res, 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);
ELSIF (s1 IS PCT.EnhArray) & (s2 IS PCT.EnhArray) THEN
res := EqualNames( s1( PCT.EnhArray ).base, s2( PCT.EnhArray ).base );
ELSIF (s1 IS PCT.Tensor) & (s2 IS PCT.Tensor) THEN
res := EqualNames( s1( PCT.Tensor ).base, s2( PCT.Tensor ).base );
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) 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);
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;
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, Diagnostics.Invalid, obj.name); MAttr.changed:=TRUE
ELSIF old.vis#obj.vis THEN
PCM.ErrorN(401, Diagnostics.Invalid, 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
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;
BEGIN
styp := NIL;
NEW(s); PCT.InitScope(s, upper, {}, TRUE); PCT.SetOwner(s);
R.RawNum(tag);
WHILE tag#SFend DO
flags := {};
IF tag = SFobjflag THEN
R.RawNum(f); R.RawNum(tag);
IF f = PCM.CParam THEN
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;
IF tag = SFreadonly THEN
INCL(flags,PCM.ReadOnly); R.RawNum(tag);
END;
InStruct(str); ReadStrIndex(R, readString, name);
IF (name = PCT.SelfName) OR (name = altSelf) THEN
styp := str; svar := var
ELSE
s.CreatePar(PCT.Public, var, name, flags, str, 0 , res);
Assert(res = PCT.Ok);
END;
R.RawNum(tag)
END;
IF styp # NIL THEN
s.CreatePar(PCT.Public, svar, PCT.SelfName, {}, styp, 0 , res);
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);
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)) DO
InObj(name, vis, flags, typ);
IF name = empty THEN vis := PCT.Internal; name := PCT.Anonymous END;
s.CreateVar(name, vis, flags, typ, 0, NIL, res);
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, res);
Assert(res = PCT.Ok);
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, Diagnostics.Invalid);
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;
flags: LONGINT;
BEGIN
IF tag <= 0 THEN
ASSERT(MAttr.struct[-tag]#NIL);
typ := MAttr.struct[-tag];
IF TraceImport THEN
PCM.LogWLn; PCM.LogWStr("InStruct / OldStr "); PCM.LogWNum(-tag)
END
ELSIF tag <= SFlastStruct THEN 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
IF tag = SFmodOther THEN R.RawNum(tag) ELSE tag := tag-SFmod1 END;
mod := MAttr.import[tag]; ReadStrIndex(R, readString, typname);
modAttr := mod.sym(Module);
IF typname # empty THEN
i := 0;
WHILE (i<modAttr.nofstr) & ((modAttr.struct[i].owner=NIL) OR (modAttr.struct[i].owner.name # typname)) DO INC(i) END;
IF i<modAttr.nofstr THEN typ := modAttr.struct[i] ELSE typ := PCT.UndefType END;
IF (modAttr.reimp = NIL) OR (modAttr.nofreimp = LEN(modAttr.reimp)) THEN ExtendStructArray(modAttr.reimp) END;
modAttr.reimp[modAttr.nofreimp] := typ; INC(modAttr.nofreimp);
IF TraceImport THEN
PCM.LogWLn; PCM.LogWStr("InStruct / Imported "); PCM.LogWStr0(mod.name);
PCM.LogWStr("."); PCM.LogWStr0(typname);
END
ELSE
R.RawNum(typadr); typ := modAttr.reimp[typadr];
IF TraceImport THEN
PCM.LogWLn; PCM.LogWStr("InStruct / Re-Imported "); PCM.LogWStr0(mod.name);
PCM.LogWStr("."); PCM.LogWStr0(typ.owner.name);
END
END
ELSE
strref := MAttr.nofstr; INC(MAttr.nofstr);
IF MAttr.nofstr >= 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);
CASE typtag OF
| SFtypOpenArr, SFtypArray:
NEW(arr); typ := arr
| SFtypOpenEnhArr, SFtypStaticEnhArray:
NEW( earr ); typ := earr
| SFtypTensor:
NEW(tensor); typ := tensor;
| 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);
END;
END;
| SFtypProcTyp:
NEW(proc); typ := proc
END;
MAttr.struct[strref] := typ;
NEW(tAttr, M); typ.sym:=tAttr; tAttr.strref := strref;
InStruct(btyp);
CASE typtag OF
| SFtypOpenArr:
PCT.InitOpenArray(arr, btyp, res);
Assert(res = PCT.Ok);
ReadStrIndex(R, readString, name);
R.RawNum(flags);
IF TraceImport THEN
PCM.LogWLn; PCM.LogWStr("InStruct / User / OpenArr ");
IF name # empty THEN PCM.LogWStr0(name) END
END
| SFtypOpenEnhArr:
PCT.InitOpenEnhArray( earr, btyp, {PCT.open}, res );
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:
ReadStrIndex( R, readString, name ); R.RawNum( len );
PCT.InitStaticEnhArray( earr, len, btyp, {PCT.static}, res );
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
| SFtypArray:
ReadStrIndex(R, readString, name);
R.RawNum(flags);
R.RawNum(len);
PCT.InitStaticArray(arr, len, btyp, res);
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);
END;
ReadStrIndex(R, readString, name);
R.RawNum(flags);
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);
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);
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, , res);
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}
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
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, Diagnostics.Invalid, ""); 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;
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)) DO
InObj(name, vis, flag, str);
IF ~selfimport THEN
scope.CreateValue(name, vis, InConst(), 0, res);
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)) DO
InObj(name, vis, flag, str);
IF ~selfimport THEN
scope.CreateVar(name, vis, flag, str, 0, NIL, res);
Assert(res = PCT.Ok);
ELSE
Insert(scope, PCT.NewGlobalVar(vis, name, flag, str, res));
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 < SFoperator) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) DO
InObj(name, vis, flag, str); pscope := InParList(scope);
IF ~selfimport THEN
scope.CreateProc(name, vis, flag, pscope, str, 0, res);
Assert(res = PCT.Ok);
ELSE
proc := PCT.NewProc(vis, name, flag, pscope, str, res);
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)) 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, res);
Assert(res = PCT.Ok);
ELSE
proc := PCT.NewProc(vis, name, flag, pscope, str, res);
Assert(res = PCT.Ok);
Insert(scope, proc);
END;
PCT.ChangeState(pscope, PCT.structdeclared, -1);
END
END;
IF tag = SFcproc THEN R.RawNum(tag);
WHILE (tag < SFalias) OR ((SFtypOpenEnhArr <= tag) & (tag <= SFtypStaticEnhArray)) DO
InObj(name, vis, flag, str); pscope := InParList(scope);
INCL(flag, PCT.Inline);
IF ~selfimport THEN
scope.CreateProc(name, vis, flag, pscope, str, 0, res);
Assert(res = PCT.Ok);
ELSE
Insert(scope, PCT.NewProc(vis, name, flag, pscope, str, res));
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)) DO
InStruct(str); ReadStrIndex(R, readString, name);
IF ~selfimport THEN
scope.CreateType(name, PCT.Public, str, 0, res);
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)) DO InStruct(str); R.RawNum(tag) END
END;
IF importError THEN
M := NIL
ELSE
ImportComplete(M)
END
END Import;
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
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.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);
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).
*)