MODULE DevCPE; (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPE.odc *) (* DO NOT EDIT *) IMPORT SYSTEM, Dates, DevCPM, DevCPT; CONST (* item base modes (=object modes) *) Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; (* structure forms *) Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; Pointer = 13; ProcTyp = 14; Comp = 15; Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; (* composite structure forms *) Basic = 1; Array = 2; DynArr = 3; Record = 4; (* object modes *) Fld = 4; Typ = 5; Head = 12; (* module visibility of objects *) internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; (* history of imported objects *) inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; (* meta interface consts *) mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6; mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13; mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3; mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4; mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13; mInterface = 32; mGuid = 33; mResult = 34; (* sysflag *) untagged = 1; noAlign = 3; union = 7; interface = 10; (* fixup types *) absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; (* kernel flags *) iptrs = 30; expAllFields = TRUE; (* implementation restrictions *) CodeBlocks = 512; CodeLength = 16384; MaxNameTab = 800000H; useAllRef = FALSE; outSignatures = TRUE; TYPE CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR; VAR pc*: INTEGER; dsize*: INTEGER; (* global data size *) KNewRec*, KNewArr*: DevCPT.Object; closeLbl*: INTEGER; CaseLinks*: DevCPT.LinkList; processor: INTEGER; bigEndian: BOOLEAN; procVarIndirect: BOOLEAN; idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER; Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object; outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN; codePos, srcPos: INTEGER; options: SET; code: ARRAY CodeBlocks OF CodeBlock; actual: CodeBlock; actIdx, blkIdx: INTEGER; CodeOvF: BOOLEAN; zero: ARRAY 16 OF SHORTCHAR; (* all 0X *) imports: INTEGER; dllList, dllLast: DevCPT.Object; PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER); CONST N = 4294967296.0; (* 2^32 *) VAR rh, rl: REAL; BEGIN rl := con.intval; rh := con.realval / N; IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N END; hi := SHORT(ENTIER(rh)); rl := rl + (rh - hi) * N; IF rl < 0 THEN hi := hi - 1; rl := rl + N ELSIF rl >= N THEN hi := hi + 1; rl := rl - N END; IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END; low := SHORT(ENTIER(rl)) (* hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0)); r := con.realval + con.intval - hi * 4294967296.0; IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; low := SHORT(ENTIER(r)) *) END GetLongWords; PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER); VAR r: SHORTREAL; BEGIN r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r) END GetRealWord; PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER); TYPE A = ARRAY 2 OF INTEGER; VAR a: A; BEGIN a := SYSTEM.VAL(A, con.realval); IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END END GetRealWords; PROCEDURE IsSame (x, y: REAL): BOOLEAN; BEGIN RETURN (x = y) & ((x # 0.) OR (1. / x = 1. / y)) END IsSame; PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER); VAR c: DevCPT.Const; BEGIN INCL(con.setval, form); CASE form OF | String8: obj := Const8; c := obj.conval; WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END | String16: obj := Const16; c := obj.conval; WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END | Int64: obj := Const64; c := obj.conval; WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO c := c.link END; IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END | Real32: obj := Const32; c := obj.conval; WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; IF c = NIL THEN adr := idx32; INC(idx32, 4) END | Real64: obj := Const64; c := obj.conval; WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; IF c = NIL THEN adr := idx64; INC(idx64, 8) END | Guid: obj := Const32; c := obj.conval; WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; IF c = NIL THEN adr := idx32; INC(idx32, 16) END END; IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END; con.intval := adr END AllocConst; PROCEDURE AllocTypDesc* (typ: DevCPT.Struct); (* typ.comp = Record *) VAR obj: DevCPT.Object; name: DevCPT.Name; BEGIN IF typ.strobj = NIL THEN name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null; (* avoid err 1 *) obj.mode := Typ; obj.typ := typ; typ.strobj := obj END END AllocTypDesc; PROCEDURE PutByte* (a, x: INTEGER); BEGIN code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256)) END PutByte; PROCEDURE PutShort* (a, x: INTEGER); BEGIN IF bigEndian THEN PutByte(a, x DIV 256); PutByte(a + 1, x) ELSE PutByte(a, x); PutByte(a + 1, x DIV 256) END END PutShort; PROCEDURE PutWord* (a, x: INTEGER); BEGIN IF bigEndian THEN PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H); PutByte(a + 2, x DIV 256); PutByte(a + 3, x) ELSE PutByte(a, x); PutByte(a + 1, x DIV 256); PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H) END END PutWord; PROCEDURE ThisByte* (a: INTEGER): INTEGER; BEGIN RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength]) END ThisByte; PROCEDURE ThisShort* (a: INTEGER): INTEGER; BEGIN IF bigEndian THEN RETURN ThisByte(a) * 256 + ThisByte(a+1) ELSE RETURN ThisByte(a+1) * 256 + ThisByte(a) END END ThisShort; PROCEDURE ThisWord* (a: INTEGER): INTEGER; BEGIN IF bigEndian THEN RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3) ELSE RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a) END END ThisWord; PROCEDURE GenByte* (x: INTEGER); BEGIN IF actIdx >= CodeLength THEN IF blkIdx < CodeBlocks THEN NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0 ELSE IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END; actIdx := 0; pc := 0 END END; actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc) END GenByte; PROCEDURE GenShort* (x: INTEGER); BEGIN IF bigEndian THEN GenByte(x DIV 256); GenByte(x) ELSE GenByte(x); GenByte(x DIV 256) END END GenShort; PROCEDURE GenWord* (x: INTEGER); BEGIN IF bigEndian THEN GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x) ELSE GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H) END END GenWord; PROCEDURE WriteCode; VAR i, j, k, n: INTEGER; b: CodeBlock; BEGIN j := 0; k := 0; WHILE j < pc DO n := pc - j; i := 0; b := code[k]; IF n > CodeLength THEN n := CodeLength END; WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END; INC(j, n); INC(k) END END WriteCode; PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList; VAR link: DevCPT.LinkList; m: DevCPT.Object; BEGIN ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ)); ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp)); IF obj.mnolev >= 0 THEN (* not imported *) CASE obj.mode OF | Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END | TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END | Var: offs := offs + dsize; obj := Data | Con, IProc, XProc, LProc: END ELSIF obj.mode = Typ THEN IF obj.typ.untagged THEN (* add desc for imported untagged types *) IF obj.links = NIL THEN obj.link := descList; descList := obj END ELSE m := DevCPT.GlbMod[-obj.mnolev]; IF m.library # NIL THEN RETURN NIL END (* type import from dll *) END END; link := obj.links; WHILE (link # NIL) & (link.offset # offs) DO link := link.next END; IF link = NIL THEN NEW(link); link.offset := offs; link.linkadr := 0; link.next := obj.links; obj.links := link END; RETURN link END OffsetLink; PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object; VAR obj: DevCPT.Object; BEGIN obj := typ.strobj; IF obj = NIL THEN obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0; obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj END; RETURN obj END TypeObj; PROCEDURE Align (n: INTEGER); VAR p: INTEGER; BEGIN p := DevCPM.ObjLen(); DevCPM.ObjWBytes(zero, (-p) MOD n) END Align; PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR); VAR ch: SHORTCHAR; i: SHORTINT; BEGIN i := 0; REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X END OutName; PROCEDURE Out2 (x: INTEGER); (* byte ordering must correspond to target machine *) BEGIN IF bigEndian THEN DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) ELSE DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256))) END END Out2; PROCEDURE Out4 (x: INTEGER); (* byte ordering must correspond to target machine *) BEGIN IF bigEndian THEN DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H))); DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) ELSE DevCPM.ObjWLInt(x) END END Out4; PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER); VAR link: DevCPT.LinkList; BEGIN link := OffsetLink(obj, offs); IF link # NIL THEN Out4(typ * 1000000H + link.linkadr MOD 1000000H); link.linkadr := -(DevCPM.ObjLen() - headSize - 4) ELSE Out4(0) END END OutReference; PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER); VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; BEGIN IF typ.form = Pointer THEN IF ip & (typ.sysflag = interface) OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN btyp := typ.BaseTyp; IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ; fld := typ.link; WHILE (fld # NIL) & (fld.mode = Fld) DO IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface) OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num) ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num) END; fld := fld.link END ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n; WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN i := num; FindPtrs(btyp, adr, ip, num); IF num # i THEN i := 1; WHILE i < n DO INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i) END END END END END FindPtrs; PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR); BEGIN DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name) END OutRefName; PROCEDURE OutRefs* (obj: DevCPT.Object); VAR f: BYTE; BEGIN IF outRef & (obj # NIL) THEN OutRefs(obj.left); IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN f := obj.typ.form; IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64}) OR outURef & (obj.typ.comp # DynArr) OR outAllRef & ~obj.typ.untagged OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END; IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr))) ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec))) ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16))) ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64))) ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid))) ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult))) ELSIF f = Pointer THEN IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface))) ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) END ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1))) ELSE DevCPM.ObjW(SHORT(CHR(f))) END; IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END; OutName(obj.name^) END END ; OutRefs(obj.right) END END OutRefs; PROCEDURE OutSourceRef* (pos: INTEGER); BEGIN IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN WHILE pc > codePos + 250 DO DevCPM.ObjW(SHORT(CHR(250))); INC(codePos, 250); DevCPM.ObjWNum(0) END; DevCPM.ObjW(SHORT(CHR(pc - codePos))); codePos := pc; DevCPM.ObjWNum(pos - srcPos); srcPos := pos END END OutSourceRef; PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER); BEGIN WHILE link # NIL DO ASSERT(link.linkadr # 0); DevCPM.ObjWNum(link.linkadr); DevCPM.ObjWNum(adr + link.offset); link := link.next END END OutPLink; PROCEDURE OutLink (link: DevCPT.LinkList); BEGIN OutPLink(link, 0); DevCPM.ObjW(0X) END OutLink; PROCEDURE OutNames; VAR a, b, c: DevCPT.Object; BEGIN a := nameList; b := NIL; WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END; DevCPM.ObjW(0X); (* names[0] = 0X *) WHILE b # NIL DO OutName(b.name^); b := b.nlink END; END OutNames; PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR); PROCEDURE Copy (n: INTEGER); VAR x, y: INTEGER; BEGIN x := ORD(str[n]); y := ORD(str[n + 1]); IF x >= ORD("a") THEN DEC(x, ORD("a") - 10) ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10) ELSE DEC(x, ORD("0")) END; IF y >= ORD("a") THEN DEC(y, ORD("a") - 10) ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10) ELSE DEC(y, ORD("0")) END; DevCPM.ObjW(SHORT(CHR(x * 16 + y))) END Copy; BEGIN IF bigEndian THEN Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17) ELSE Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15) END; Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35) END OutGuid; PROCEDURE OutConst (obj: DevCPT.Object); TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR; VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER; BEGIN a := obj.conval; b := NIL; WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END; WHILE b # NIL DO IF String8 IN b.setval THEN DevCPM.ObjWBytes(b.ext^, b.intval2); Align(4) ELSIF String16 IN b.setval THEN i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0; Align(4) ELSIF Real32 IN b.setval THEN r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r); IF DevCPM.LEHost = bigEndian THEN ch := a4[0]; a4[0] := a4[3]; a4[3] := ch; ch := a4[1]; a4[1] := a4[2]; a4[2] := ch END; DevCPM.ObjWBytes(a4, 4) ELSIF Real64 IN b.setval THEN a8 := SYSTEM.VAL(A8, b.realval); IF DevCPM.LEHost = bigEndian THEN ch := a8[0]; a8[0] := a8[7]; a8[7] := ch; ch := a8[1]; a8[1] := a8[6]; a8[6] := ch; ch := a8[2]; a8[2] := a8[5]; a8[5] := ch; ch := a8[3]; a8[3] := a8[4]; a8[4] := ch END; DevCPM.ObjWBytes(a8, 8) ELSIF Int64 IN b.setval THEN (* intval moved to intval2 by AllocConst *) x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x; IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END ELSIF Guid IN b.setval THEN OutGuid(b.ext^) END; b := b.link END END OutConst; PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN); BEGIN IF typ = NIL THEN Out4(0) ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr) ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec) ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr) ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid) ELSIF typ = DevCPT.restyp THEN Out4(mResult) ELSE CASE typ.form OF | Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0) | Bool, Char8: Out4(typ.form - 1) | Int8..Set: Out4(typ.form) | Char16: Out4(mChar16) | Int64: Out4(mInt64) | ProcTyp: OutReference(TypeObj(typ), 0, absolute) | Pointer: IF typ.sysflag = interface THEN Out4(mInterface) ELSIF typ.untagged THEN Out4(mSysPtr) ELSE OutReference(TypeObj(typ), 0, absolute) END | Comp: IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute) ELSE Out4(0) END END END END OutStruct; PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER; VAR n: INTEGER; BEGIN n := 0; IF obj.name # DevCPT.null THEN IF obj.num = 0 THEN obj.num := namex; WHILE obj.name[n] # 0X DO INC(n) END; INC(namex, n + 1); obj.nlink := nameList; nameList := obj END; n := obj.num; END; RETURN n END NameIdx; PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER); VAR p: DevCPT.Object; n, m: INTEGER; BEGIN pos := DevCPM.ObjLen() - headSize; OutStruct(retTyp, TRUE); p := par; n := 0; WHILE p # NIL DO INC(n); p := p.link END; Out4(n); p := par; WHILE p # NIL DO IF p.mode # VarPar THEN m := mValue ELSIF p.vis = inPar THEN m := mInPar ELSIF p.vis = outPar THEN m := mOutPar ELSE m := mVarPar END; Out4(NameIdx(p) * 256 + m); OutStruct(p.typ, TRUE); p := p.link END END OutSignature; PROCEDURE PrepObject (obj: DevCPT.Object); BEGIN IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN (* write param list *) OutSignature(obj.link, obj.typ, obj.conval.intval) END END PrepObject; PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object); VAR vis: INTEGER; BEGIN Out4(fprint); Out4(offs); IF obj.vis = internal THEN vis := mInternal ELSIF obj.vis = externalR THEN vis := mReadonly ELSIF obj.vis = external THEN vis := mExported END; Out4(mode + vis * 16 + NameIdx(obj) * 256); IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute) (* ref to par list *) ELSE OutStruct(typ, mode = mField) END END OutObject; PROCEDURE PrepDesc (desc: DevCPT.Struct); VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct; BEGIN IF desc.comp = Record THEN (* write field list *) desc.strobj.adr := DevCPM.ObjLen() - headSize; n := 0; fld := desc.link; WHILE (fld # NIL) & (fld.mode = Fld) DO IF expAllFields OR (fld.vis # internal) THEN INC(n) END; fld := fld.link END; Out4(n); fld := desc.link; WHILE (fld # NIL) & (fld.mode = Fld) DO IF expAllFields OR (fld.vis # internal) THEN OutObject(mField, 0, fld.adr, fld.typ, fld) END; fld := fld.link END ELSIF (desc.form = ProcTyp) & outSignatures THEN (* write param list *) OutSignature(desc.link, desc.BaseTyp, desc.n) END; (* assert name and base type are included *) IF desc.untagged THEN n := NameIdx(untgd) ELSE n := NameIdx(desc.strobj) END; IF desc.form # ProcTyp THEN b := desc.BaseTyp; IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp, ProcTyp}) & (b.sysflag # interface) & (b # DevCPT.guidtyp) & (~b.untagged OR outURef & (b.form = Comp)) THEN l := OffsetLink(TypeObj(b), 0) END END END PrepDesc; PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object; VAR obj: DevCPT.Object; BEGIN IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END; obj := NumMeth(root.left, num); IF obj = NIL THEN obj := NumMeth(root.right, num) END; RETURN obj END NumMeth; PROCEDURE OutDesc (desc: DevCPT.Struct); VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE; name: DevCPT.Name; BEGIN ASSERT(~desc.untagged); IF desc.comp = Record THEN xb := desc; flddir := desc.strobj.adr; REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged; Out4(-1); i := desc.n; WHILE i > 0 DO DEC(i); t := desc; REPEAT m := NumMeth(t.link, i); t := t.BaseTyp UNTIL (m # NIL) OR (t = xb); IF m # NIL THEN IF absAttr IN m.conval.setval THEN Out4(0) ELSE OutReference(m, 0, absolute) END ELSIF (xb = NIL) OR xb.untagged THEN Out4(0) (* unimplemented ANYREC method *) ELSE OutReference(xb.strobj, -4 - 4 * i, copy) END END; desc.strobj.adr := DevCPM.ObjLen() - headSize; (* desc adr *) Out4(desc.size); OutReference(Mod, 0, absolute); IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; IF desc.attribute = extAttr THEN attr := 1 ELSIF desc.attribute = limAttr THEN attr := 2 ELSIF desc.attribute = absAttr THEN attr := 3 ELSE attr := 0 END; Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0; WHILE i <= desc.extlev DO t := desc; WHILE t.extlev > i DO t := t.BaseTyp END; IF t.sysflag = interface THEN Out4(0) ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute) ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute) ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute) ELSE OutReference(xb.strobj, 12 + 4 * i, copy) END; INC(i) END; WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END; OutReference(Meta, flddir, absolute); (* ref to field list *) nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr); Out4(-(4 * nofptr + 4)); nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr); Out4(-1) ELSE desc.strobj.adr := DevCPM.ObjLen() - headSize; lev := 0; size := 0; IF desc.comp = Array THEN size := desc.n; form := mArray ELSIF desc.comp = DynArr THEN form := mArray; lev := SHORT(SHORT(desc.n + 1)) ELSIF desc.form = Pointer THEN form := mPointer ELSE ASSERT(desc.form = ProcTyp); DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp; END; Out4(size); OutReference(Mod, 0, absolute); IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; Out4(form + lev * 16 + NameIdx(m) * 256); IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE) ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute) (* ref to par list *) END END END OutDesc; PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER); VAR i: INTEGER; t: Dates.Time; d: Dates.Date; BEGIN Out4(0); (* link *) Out4(ORD(options)); (* opts *) Out4(0); (* refcnt *) Dates.GetDate(d); Dates.GetTime(t); (* compile time *) Out2(d.year); Out2(d.month); Out2(d.day); Out2(t.hour); Out2(t.minute); Out2(t.second); Out4(0); Out4(0); Out4(0); (* load time *) Out4(0); (* ext *) IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute); (* terminator *) ELSE Out4(0) END; Out4(imports); (* nofimps *) Out4(nofptr); (* nofptrs *) Out4(pc); (* csize *) Out4(dsize); (* dsize *) Out4(refSize); (* rsize *) OutReference(Code, 0, absolute); (* code *) OutReference(Data, 0, absolute); (* data *) OutReference(Meta, 0, absolute); (* refs *) IF procVarIndirect THEN OutReference(Proc, 0, absolute); (* procBase *) ELSE OutReference(Code, 0, absolute); (* procBase *) END; OutReference(Data, 0, absolute); (* varBase *) OutReference(Meta, namePos, absolute); (* names *) OutReference(Meta, ptrPos, absolute); (* ptrs *) OutReference(Meta, impPos, absolute); (* imports *) OutReference(Meta, expPos, absolute); (* export *) i := 0; (* name *) WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END; DevCPM.ObjW(0X); Align(4) END OutModDesc; PROCEDURE OutProcTable (obj: DevCPT.Object); (* 68000 *) BEGIN IF obj # NIL THEN OutProcTable(obj.left); IF obj.mode IN {XProc, IProc} THEN Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0); END; OutProcTable(obj.right); END; END OutProcTable; PROCEDURE PrepExport (obj: DevCPT.Object); BEGIN IF obj # NIL THEN PrepExport(obj.left); IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN PrepObject(obj) END; PrepExport(obj.right) END END PrepExport; PROCEDURE OutExport (obj: DevCPT.Object); VAR num: INTEGER; BEGIN IF obj # NIL THEN OutExport(obj.left); IF (obj.history # removed) & ((obj.vis # internal) OR (obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN DevCPT.FPrintObj(obj); IF obj.mode IN {LProc, XProc, IProc} THEN IF procVarIndirect THEN ASSERT(obj.nlink = NIL); num := obj.num; obj.num := 0; OutObject(mProc, obj.fprint, num, NIL, obj); obj.num := num ELSE OutObject(mProc, obj.fprint, obj.adr, NIL, obj) END ELSIF obj.mode = Var THEN OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj) ELSIF obj.mode = Typ THEN OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj) ELSE ASSERT(obj.mode IN {Con, CProc}); OutObject(mConst, obj.fprint, 0, NIL, obj) END END; OutExport(obj.right) END END OutExport; PROCEDURE OutCLinks (obj: DevCPT.Object); BEGIN IF obj # NIL THEN OutCLinks(obj.left); IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END; OutCLinks(obj.right) END END OutCLinks; PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER); BEGIN IF obj # NIL THEN OutCPLinks(obj.left, base); IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END; OutCPLinks(obj.right, base) END END OutCPLinks; PROCEDURE OutImport (obj: DevCPT.Object); VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER; BEGIN IF obj # NIL THEN OutImport(obj.left); IF obj.mode = Typ THEN typ := obj.typ; IF obj.used OR (typ.form IN {Pointer, Comp}) & (typ.strobj = obj) & ((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN DevCPT.FPrintStr(typ); DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^); IF obj.used THEN opt := 2 ELSE opt := 0 END; IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1))); IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt))) END; OutLink(obj.links) END ELSIF obj.used THEN DevCPT.FPrintObj(obj); IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) ELSIF obj.mode IN {XProc, IProc} THEN DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) ELSE ASSERT(obj.mode IN {Con, CProc}); DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint) END END; OutImport(obj.right) END END OutImport; PROCEDURE OutUseBlock; VAR m, obj: DevCPT.Object; i: INTEGER; BEGIN m := dllList; WHILE m # NIL DO obj := m.nlink; WHILE obj # NIL DO IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar))) ELSE DevCPM.ObjW(SHORT(CHR(mProc))) END; IF obj.entry # NIL THEN OutName(obj.entry^) ELSE OutName(obj.name^); END; DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links); obj := obj.nlink END; DevCPM.ObjW(0X); m := m.link END; i := 1; WHILE i < DevCPT.nofGmod DO obj := DevCPT.GlbMod[i]; IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END; INC(i) END; END OutUseBlock; PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String); VAR name: DevCPT.String; dll: DevCPT.Object; BEGIN IF obj # NIL THEN CollectDll(obj.left, mod); IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN IF obj.library # NIL THEN name := obj.library ELSE name := mod END; dll := dllList; WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END; IF dll = NIL THEN NEW(dll); dll.library := name; INC(imports); IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END; dllLast := dll; dll.left := dll; END; dll.left.nlink := obj; dll.left := obj END; CollectDll(obj.right, mod) END END CollectDll; PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER); BEGIN IF obj # NIL THEN EnumXProc(obj.left, num); IF obj.mode IN {XProc, IProc} THEN obj.num := num; INC(num, 8); END; EnumXProc(obj.right, num) END; END EnumXProc; PROCEDURE OutHeader*; VAR i: INTEGER; m: DevCPT.Object; BEGIN DevCPM.ObjWLInt(processor); (* processor type *) DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); (* sizes *) imports := 0; i := 1; WHILE i < DevCPT.nofGmod DO m := DevCPT.GlbMod[i]; IF m.library # NIL THEN (* dll import *) CollectDll(m.right, m.library); ELSE INC(imports) (* module import *) END; INC(i) END; DevCPM.ObjWNum(imports); (* num of import *) OutName(DevCPT.SelfName); m := dllList; WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END; i := 1; WHILE i < DevCPT.nofGmod DO m := DevCPT.GlbMod[i]; IF m.library = NIL THEN OutName(m.name^) END; INC(i) END; Align(16); headSize := DevCPM.ObjLen(); IF procVarIndirect THEN i := 0; EnumXProc(DevCPT.topScope.right, i) END END OutHeader; PROCEDURE OutCode*; VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos, con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER; m, obj, dlist: DevCPT.Object; BEGIN (* Ref *) DevCPM.ObjW(0X); (* end mark *) refSize := DevCPM.ObjLen() - headSize; (* Export *) Align(4); IF outSignatures THEN PrepExport(DevCPT.topScope.right) END; (* procedure signatures *) Align(8); expPos := DevCPM.ObjLen(); Out4(0); OutExport(DevCPT.topScope.right); (* export objects *) i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i); (* Pointers *) ptrPos := DevCPM.ObjLen(); obj := DevCPT.topScope.scope; nofptrs := 0; WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END; obj := DevCPT.topScope.scope; i := 0; WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END; IF i > 0 THEN Out4(-1); INCL(options, iptrs) END; (* Prepare Type Descriptors *) dlist := NIL; WHILE descList # NIL DO obj := descList; descList := descList.link; PrepDesc(obj.typ); obj.link := dlist; dlist := obj END; (* Import List *) impPos := DevCPM.ObjLen(); i := 0; WHILE i < imports DO Out4(0); INC(i) END; (* Names *) namePos := DevCPM.ObjLen(); OutNames; (* Const *) Align(4); con8Pos := DevCPM.ObjLen(); OutConst(Const8); con16Pos := DevCPM.ObjLen(); ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8); OutConst(Const16); con32Pos := DevCPM.ObjLen(); ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16); OutConst(Const32); con64Pos := DevCPM.ObjLen(); ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32); IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END; OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64); (* Module Descriptor *) Align(16); modPos := DevCPM.ObjLen(); OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize); (* Procedure Table *) procPos := DevCPM.ObjLen(); OutProcTable(DevCPT.topScope.right); Out4(0); Out4(0); (* at least one entry in ProcTable *) Out4(0); (* sentinel *) (* Type Descriptors *) obj := dlist; WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END; (* Code *) codePos := DevCPM.ObjLen(); WriteCode; WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END; (* Fixups *) OutLink(KNewRec.links); OutLink(KNewArr.links); (* metalink *) OutPLink(Const8.links, con8Pos - headSize); OutPLink(Const16.links, con16Pos - headSize); OutPLink(Const32.links, con32Pos - headSize); OutPLink(Const64.links, con64Pos - headSize); OutLink(Meta.links); (* desclink *) obj := dlist; i := modPos - headSize; WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END; IF procVarIndirect THEN OutPLink(Proc.links, procPos - modPos); OutCPLinks(DevCPT.topScope.right, procPos - modPos) END; OutLink(Mod.links); (* codelink *) IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END; OutPLink(CaseLinks, 0); OutLink(Code.links); (* datalink *) OutLink(Data.links); (* Use *) OutUseBlock; (* Header Fixups *) DevCPM.ObjSet(8); DevCPM.ObjWLInt(headSize); DevCPM.ObjWLInt(modPos - headSize); DevCPM.ObjWLInt(codePos - modPos); DevCPM.ObjWLInt(pc); DevCPM.ObjWLInt(dsize); IF namex > MaxNameTab THEN DevCPM.err(242) END; IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END END OutCode; PROCEDURE Init* (proc: INTEGER; opt: SET); CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14; BEGIN processor := proc; bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt; outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt; outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options); outSrc := srcpos IN opt; pc := 0; actIdx := CodeLength; blkIdx := 0; idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1; options := opt * {0..15}; CodeOvF := FALSE; KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; codePos := 0; srcPos := 0; NEW(untgd); untgd.name := DevCPT.NewName("!"); closeLbl := 0 END Init; PROCEDURE Close*; BEGIN KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END; actual := NIL; untgd := NIL; END Close; BEGIN NEW(KNewRec); KNewRec.mnolev := -128; NEW(KNewArr); KNewArr.mnolev := -128; NEW(Const8); Const8.mode := Con; Const8.mnolev := 0; NEW(Const16); Const16.mode := Con; Const16.mnolev := 0; NEW(Const32); Const32.mode := Con; Const32.mnolev := 0; NEW(Const64); Const64.mode := Con; Const64.mnolev := 0; NEW(Code); Code.mode := Con; Code.mnolev := 0; NEW(Data); Data.mode := Con; Data.mnolev := 0; NEW(Mod); Mod.mode := Con; Mod.mnolev := 0; NEW(Proc); Proc.mode := Con; Proc.mnolev := 0; NEW(Meta); Meta.mode := Con; Mod.mnolev := 0; END DevCPE.