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