1 MODULE DevCPE;
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPE.odc *)
4 (* DO NOT EDIT *)
6 IMPORT SYSTEM, Dates, DevCPM, DevCPT;
9 CONST
10 (* item base modes (=object modes) *)
11 Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
13 (* structure forms *)
14 Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
15 Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
16 Pointer = 13; ProcTyp = 14; Comp = 15;
17 Char16 = 16; String16 = 17; Int64 = 18; Guid = 23;
19 (* composite structure forms *)
20 Basic = 1; Array = 2; DynArr = 3; Record = 4;
22 (* object modes *)
23 Fld = 4; Typ = 5; Head = 12;
25 (* module visibility of objects *)
26 internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
28 (* history of imported objects *)
29 inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5;
31 (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
32 newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
34 (* meta interface consts *)
35 mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
36 mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6;
37 mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13;
38 mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3;
39 mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
40 mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13;
41 mInterface = 32; mGuid = 33; mResult = 34;
43 (* sysflag *)
44 untagged = 1; noAlign = 3; union = 7; interface = 10;
46 (* fixup types *)
47 absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105;
49 (* kernel flags *)
50 iptrs = 30;
52 expAllFields = TRUE;
54 (* implementation restrictions *)
55 CodeBlocks = 512;
56 CodeLength = 16384;
57 MaxNameTab = 800000H;
59 useAllRef = FALSE;
60 outSignatures = TRUE;
62 TYPE
63 CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR;
65 VAR
66 pc*: INTEGER;
67 dsize*: INTEGER; (* global data size *)
68 KNewRec*, KNewArr*: DevCPT.Object;
69 closeLbl*: INTEGER;
70 CaseLinks*: DevCPT.LinkList;
72 processor: INTEGER;
73 bigEndian: BOOLEAN;
74 procVarIndirect: BOOLEAN;
75 idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER;
76 Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object;
77 outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN;
78 codePos, srcPos: INTEGER;
79 options: SET;
80 code: ARRAY CodeBlocks OF CodeBlock;
81 actual: CodeBlock;
82 actIdx, blkIdx: INTEGER;
83 CodeOvF: BOOLEAN;
84 zero: ARRAY 16 OF SHORTCHAR; (* all 0X *)
85 imports: INTEGER;
86 dllList, dllLast: DevCPT.Object;
89 PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER);
90 CONST N = 4294967296.0; (* 2^32 *)
91 VAR rh, rl: REAL;
92 BEGIN
93 rl := con.intval; rh := con.realval / N;
94 IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N
95 ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N
96 END;
97 hi := SHORT(ENTIER(rh));
98 rl := rl + (rh - hi) * N;
99 IF rl < 0 THEN hi := hi - 1; rl := rl + N
100 ELSIF rl >= N THEN hi := hi + 1; rl := rl - N
101 END;
102 IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END;
103 low := SHORT(ENTIER(rl))
104 (*
105 hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0));
106 r := con.realval + con.intval - hi * 4294967296.0;
107 IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END;
108 low := SHORT(ENTIER(r))
109 *)
110 END GetLongWords;
112 PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER);
113 VAR r: SHORTREAL;
114 BEGIN
115 r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r)
116 END GetRealWord;
118 PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER);
119 TYPE A = ARRAY 2 OF INTEGER;
120 VAR a: A;
121 BEGIN
122 a := SYSTEM.VAL(A, con.realval);
123 IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END
124 END GetRealWords;
126 PROCEDURE IsSame (x, y: REAL): BOOLEAN;
127 BEGIN
128 RETURN (x = y) & ((x # 0.) OR (1. / x = 1. / y))
129 END IsSame;
131 PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER);
132 VAR c: DevCPT.Const;
133 BEGIN
134 INCL(con.setval, form);
135 CASE form OF
136 | String8:
137 obj := Const8; c := obj.conval;
138 WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
139 IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END
140 | String16:
141 obj := Const16; c := obj.conval;
142 WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
143 IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END
144 | Int64:
145 obj := Const64; c := obj.conval;
146 WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO
147 c := c.link
148 END;
149 IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END
150 | Real32:
151 obj := Const32; c := obj.conval;
152 WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END;
153 IF c = NIL THEN adr := idx32; INC(idx32, 4) END
154 | Real64:
155 obj := Const64; c := obj.conval;
156 WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END;
157 IF c = NIL THEN adr := idx64; INC(idx64, 8) END
158 | Guid:
159 obj := Const32; c := obj.conval;
160 WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
161 IF c = NIL THEN adr := idx32; INC(idx32, 16) END
162 END;
163 IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END;
164 con.intval := adr
165 END AllocConst;
168 PROCEDURE AllocTypDesc* (typ: DevCPT.Struct); (* typ.comp = Record *)
169 VAR obj: DevCPT.Object; name: DevCPT.Name;
170 BEGIN
171 IF typ.strobj = NIL THEN
172 name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null; (* avoid err 1 *)
173 obj.mode := Typ; obj.typ := typ; typ.strobj := obj
174 END
175 END AllocTypDesc;
178 PROCEDURE PutByte* (a, x: INTEGER);
179 BEGIN
180 code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256))
181 END PutByte;
183 PROCEDURE PutShort* (a, x: INTEGER);
184 BEGIN
185 IF bigEndian THEN
186 PutByte(a, x DIV 256); PutByte(a + 1, x)
187 ELSE
188 PutByte(a, x); PutByte(a + 1, x DIV 256)
189 END
190 END PutShort;
192 PROCEDURE PutWord* (a, x: INTEGER);
193 BEGIN
194 IF bigEndian THEN
195 PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H);
196 PutByte(a + 2, x DIV 256); PutByte(a + 3, x)
197 ELSE
198 PutByte(a, x); PutByte(a + 1, x DIV 256);
199 PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H)
200 END
201 END PutWord;
203 PROCEDURE ThisByte* (a: INTEGER): INTEGER;
204 BEGIN
205 RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength])
206 END ThisByte;
208 PROCEDURE ThisShort* (a: INTEGER): INTEGER;
209 BEGIN
210 IF bigEndian THEN
211 RETURN ThisByte(a) * 256 + ThisByte(a+1)
212 ELSE
213 RETURN ThisByte(a+1) * 256 + ThisByte(a)
214 END
215 END ThisShort;
217 PROCEDURE ThisWord* (a: INTEGER): INTEGER;
218 BEGIN
219 IF bigEndian THEN
220 RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3)
221 ELSE
222 RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a)
223 END
224 END ThisWord;
226 PROCEDURE GenByte* (x: INTEGER);
227 BEGIN
228 IF actIdx >= CodeLength THEN
229 IF blkIdx < CodeBlocks THEN
230 NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0
231 ELSE
232 IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END;
233 actIdx := 0; pc := 0
234 END
235 END;
236 actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc)
237 END GenByte;
239 PROCEDURE GenShort* (x: INTEGER);
240 BEGIN
241 IF bigEndian THEN
242 GenByte(x DIV 256); GenByte(x)
243 ELSE
244 GenByte(x); GenByte(x DIV 256)
245 END
246 END GenShort;
248 PROCEDURE GenWord* (x: INTEGER);
249 BEGIN
250 IF bigEndian THEN
251 GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x)
252 ELSE
253 GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H)
254 END
255 END GenWord;
257 PROCEDURE WriteCode;
258 VAR i, j, k, n: INTEGER; b: CodeBlock;
259 BEGIN
260 j := 0; k := 0;
261 WHILE j < pc DO
262 n := pc - j; i := 0; b := code[k];
263 IF n > CodeLength THEN n := CodeLength END;
264 WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END;
265 INC(j, n); INC(k)
266 END
267 END WriteCode;
270 PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList;
271 VAR link: DevCPT.LinkList; m: DevCPT.Object;
272 BEGIN
273 ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ));
274 ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp));
275 IF obj.mnolev >= 0 THEN (* not imported *)
276 CASE obj.mode OF
277 | Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END
278 | TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END
279 | Var: offs := offs + dsize; obj := Data
280 | Con, IProc, XProc, LProc:
281 END
282 ELSIF obj.mode = Typ THEN
283 IF obj.typ.untagged THEN (* add desc for imported untagged types *)
284 IF obj.links = NIL THEN obj.link := descList; descList := obj END
285 ELSE
286 m := DevCPT.GlbMod[-obj.mnolev];
287 IF m.library # NIL THEN RETURN NIL END (* type import from dll *)
288 END
289 END;
290 link := obj.links;
291 WHILE (link # NIL) & (link.offset # offs) DO link := link.next END;
292 IF link = NIL THEN
293 NEW(link); link.offset := offs; link.linkadr := 0;
294 link.next := obj.links; obj.links := link
295 END;
296 RETURN link
297 END OffsetLink;
300 PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object;
301 VAR obj: DevCPT.Object;
302 BEGIN
303 obj := typ.strobj;
304 IF obj = NIL THEN
305 obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0;
306 obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj
307 END;
308 RETURN obj
309 END TypeObj;
312 PROCEDURE Align (n: INTEGER);
313 VAR p: INTEGER;
314 BEGIN
315 p := DevCPM.ObjLen();
316 DevCPM.ObjWBytes(zero, (-p) MOD n)
317 END Align;
319 PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR);
320 VAR ch: SHORTCHAR; i: SHORTINT;
321 BEGIN i := 0;
322 REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X
323 END OutName;
325 PROCEDURE Out2 (x: INTEGER); (* byte ordering must correspond to target machine *)
326 BEGIN
327 IF bigEndian THEN
328 DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x)))
329 ELSE
330 DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256)))
331 END
332 END Out2;
334 PROCEDURE Out4 (x: INTEGER); (* byte ordering must correspond to target machine *)
335 BEGIN
336 IF bigEndian THEN
337 DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H)));
338 DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x)))
339 ELSE
340 DevCPM.ObjWLInt(x)
341 END
342 END Out4;
344 PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER);
345 VAR link: DevCPT.LinkList;
346 BEGIN
347 link := OffsetLink(obj, offs);
348 IF link # NIL THEN
349 Out4(typ * 1000000H + link.linkadr MOD 1000000H);
350 link.linkadr := -(DevCPM.ObjLen() - headSize - 4)
351 ELSE Out4(0)
352 END
353 END OutReference;
355 PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER);
356 VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
357 BEGIN
358 IF typ.form = Pointer THEN
359 IF ip & (typ.sysflag = interface)
360 OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END
361 ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
362 btyp := typ.BaseTyp;
363 IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ;
364 fld := typ.link;
365 WHILE (fld # NIL) & (fld.mode = Fld) DO
366 IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface)
367 OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num)
368 ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num)
369 END;
370 fld := fld.link
371 END
372 ELSIF typ.comp = Array THEN
373 btyp := typ.BaseTyp; n := typ.n;
374 WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
375 IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
376 i := num; FindPtrs(btyp, adr, ip, num);
377 IF num # i THEN i := 1;
378 WHILE i < n DO
379 INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i)
380 END
381 END
382 END
383 END
384 END FindPtrs;
387 PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR);
388 BEGIN
389 DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name)
390 END OutRefName;
392 PROCEDURE OutRefs* (obj: DevCPT.Object);
393 VAR f: BYTE;
394 BEGIN
395 IF outRef & (obj # NIL) THEN
396 OutRefs(obj.left);
397 IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN
398 f := obj.typ.form;
399 IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64})
400 OR outURef & (obj.typ.comp # DynArr)
401 OR outAllRef & ~obj.typ.untagged
402 OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN
403 IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END;
404 IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr)))
405 ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec)))
406 ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr)))
407 ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16)))
408 ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64)))
409 ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid)))
410 ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult)))
411 ELSIF f = Pointer THEN
412 IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface)))
413 ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr)))
414 ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute)
415 END
416 ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN
417 DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute)
418 ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1)))
419 ELSE DevCPM.ObjW(SHORT(CHR(f)))
420 END;
421 IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END;
422 OutName(obj.name^)
423 END
424 END ;
425 OutRefs(obj.right)
426 END
427 END OutRefs;
429 PROCEDURE OutSourceRef* (pos: INTEGER);
430 BEGIN
431 IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN
432 WHILE pc > codePos + 250 DO
433 DevCPM.ObjW(SHORT(CHR(250)));
434 INC(codePos, 250);
435 DevCPM.ObjWNum(0)
436 END;
437 DevCPM.ObjW(SHORT(CHR(pc - codePos)));
438 codePos := pc;
439 DevCPM.ObjWNum(pos - srcPos);
440 srcPos := pos
441 END
442 END OutSourceRef;
445 PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER);
446 BEGIN
447 WHILE link # NIL DO
448 ASSERT(link.linkadr # 0);
449 DevCPM.ObjWNum(link.linkadr);
450 DevCPM.ObjWNum(adr + link.offset);
451 link := link.next
452 END
453 END OutPLink;
455 PROCEDURE OutLink (link: DevCPT.LinkList);
456 BEGIN
457 OutPLink(link, 0); DevCPM.ObjW(0X)
458 END OutLink;
460 PROCEDURE OutNames;
461 VAR a, b, c: DevCPT.Object;
462 BEGIN
463 a := nameList; b := NIL;
464 WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END;
465 DevCPM.ObjW(0X); (* names[0] = 0X *)
466 WHILE b # NIL DO
467 OutName(b.name^);
468 b := b.nlink
469 END;
470 END OutNames;
472 PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR);
474 PROCEDURE Copy (n: INTEGER);
475 VAR x, y: INTEGER;
476 BEGIN
477 x := ORD(str[n]); y := ORD(str[n + 1]);
478 IF x >= ORD("a") THEN DEC(x, ORD("a") - 10)
479 ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10)
480 ELSE DEC(x, ORD("0"))
481 END;
482 IF y >= ORD("a") THEN DEC(y, ORD("a") - 10)
483 ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10)
484 ELSE DEC(y, ORD("0"))
485 END;
486 DevCPM.ObjW(SHORT(CHR(x * 16 + y)))
487 END Copy;
489 BEGIN
490 IF bigEndian THEN
491 Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17)
492 ELSE
493 Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15)
494 END;
495 Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35)
496 END OutGuid;
498 PROCEDURE OutConst (obj: DevCPT.Object);
499 TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR;
500 VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER;
501 BEGIN
502 a := obj.conval; b := NIL;
503 WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END;
504 WHILE b # NIL DO
505 IF String8 IN b.setval THEN
506 DevCPM.ObjWBytes(b.ext^, b.intval2);
507 Align(4)
508 ELSIF String16 IN b.setval THEN
509 i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0;
510 Align(4)
511 ELSIF Real32 IN b.setval THEN
512 r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r);
513 IF DevCPM.LEHost = bigEndian THEN
514 ch := a4[0]; a4[0] := a4[3]; a4[3] := ch;
515 ch := a4[1]; a4[1] := a4[2]; a4[2] := ch
516 END;
517 DevCPM.ObjWBytes(a4, 4)
518 ELSIF Real64 IN b.setval THEN
519 a8 := SYSTEM.VAL(A8, b.realval);
520 IF DevCPM.LEHost = bigEndian THEN
521 ch := a8[0]; a8[0] := a8[7]; a8[7] := ch;
522 ch := a8[1]; a8[1] := a8[6]; a8[6] := ch;
523 ch := a8[2]; a8[2] := a8[5]; a8[5] := ch;
524 ch := a8[3]; a8[3] := a8[4]; a8[4] := ch
525 END;
526 DevCPM.ObjWBytes(a8, 8)
527 ELSIF Int64 IN b.setval THEN
528 (* intval moved to intval2 by AllocConst *)
529 x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x;
530 IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END
531 ELSIF Guid IN b.setval THEN
532 OutGuid(b.ext^)
533 END;
534 b := b.link
535 END
536 END OutConst;
538 PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN);
539 BEGIN
540 IF typ = NIL THEN Out4(0)
541 ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr)
542 ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec)
543 ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr)
544 ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid)
545 ELSIF typ = DevCPT.restyp THEN Out4(mResult)
546 ELSE
547 CASE typ.form OF
548 | Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0)
549 | Bool, Char8: Out4(typ.form - 1)
550 | Int8..Set: Out4(typ.form)
551 | Char16: Out4(mChar16)
552 | Int64: Out4(mInt64)
553 | ProcTyp: OutReference(TypeObj(typ), 0, absolute)
554 | Pointer:
555 IF typ.sysflag = interface THEN Out4(mInterface)
556 ELSIF typ.untagged THEN Out4(mSysPtr)
557 ELSE OutReference(TypeObj(typ), 0, absolute)
558 END
559 | Comp:
560 IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute)
561 ELSE Out4(0)
562 END
563 END
564 END
565 END OutStruct;
567 PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER;
568 VAR n: INTEGER;
569 BEGIN
570 n := 0;
571 IF obj.name # DevCPT.null THEN
572 IF obj.num = 0 THEN
573 obj.num := namex;
574 WHILE obj.name[n] # 0X DO INC(n) END;
575 INC(namex, n + 1);
576 obj.nlink := nameList; nameList := obj
577 END;
578 n := obj.num;
579 END;
580 RETURN n
581 END NameIdx;
583 PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER);
584 VAR p: DevCPT.Object; n, m: INTEGER;
585 BEGIN
586 pos := DevCPM.ObjLen() - headSize;
587 OutStruct(retTyp, TRUE);
588 p := par; n := 0;
589 WHILE p # NIL DO INC(n); p := p.link END;
590 Out4(n); p := par;
591 WHILE p # NIL DO
592 IF p.mode # VarPar THEN m := mValue
593 ELSIF p.vis = inPar THEN m := mInPar
594 ELSIF p.vis = outPar THEN m := mOutPar
595 ELSE m := mVarPar
596 END;
597 Out4(NameIdx(p) * 256 + m);
598 OutStruct(p.typ, TRUE);
599 p := p.link
600 END
601 END OutSignature;
603 PROCEDURE PrepObject (obj: DevCPT.Object);
604 BEGIN
605 IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN (* write param list *)
606 OutSignature(obj.link, obj.typ, obj.conval.intval)
607 END
608 END PrepObject;
610 PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object);
611 VAR vis: INTEGER;
612 BEGIN
613 Out4(fprint);
614 Out4(offs);
615 IF obj.vis = internal THEN vis := mInternal
616 ELSIF obj.vis = externalR THEN vis := mReadonly
617 ELSIF obj.vis = external THEN vis := mExported
618 END;
619 Out4(mode + vis * 16 + NameIdx(obj) * 256);
620 IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute) (* ref to par list *)
621 ELSE OutStruct(typ, mode = mField)
622 END
623 END OutObject;
625 PROCEDURE PrepDesc (desc: DevCPT.Struct);
626 VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct;
627 BEGIN
628 IF desc.comp = Record THEN (* write field list *)
629 desc.strobj.adr := DevCPM.ObjLen() - headSize;
630 n := 0; fld := desc.link;
631 WHILE (fld # NIL) & (fld.mode = Fld) DO
632 IF expAllFields OR (fld.vis # internal) THEN INC(n) END;
633 fld := fld.link
634 END;
635 Out4(n); fld := desc.link;
636 WHILE (fld # NIL) & (fld.mode = Fld) DO
637 IF expAllFields OR (fld.vis # internal) THEN
638 OutObject(mField, 0, fld.adr, fld.typ, fld)
639 END;
640 fld := fld.link
641 END
642 ELSIF (desc.form = ProcTyp) & outSignatures THEN (* write param list *)
643 OutSignature(desc.link, desc.BaseTyp, desc.n)
644 END;
645 (* assert name and base type are included *)
646 IF desc.untagged THEN n := NameIdx(untgd)
647 ELSE n := NameIdx(desc.strobj)
648 END;
649 IF desc.form # ProcTyp THEN b := desc.BaseTyp;
650 IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp, ProcTyp})
651 & (b.sysflag # interface) & (b # DevCPT.guidtyp)
652 & (~b.untagged OR outURef & (b.form = Comp)) THEN
653 l := OffsetLink(TypeObj(b), 0)
654 END
655 END
656 END PrepDesc;
658 PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object;
659 VAR obj: DevCPT.Object;
660 BEGIN
661 IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END;
662 obj := NumMeth(root.left, num);
663 IF obj = NIL THEN obj := NumMeth(root.right, num) END;
664 RETURN obj
665 END NumMeth;
667 PROCEDURE OutDesc (desc: DevCPT.Struct);
668 VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE;
669 name: DevCPT.Name;
670 BEGIN
671 ASSERT(~desc.untagged);
672 IF desc.comp = Record THEN
673 xb := desc; flddir := desc.strobj.adr;
674 REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged;
675 Out4(-1); i := desc.n;
676 WHILE i > 0 DO DEC(i); t := desc;
677 REPEAT
678 m := NumMeth(t.link, i); t := t.BaseTyp
679 UNTIL (m # NIL) OR (t = xb);
680 IF m # NIL THEN
681 IF absAttr IN m.conval.setval THEN Out4(0)
682 ELSE OutReference(m, 0, absolute)
683 END
684 ELSIF (xb = NIL) OR xb.untagged THEN Out4(0) (* unimplemented ANYREC method *)
685 ELSE OutReference(xb.strobj, -4 - 4 * i, copy)
686 END
687 END;
688 desc.strobj.adr := DevCPM.ObjLen() - headSize; (* desc adr *)
689 Out4(desc.size);
690 OutReference(Mod, 0, absolute);
691 IF desc.untagged THEN m := untgd ELSE m := desc.strobj END;
692 IF desc.attribute = extAttr THEN attr := 1
693 ELSIF desc.attribute = limAttr THEN attr := 2
694 ELSIF desc.attribute = absAttr THEN attr := 3
695 ELSE attr := 0
696 END;
697 Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0;
698 WHILE i <= desc.extlev DO
699 t := desc;
700 WHILE t.extlev > i DO t := t.BaseTyp END;
701 IF t.sysflag = interface THEN Out4(0)
702 ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute)
703 ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute)
704 ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute)
705 ELSE OutReference(xb.strobj, 12 + 4 * i, copy)
706 END;
707 INC(i)
708 END;
709 WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END;
710 OutReference(Meta, flddir, absolute); (* ref to field list *)
711 nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr);
712 Out4(-(4 * nofptr + 4));
713 nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr);
714 Out4(-1)
715 ELSE
716 desc.strobj.adr := DevCPM.ObjLen() - headSize;
717 lev := 0; size := 0;
718 IF desc.comp = Array THEN
719 size := desc.n; form := mArray
720 ELSIF desc.comp = DynArr THEN
721 form := mArray; lev := SHORT(SHORT(desc.n + 1))
722 ELSIF desc.form = Pointer THEN
723 form := mPointer
724 ELSE ASSERT(desc.form = ProcTyp);
725 DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp;
726 END;
727 Out4(size);
728 OutReference(Mod, 0, absolute);
729 IF desc.untagged THEN m := untgd ELSE m := desc.strobj END;
730 Out4(form + lev * 16 + NameIdx(m) * 256);
731 IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE)
732 ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute) (* ref to par list *)
733 END
734 END
735 END OutDesc;
737 PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER);
738 VAR i: INTEGER; t: Dates.Time; d: Dates.Date;
739 BEGIN
740 Out4(0); (* link *)
741 Out4(ORD(options)); (* opts *)
742 Out4(0); (* refcnt *)
743 Dates.GetDate(d); Dates.GetTime(t); (* compile time *)
744 Out2(d.year); Out2(d.month); Out2(d.day);
745 Out2(t.hour); Out2(t.minute); Out2(t.second);
746 Out4(0); Out4(0); Out4(0); (* load time *)
747 Out4(0); (* ext *)
748 IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute); (* terminator *)
749 ELSE Out4(0)
750 END;
751 Out4(imports); (* nofimps *)
752 Out4(nofptr); (* nofptrs *)
753 Out4(pc); (* csize *)
754 Out4(dsize); (* dsize *)
755 Out4(refSize); (* rsize *)
756 OutReference(Code, 0, absolute); (* code *)
757 OutReference(Data, 0, absolute); (* data *)
758 OutReference(Meta, 0, absolute); (* refs *)
759 IF procVarIndirect THEN
760 OutReference(Proc, 0, absolute); (* procBase *)
761 ELSE
762 OutReference(Code, 0, absolute); (* procBase *)
763 END;
764 OutReference(Data, 0, absolute); (* varBase *)
765 OutReference(Meta, namePos, absolute); (* names *)
766 OutReference(Meta, ptrPos, absolute); (* ptrs *)
767 OutReference(Meta, impPos, absolute); (* imports *)
768 OutReference(Meta, expPos, absolute); (* export *)
769 i := 0; (* name *)
770 WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END;
771 DevCPM.ObjW(0X);
772 Align(4)
773 END OutModDesc;
775 PROCEDURE OutProcTable (obj: DevCPT.Object); (* 68000 *)
776 BEGIN
777 IF obj # NIL THEN
778 OutProcTable(obj.left);
779 IF obj.mode IN {XProc, IProc} THEN
780 Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0);
781 END;
782 OutProcTable(obj.right);
783 END;
784 END OutProcTable;
786 PROCEDURE PrepExport (obj: DevCPT.Object);
787 BEGIN
788 IF obj # NIL THEN
789 PrepExport(obj.left);
790 IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN
791 PrepObject(obj)
792 END;
793 PrepExport(obj.right)
794 END
795 END PrepExport;
797 PROCEDURE OutExport (obj: DevCPT.Object);
798 VAR num: INTEGER;
799 BEGIN
800 IF obj # NIL THEN
801 OutExport(obj.left);
802 IF (obj.history # removed) & ((obj.vis # internal) OR
803 (obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN
804 DevCPT.FPrintObj(obj);
805 IF obj.mode IN {LProc, XProc, IProc} THEN
806 IF procVarIndirect THEN
807 ASSERT(obj.nlink = NIL);
808 num := obj.num; obj.num := 0;
809 OutObject(mProc, obj.fprint, num, NIL, obj);
810 obj.num := num
811 ELSE
812 OutObject(mProc, obj.fprint, obj.adr, NIL, obj)
813 END
814 ELSIF obj.mode = Var THEN
815 OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj)
816 ELSIF obj.mode = Typ THEN
817 OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj)
818 ELSE ASSERT(obj.mode IN {Con, CProc});
819 OutObject(mConst, obj.fprint, 0, NIL, obj)
820 END
821 END;
822 OutExport(obj.right)
823 END
824 END OutExport;
826 PROCEDURE OutCLinks (obj: DevCPT.Object);
827 BEGIN
828 IF obj # NIL THEN
829 OutCLinks(obj.left);
830 IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END;
831 OutCLinks(obj.right)
832 END
833 END OutCLinks;
835 PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER);
836 BEGIN
837 IF obj # NIL THEN
838 OutCPLinks(obj.left, base);
839 IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END;
840 OutCPLinks(obj.right, base)
841 END
842 END OutCPLinks;
844 PROCEDURE OutImport (obj: DevCPT.Object);
845 VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER;
846 BEGIN
847 IF obj # NIL THEN
848 OutImport(obj.left);
849 IF obj.mode = Typ THEN typ := obj.typ;
850 IF obj.used OR
851 (typ.form IN {Pointer, Comp}) & (typ.strobj = obj) &
852 ((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN
853 DevCPT.FPrintStr(typ);
854 DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^);
855 IF obj.used THEN opt := 2 ELSE opt := 0 END;
856 IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN
857 DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1)));
858 IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END
859 ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt)))
860 END;
861 OutLink(obj.links)
862 END
863 ELSIF obj.used THEN
864 DevCPT.FPrintObj(obj);
865 IF obj.mode = Var THEN
866 DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^);
867 DevCPM.ObjWNum(obj.fprint); OutLink(obj.links)
868 ELSIF obj.mode IN {XProc, IProc} THEN
869 DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^);
870 DevCPM.ObjWNum(obj.fprint); OutLink(obj.links)
871 ELSE ASSERT(obj.mode IN {Con, CProc});
872 DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint)
873 END
874 END;
875 OutImport(obj.right)
876 END
877 END OutImport;
879 PROCEDURE OutUseBlock;
880 VAR m, obj: DevCPT.Object; i: INTEGER;
881 BEGIN
882 m := dllList;
883 WHILE m # NIL DO
884 obj := m.nlink;
885 WHILE obj # NIL DO
886 IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar)))
887 ELSE DevCPM.ObjW(SHORT(CHR(mProc)))
888 END;
889 IF obj.entry # NIL THEN OutName(obj.entry^)
890 ELSE OutName(obj.name^);
891 END;
892 DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links);
893 obj := obj.nlink
894 END;
895 DevCPM.ObjW(0X); m := m.link
896 END;
897 i := 1;
898 WHILE i < DevCPT.nofGmod DO
899 obj := DevCPT.GlbMod[i];
900 IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END;
901 INC(i)
902 END;
903 END OutUseBlock;
905 PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String);
906 VAR name: DevCPT.String; dll: DevCPT.Object;
907 BEGIN
908 IF obj # NIL THEN
909 CollectDll(obj.left, mod);
910 IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN
911 IF obj.library # NIL THEN name := obj.library
912 ELSE name := mod
913 END;
914 dll := dllList;
915 WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END;
916 IF dll = NIL THEN
917 NEW(dll); dll.library := name; INC(imports);
918 IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END;
919 dllLast := dll; dll.left := dll;
920 END;
921 dll.left.nlink := obj; dll.left := obj
922 END;
923 CollectDll(obj.right, mod)
924 END
925 END CollectDll;
927 PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER);
928 BEGIN
929 IF obj # NIL THEN
930 EnumXProc(obj.left, num);
931 IF obj.mode IN {XProc, IProc} THEN
932 obj.num := num; INC(num, 8);
933 END;
934 EnumXProc(obj.right, num)
935 END;
936 END EnumXProc;
938 PROCEDURE OutHeader*;
939 VAR i: INTEGER; m: DevCPT.Object;
940 BEGIN
941 DevCPM.ObjWLInt(processor); (* processor type *)
942 DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0);
943 DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); (* sizes *)
944 imports := 0; i := 1;
945 WHILE i < DevCPT.nofGmod DO
946 m := DevCPT.GlbMod[i];
947 IF m.library # NIL THEN (* dll import *)
948 CollectDll(m.right, m.library);
949 ELSE INC(imports) (* module import *)
950 END;
951 INC(i)
952 END;
953 DevCPM.ObjWNum(imports); (* num of import *)
954 OutName(DevCPT.SelfName);
955 m := dllList;
956 WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END;
957 i := 1;
958 WHILE i < DevCPT.nofGmod DO
959 m := DevCPT.GlbMod[i];
960 IF m.library = NIL THEN OutName(m.name^) END;
961 INC(i)
962 END;
963 Align(16); headSize := DevCPM.ObjLen();
964 IF procVarIndirect THEN
965 i := 0; EnumXProc(DevCPT.topScope.right, i)
966 END
967 END OutHeader;
969 PROCEDURE OutCode*;
970 VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos,
971 con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER;
972 m, obj, dlist: DevCPT.Object;
973 BEGIN
974 (* Ref *)
975 DevCPM.ObjW(0X); (* end mark *)
976 refSize := DevCPM.ObjLen() - headSize;
977 (* Export *)
978 Align(4);
979 IF outSignatures THEN PrepExport(DevCPT.topScope.right) END; (* procedure signatures *)
980 Align(8); expPos := DevCPM.ObjLen();
981 Out4(0);
982 OutExport(DevCPT.topScope.right); (* export objects *)
983 i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i);
984 (* Pointers *)
985 ptrPos := DevCPM.ObjLen();
986 obj := DevCPT.topScope.scope; nofptrs := 0;
987 WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END;
988 obj := DevCPT.topScope.scope; i := 0;
989 WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END;
990 IF i > 0 THEN Out4(-1); INCL(options, iptrs) END;
991 (* Prepare Type Descriptors *)
992 dlist := NIL;
993 WHILE descList # NIL DO
994 obj := descList; descList := descList.link;
995 PrepDesc(obj.typ);
996 obj.link := dlist; dlist := obj
997 END;
998 (* Import List *)
999 impPos := DevCPM.ObjLen(); i := 0;
1000 WHILE i < imports DO Out4(0); INC(i) END;
1001 (* Names *)
1002 namePos := DevCPM.ObjLen(); OutNames;
1003 (* Const *)
1004 Align(4); con8Pos := DevCPM.ObjLen();
1005 OutConst(Const8); con16Pos := DevCPM.ObjLen();
1006 ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8);
1007 OutConst(Const16); con32Pos := DevCPM.ObjLen();
1008 ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16);
1009 OutConst(Const32); con64Pos := DevCPM.ObjLen();
1010 ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32);
1011 IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END;
1012 OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64);
1013 (* Module Descriptor *)
1014 Align(16); modPos := DevCPM.ObjLen();
1015 OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize);
1016 (* Procedure Table *)
1017 procPos := DevCPM.ObjLen();
1018 OutProcTable(DevCPT.topScope.right);
1019 Out4(0); Out4(0); (* at least one entry in ProcTable *)
1020 Out4(0); (* sentinel *)
1021 (* Type Descriptors *)
1022 obj := dlist;
1023 WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END;
1024 (* Code *)
1025 codePos := DevCPM.ObjLen(); WriteCode;
1026 WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END;
1027 (* Fixups *)
1028 OutLink(KNewRec.links); OutLink(KNewArr.links);
1029 (* metalink *)
1030 OutPLink(Const8.links, con8Pos - headSize);
1031 OutPLink(Const16.links, con16Pos - headSize);
1032 OutPLink(Const32.links, con32Pos - headSize);
1033 OutPLink(Const64.links, con64Pos - headSize);
1034 OutLink(Meta.links);
1035 (* desclink *)
1036 obj := dlist; i := modPos - headSize;
1037 WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END;
1038 IF procVarIndirect THEN
1039 OutPLink(Proc.links, procPos - modPos);
1040 OutCPLinks(DevCPT.topScope.right, procPos - modPos)
1041 END;
1042 OutLink(Mod.links);
1043 (* codelink *)
1044 IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END;
1045 OutPLink(CaseLinks, 0); OutLink(Code.links);
1046 (* datalink *)
1047 OutLink(Data.links);
1048 (* Use *)
1049 OutUseBlock;
1050 (* Header Fixups *)
1051 DevCPM.ObjSet(8);
1052 DevCPM.ObjWLInt(headSize);
1053 DevCPM.ObjWLInt(modPos - headSize);
1054 DevCPM.ObjWLInt(codePos - modPos);
1055 DevCPM.ObjWLInt(pc);
1056 DevCPM.ObjWLInt(dsize);
1057 IF namex > MaxNameTab THEN DevCPM.err(242) END;
1058 IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END
1059 END OutCode;
1061 PROCEDURE Init* (proc: INTEGER; opt: SET);
1062 CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14;
1063 BEGIN
1064 processor := proc;
1065 bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt;
1066 outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt;
1067 outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options);
1068 outSrc := srcpos IN opt;
1069 pc := 0; actIdx := CodeLength; blkIdx := 0;
1070 idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1;
1071 options := opt * {0..15}; CodeOvF := FALSE;
1072 KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL;
1073 Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL;
1074 Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL;
1075 Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL;
1076 nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL;
1077 codePos := 0; srcPos := 0;
1078 NEW(untgd); untgd.name := DevCPT.NewName("!");
1079 closeLbl := 0
1080 END Init;
1082 PROCEDURE Close*;
1083 BEGIN
1084 KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL;
1085 Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL;
1086 Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL;
1087 Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL;
1088 nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL;
1089 WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END;
1090 actual := NIL; untgd := NIL;
1091 END Close;
1093 BEGIN
1094 NEW(KNewRec); KNewRec.mnolev := -128;
1095 NEW(KNewArr); KNewArr.mnolev := -128;
1096 NEW(Const8); Const8.mode := Con; Const8.mnolev := 0;
1097 NEW(Const16); Const16.mode := Con; Const16.mnolev := 0;
1098 NEW(Const32); Const32.mode := Con; Const32.mnolev := 0;
1099 NEW(Const64); Const64.mode := Con; Const64.mnolev := 0;
1100 NEW(Code); Code.mode := Con; Code.mnolev := 0;
1101 NEW(Data); Data.mode := Con; Data.mnolev := 0;
1102 NEW(Mod); Mod.mode := Con; Mod.mnolev := 0;
1103 NEW(Proc); Proc.mode := Con; Proc.mnolev := 0;
1104 NEW(Meta); Meta.mode := Con; Mod.mnolev := 0;
1105 END DevCPE.