96851ea9f94c00e66861d766eb885735bb1a48be
1 MODULE DevCPV486;
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPV486.odc *)
4 (* DO NOT EDIT *)
6 IMPORT SYSTEM, DevCPM, DevCPT, DevCPE, DevCPH, DevCPL486, DevCPC486;
8 CONST
9 processor* = 10; (* for i386 *)
11 (* object modes *)
12 Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
13 SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
15 (* item modes for i386 *)
16 Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
18 (* symbol values and ops *)
19 times = 1; slash = 2; div = 3; mod = 4;
20 and = 5; plus = 6; minus = 7; or = 8; eql = 9;
21 neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
22 in = 15; is = 16; ash = 17; msk = 18; len = 19;
23 conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
24 (*SYSTEM*)
25 adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
26 min = 34; max = 35; typfn = 36;
27 thisrecfn = 45; thisarrfn = 46;
28 shl = 50; shr = 51; lshr = 52; xor = 53;
30 (* structure forms *)
31 Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
32 Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
33 Pointer = 13; ProcTyp = 14; Comp = 15;
34 Char16 = 16; String16 = 17; Int64 = 18;
35 VString16to8 = 29; VString8 = 30; VString16 = 31;
36 realSet = {Real32, Real64};
38 (* composite structure forms *)
39 Basic = 1; Array = 2; DynArr = 3; Record = 4;
41 (* nodes classes *)
42 Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
43 Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
44 Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
45 Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
46 Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30;
47 Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55;
49 (*function number*)
50 assign = 0; newfn = 1; incfn = 13; decfn = 14;
51 inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32;
53 (*SYSTEM function number*)
54 getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31;
56 (* COM function number *)
57 validfn = 40; queryfn = 42;
59 (* procedure flags (conval.setval) *)
60 hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isHidden = 29; isGuarded = 30; isCallback = 31;
62 (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
63 newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
65 (* case statement flags (conval.setval) *)
66 useTable = 1; useTree = 2;
68 (* registers *)
69 AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
70 stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; loaded = 24;
71 wreg = {AX, BX, CX, DX, SI, DI};
73 (* module visibility of objects *)
74 internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
76 (* sysflag *)
77 untagged = 1; noAlign = 3; align2 = 4; align8 = 6; union = 7;
78 interface = 10; guarded = 8; noframe = 16;
79 nilBit = 1; enumBits = 8; new = 1; iid = 2;
80 stackArray = 120;
82 (* system trap numbers *)
83 withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
84 recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
86 ParOff = 8;
87 interfaceSize = 16; (* SIZE(Kernel.Interface) *)
88 addRefFP = 4E27A847H; (* fingerprint of AddRef and Release procedures *)
89 intHandlerFP = 24B0EAE3H; (* fingerprint of InterfaceTrapHandler *)
90 numPreIntProc = 2;
93 VAR
94 Exit, Return: DevCPL486.Label;
95 assert, sequential: BOOLEAN;
96 nesting, actual: INTEGER;
97 query, addRef, release, release2: DevCPT.Object;
99 PROCEDURE Init*(opt: SET);
100 CONST ass = 2;
101 BEGIN
102 DevCPL486.Init(opt); DevCPC486.Init(opt);
103 assert := ass IN opt;
104 DevCPM.breakpc := MAX(INTEGER);
105 query := NIL; addRef := NIL; release := NIL; release2 := NIL; DevCPC486.intHandler := NIL;
106 END Init;
108 PROCEDURE Close*;
109 BEGIN
110 DevCPL486.Close
111 END Close;
113 PROCEDURE Align(VAR offset: INTEGER; align: INTEGER);
114 BEGIN
115 CASE align OF
116 1: (* ok *)
117 | 2: INC(offset, offset MOD 2)
118 | 4: INC(offset, (-offset) MOD 4)
119 | 8: INC(offset, (-offset) MOD 8)
120 END
121 END Align;
123 PROCEDURE NegAlign(VAR offset: INTEGER; align: INTEGER);
124 BEGIN
125 CASE align OF
126 1: (* ok *)
127 | 2: DEC(offset, offset MOD 2)
128 | 4: DEC(offset, offset MOD 4)
129 | 8: DEC(offset, offset MOD 8)
130 END
131 END NegAlign;
133 PROCEDURE Base(typ: DevCPT.Struct; limit: INTEGER): INTEGER; (* typ.comp # DynArr *)
134 VAR align: INTEGER;
135 BEGIN
136 WHILE typ.comp = Array DO typ := typ.BaseTyp END ;
137 IF typ.comp = Record THEN
138 align := typ.align
139 ELSE
140 align := typ.size;
141 END;
142 IF align > limit THEN RETURN limit ELSE RETURN align END
143 END Base;
145 (* -----------------------------------------------------
146 reference implementation of TypeSize for portable symbol files
147 mandatory for all non-system structures
149 PROCEDURE TypeSize (typ: DevCPT.Struct);
150 VAR f, c: SHORTINT; offset: LONGINT; fld: DevCPT.Object; btyp: DevCPT.Struct;
151 BEGIN
152 IF typ.size = -1 THEN
153 f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
154 IF c = Record THEN
155 IF btyp = NIL THEN offset := 0 ELSE TypeSize(btyp); offset := btyp.size END;
156 fld := typ.link;
157 WHILE (fld # NIL) & (fld.mode = Fld) DO
158 btyp := fld.typ; TypeSize(btyp);
159 IF btyp.size >= 4 THEN INC(offset, (-offset) MOD 4)
160 ELSIF btyp.size >= 2 THEN INC(offset, offset MOD 2)
161 END;
162 fld.adr := offset; INC(offset, btyp.size);
163 fld := fld.link
164 END;
165 IF offset > 2 THEN INC(offset, (-offset) MOD 4) END;
166 typ.size := offset; typ.align := 4;
167 typ.n := -1 (* methods not counted yet *)
168 ELSIF c = Array THEN
169 TypeSize(btyp);
170 typ.size := typ.n * btyp.size
171 ELSIF f = Pointer THEN
172 typ.size := DevCPM.PointerSize
173 ELSIF f = ProcTyp THEN
174 typ.size := DevCPM.ProcSize
175 ELSE (* c = DynArr *)
176 TypeSize(btyp);
177 IF btyp.comp = DynArr THEN typ.size := btyp.size + 4
178 ELSE typ.size := 8
179 END
180 END
181 END
182 END TypeSize;
184 ----------------------------------------------------- *)
186 PROCEDURE GTypeSize (typ: DevCPT.Struct; guarded: BOOLEAN);
187 VAR f, c: BYTE; offset, align, falign, alignLimit: INTEGER;
188 fld: DevCPT.Object; btyp: DevCPT.Struct; name: DevCPT.Name;
189 BEGIN
190 IF typ.untagged THEN guarded := TRUE END;
191 IF typ = DevCPT.undftyp THEN DevCPM.err(58)
192 ELSIF typ.size = -1 THEN
193 f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
194 IF c = Record THEN
195 IF btyp = NIL THEN offset := 0; align := 1;
196 ELSE GTypeSize(btyp, guarded); offset := btyp.size; align := btyp.align
197 END ;
198 IF typ.sysflag = noAlign THEN alignLimit := 1
199 ELSIF typ.sysflag = align2 THEN alignLimit := 2
200 ELSIF typ.sysflag = align8 THEN alignLimit := 8
201 ELSE alignLimit := 4
202 END;
203 fld := typ.link;
204 WHILE (fld # NIL) & (fld.mode = Fld) DO
205 btyp := fld.typ; GTypeSize(btyp, guarded);
206 IF typ.sysflag > 0 THEN falign := Base(btyp, alignLimit)
207 ELSIF btyp.size >= 4 THEN falign := 4
208 ELSIF btyp.size >= 2 THEN falign := 2
209 ELSE falign := 1
210 END;
211 IF typ.sysflag = union THEN
212 fld.adr := 0;
213 IF btyp.size > offset THEN offset := btyp.size END;
214 ELSE
215 Align(offset, falign);
216 fld.adr := offset;
217 IF offset <= MAX(INTEGER) - 4 - btyp.size THEN INC(offset, btyp.size)
218 ELSE offset := 4; DevCPM.Mark(214, typ.txtpos)
219 END
220 END;
221 IF falign > align THEN align := falign END ;
222 fld := fld.link
223 END;
224 (*
225 IF (typ.sysflag = interface) & (typ.BaseTyp = NIL) THEN
226 fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld;
227 fld.typ := DevCPT.undftyp; fld.adr := 8;
228 fld.right := typ.link; typ.link := fld;
229 fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld;
230 fld.typ := DevCPT.undftyp; fld.adr := 12;
231 typ.link.link := fld; typ.link.left := fld;
232 offset := interfaceSize; align := 4
233 END;
234 *)
235 IF typ.sysflag <= 0 THEN align := 4 END;
236 typ.align := align;
237 IF (typ.sysflag > 0) OR (offset > 2) THEN Align(offset, align) END;
238 typ.size := offset;
239 typ.n := -1 (* methods not counted yet *)
240 ELSIF c = Array THEN
241 GTypeSize(btyp, guarded);
242 IF (btyp.size = 0) OR (typ.n <= MAX(INTEGER) DIV btyp.size) THEN typ.size := typ.n * btyp.size
243 ELSE typ.size := 4; DevCPM.Mark(214, typ.txtpos)
244 END
245 ELSIF f = Pointer THEN
246 typ.size := DevCPM.PointerSize;
247 IF guarded & ~typ.untagged THEN DevCPM.Mark(143, typ.txtpos) END
248 ELSIF f = ProcTyp THEN
249 typ.size := DevCPM.ProcSize
250 ELSE (* c = DynArr *)
251 GTypeSize(btyp, guarded);
252 IF (typ.sysflag = untagged) OR typ.untagged THEN typ.size := 4
253 ELSE
254 IF btyp.comp = DynArr THEN typ.size := btyp.size + 4
255 ELSE typ.size := 8
256 END
257 END
258 END
259 END
260 END GTypeSize;
262 PROCEDURE TypeSize*(typ: DevCPT.Struct); (* also called from DevCPT.InStruct for arrays *)
263 BEGIN
264 GTypeSize(typ, FALSE)
265 END TypeSize;
267 PROCEDURE GetComKernel;
268 VAR name: DevCPT.Name; mod: DevCPT.Object;
269 BEGIN
270 IF addRef = NIL THEN
271 DevCPT.OpenScope(SHORT(SHORT(-DevCPT.nofGmod)), NIL);
272 DevCPT.topScope.name := DevCPT.NewName("$$");
273 name := "AddRef"; DevCPT.Insert(name, addRef);
274 addRef.mode := XProc;
275 addRef.fprint := addRefFP;
276 addRef.fpdone := TRUE;
277 name := "Release"; DevCPT.Insert(name, release);
278 release.mode := XProc;
279 release.fprint := addRefFP;
280 release.fpdone := TRUE;
281 name := "Release2"; DevCPT.Insert(name, release2);
282 release2.mode := XProc;
283 release2.fprint := addRefFP;
284 release2.fpdone := TRUE;
285 name := "InterfaceTrapHandler"; DevCPT.Insert(name, DevCPC486.intHandler);
286 DevCPC486.intHandler.mode := XProc;
287 DevCPC486.intHandler.fprint := intHandlerFP;
288 DevCPC486.intHandler.fpdone := TRUE;
289 DevCPT.GlbMod[DevCPT.nofGmod] := DevCPT.topScope;
290 INC(DevCPT.nofGmod);
291 DevCPT.CloseScope;
292 END
293 END GetComKernel;
295 PROCEDURE EnumTProcs(rec: DevCPT.Struct); (* method numbers in declaration order *)
296 VAR btyp: DevCPT.Struct; obj, redef: DevCPT.Object;
297 BEGIN
298 IF rec.n = -1 THEN
299 rec.n := 0; btyp := rec.BaseTyp;
300 IF btyp # NIL THEN
301 EnumTProcs(btyp); rec.n := btyp.n;
302 END;
303 obj := rec.strobj.link;
304 WHILE obj # NIL DO
305 DevCPT.FindBaseField(obj.name^, rec, redef);
306 IF redef # NIL THEN obj.num := redef.num (*mthno*);
307 IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN
308 DevCPM.Mark(119, rec.txtpos)
309 END
310 ELSE obj.num := rec.n; INC(rec.n)
311 END ;
312 IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END;
313 obj := obj.nlink
314 END
315 END
316 END EnumTProcs;
318 PROCEDURE CountTProcs(rec: DevCPT.Struct);
319 VAR btyp: DevCPT.Struct; comProc: INTEGER; m, rel: DevCPT.Object; name: DevCPT.Name;
321 PROCEDURE TProcs(obj: DevCPT.Object); (* obj.mnolev = 0, TProcs of base type already counted *)
322 VAR redef: DevCPT.Object;
323 BEGIN
324 IF obj # NIL THEN
325 TProcs(obj.left);
326 IF obj.mode = TProc THEN
327 DevCPT.FindBaseField(obj.name^, rec, redef);
328 (* obj.adr := 0 *)
329 IF redef # NIL THEN
330 obj.num := redef.num (*mthno*);
331 IF (redef.link # NIL) & (redef.link.typ.sysflag = interface) THEN
332 obj.num := numPreIntProc + comProc - 1 - obj.num
333 END;
334 IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN
335 DevCPM.Mark(119, rec.txtpos)
336 END
337 ELSE obj.num := rec.n; INC(rec.n)
338 END ;
339 IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END
340 END ;
341 TProcs(obj.right)
342 END
343 END TProcs;
345 BEGIN
346 IF rec.n = -1 THEN
347 comProc := 0;
348 IF rec.untagged THEN rec.n := 0 ELSE rec.n := DevCPT.anytyp.n END;
349 btyp := rec.BaseTyp;
350 IF btyp # NIL THEN
351 IF btyp.sysflag = interface THEN
352 EnumTProcs(btyp); rec.n := btyp.n + numPreIntProc; comProc := btyp.n;
353 ELSE
354 CountTProcs(btyp); rec.n := btyp.n
355 END
356 END;
357 WHILE (btyp # NIL) & (btyp # DevCPT.undftyp) & (btyp.sysflag # interface) DO btyp := btyp.BaseTyp END;
358 IF (btyp # NIL) & (btyp.sysflag = interface) THEN
359 IF comProc > 0 THEN
360 name := "QueryInterface"; DevCPT.FindField(name, rec, m);
361 IF m.link.typ.sysflag = interface THEN
362 DevCPT.InsertField(name, rec, m); m.mode := TProc; m.typ := rec;
363 m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, extAttr};
364 m.nlink := query; query := m
365 END;
366 name := "AddRef";
367 DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0;
368 m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr};
369 GetComKernel; addRef.used := TRUE; m.adr := -1; m.nlink := addRef;
370 END;
371 name := "RELEASE";
372 DevCPT.FindField(name, rec, rel);
373 IF (rel # NIL) & (rel.link.typ = DevCPT.anyptrtyp) THEN rel := NIL END;
374 IF (comProc > 0) OR (rel # NIL) THEN
375 name := "Release";
376 DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0;
377 m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr};
378 GetComKernel; m.adr := -1;
379 IF rel # NIL THEN release2.used := TRUE; m.nlink := release2
380 ELSE release.used := TRUE; m.nlink := release
381 END
382 END
383 END;
384 TProcs(rec.link);
385 END
386 END CountTProcs;
388 PROCEDURE ^Parameters(firstPar, proc: DevCPT.Object);
390 PROCEDURE ^TProcedures(obj: DevCPT.Object);
392 PROCEDURE TypeAlloc(typ: DevCPT.Struct);
393 VAR f, c: SHORTINT; fld: DevCPT.Object; btyp: DevCPT.Struct;
394 BEGIN
395 IF ~typ.allocated THEN (* not imported, not predefined, not allocated yet *)
396 typ.allocated := TRUE;
397 TypeSize(typ);
398 f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
399 IF c = Record THEN
400 IF typ.sysflag = interface THEN
401 EnumTProcs(typ);
402 ELSE
403 CountTProcs(typ)
404 END;
405 IF typ.extlev > 14 THEN DevCPM.Mark(233, typ.txtpos) END;
406 IF btyp # NIL THEN TypeAlloc(btyp) END;
407 IF ~typ.untagged THEN DevCPE.AllocTypDesc(typ) END;
408 fld := typ.link;
409 WHILE (fld # NIL) & (fld.mode = Fld) DO
410 TypeAlloc(fld.typ); fld := fld.link
411 END;
412 TProcedures(typ.link)
413 ELSIF f = Pointer THEN
414 IF btyp = DevCPT.undftyp THEN DevCPM.Mark(128, typ.txtpos)
415 ELSE TypeAlloc(btyp);
416 END
417 ELSIF f = ProcTyp THEN
418 TypeAlloc(btyp);
419 Parameters(typ.link, NIL)
420 ELSE (* c IN {Array, DynArr} *)
421 TypeAlloc(btyp);
422 IF (btyp.comp = DynArr) & btyp.untagged & ~typ.untagged THEN DevCPM.Mark(225, typ.txtpos) END;
423 END
424 END
425 END TypeAlloc;
427 PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER;
428 BEGIN
429 WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END;
430 IF typ # NIL THEN RETURN typ.n
431 ELSE RETURN 0
432 END
433 END NumOfIntProc;
435 PROCEDURE Parameters(firstPar, proc: DevCPT.Object);
436 (* firstPar.mnolev = 0 *)
437 VAR par: DevCPT.Object; typ: DevCPT.Struct; padr, vadr: INTEGER;
438 BEGIN
439 padr := ParOff; par := firstPar;
440 WHILE par # NIL DO
441 typ := par.typ; TypeAlloc(typ);
442 par.adr := padr;
443 IF (par.mode = VarPar) & (typ.comp # DynArr) THEN
444 IF (typ.comp = Record) & ~typ.untagged THEN INC(padr, 8)
445 ELSE INC(padr, 4)
446 END
447 ELSE
448 IF (par.mode = Var) & (typ.comp = DynArr) & typ.untagged THEN DevCPM.err(145) END;
449 INC(padr, typ.size); Align(padr, 4)
450 END;
451 par := par.link
452 END;
453 IF proc # NIL THEN
454 IF proc.mode = XProc THEN
455 INCL(proc.conval.setval, isCallback)
456 ELSIF (proc.mode = TProc)
457 & (proc.num >= numPreIntProc)
458 & (proc.num < numPreIntProc + NumOfIntProc(proc.link.typ))
459 THEN
460 INCL(proc.conval.setval, isCallback);
461 INCL(proc.conval.setval, isGuarded)
462 END;
463 IF proc.sysflag = guarded THEN INCL(proc.conval.setval, isGuarded) END;
464 IF isGuarded IN proc.conval.setval THEN
465 GetComKernel; vadr := -24
466 ELSE
467 vadr := 0;
468 IF imVar IN proc.conval.setval THEN DEC(vadr, 4) END;
469 IF isCallback IN proc.conval.setval THEN DEC(vadr, 8) END
470 END;
471 proc.conval.intval := padr; proc.conval.intval2 := vadr;
472 END
473 END Parameters;
475 PROCEDURE Variables(var: DevCPT.Object; VAR varSize: INTEGER);
476 (* allocates only offsets, regs allocated in DevCPC486.Enter *)
477 VAR adr: INTEGER; typ: DevCPT.Struct;
478 BEGIN
479 adr := varSize;
480 WHILE var # NIL DO
481 typ := var.typ; TypeAlloc(typ);
482 DEC(adr, typ.size); NegAlign(adr, Base(typ, 4));
483 var.adr := adr;
484 var := var.link
485 END;
486 NegAlign(adr, 4); varSize := adr
487 END Variables;
489 PROCEDURE ^Objects(obj: DevCPT.Object);
491 PROCEDURE Procedure(obj: DevCPT.Object);
492 (* obj.mnolev = 0 *)
493 VAR oldPos: INTEGER;
494 BEGIN
495 oldPos := DevCPM.errpos; DevCPM.errpos := obj.scope.adr;
496 TypeAlloc(obj.typ);
497 Parameters(obj.link, obj);
498 IF ~(hasBody IN obj.conval.setval) THEN DevCPM.Mark(129, obj.adr) END ;
499 Variables(obj.scope.scope, obj.conval.intval2); (* local variables *)
500 Objects(obj.scope.right);
501 DevCPM.errpos := oldPos
502 END Procedure;
504 PROCEDURE TProcedures(obj: DevCPT.Object);
505 (* obj.mnolev = 0 *)
506 VAR par: DevCPT.Object; psize: INTEGER;
507 BEGIN
508 IF obj # NIL THEN
509 TProcedures(obj.left);
510 IF (obj.mode = TProc) & (obj.scope # NIL) THEN
511 TypeAlloc(obj.typ);
512 Parameters(obj.link, obj);
513 Variables(obj.scope.scope, obj.conval.intval2); (* local variables *)
514 Objects(obj.scope.right);
515 END ;
516 TProcedures(obj.right)
517 END
518 END TProcedures;
520 PROCEDURE Objects(obj: DevCPT.Object);
521 BEGIN
522 IF obj # NIL THEN
523 Objects(obj.left);
524 IF obj.mode IN {Con, Typ, LProc, XProc, CProc, IProc} THEN
525 IF (obj.mode IN {Con, Typ}) THEN TypeAlloc(obj.typ);
526 ELSE Procedure(obj)
527 END
528 END ;
529 Objects(obj.right)
530 END
531 END Objects;
533 PROCEDURE Allocate*;
534 VAR gvarSize: INTEGER; name: DevCPT.Name;
535 BEGIN
536 DevCPM.errpos := DevCPT.topScope.adr; (* text position of scope used if error *)
537 gvarSize := 0;
538 Variables(DevCPT.topScope.scope, gvarSize); DevCPE.dsize := -gvarSize;
539 Objects(DevCPT.topScope.right)
540 END Allocate;
542 (************************)
544 PROCEDURE SameExp (n1, n2: DevCPT.Node): BOOLEAN;
545 BEGIN
546 WHILE (n1.class = n2.class) & (n1.typ = n2.typ) DO
547 CASE n1.class OF
548 | Nvar, Nvarpar, Nproc: RETURN n1.obj = n2.obj
549 | Nconst: RETURN (n1.typ.form IN {Int8..Int32}) & (n1.conval.intval = n2.conval.intval)
550 | Nfield: IF n1.obj # n2.obj THEN RETURN FALSE END
551 | Nderef, Nguard:
552 | Nindex: IF ~SameExp(n1.right, n2.right) THEN RETURN FALSE END
553 | Nmop: IF (n1.subcl # n2.subcl) OR (n1.subcl = is) THEN RETURN FALSE END
554 | Ndop: IF (n1.subcl # n2.subcl) OR ~SameExp(n1.right, n2.right) THEN RETURN FALSE END
555 ELSE RETURN FALSE
556 END ;
557 n1 := n1.left; n2 := n2.left
558 END;
559 RETURN FALSE
560 END SameExp;
562 PROCEDURE Check (n: DevCPT.Node; VAR used: SET; VAR size: INTEGER);
563 VAR ux, uy: SET; sx, sy, sf: INTEGER; f: BYTE;
564 BEGIN
565 used := {}; size := 0;
566 WHILE n # NIL DO
567 IF n.class # Ncomp THEN
568 Check(n.left, ux, sx);
569 Check(n.right, uy, sy)
570 END;
571 ux := ux + uy; sf := 0;
572 CASE n.class OF
573 | Nvar, Nvarpar:
574 IF (n.class = Nvarpar) OR (n.typ.comp = DynArr) OR
575 (n.obj.mnolev > 0) &
576 (DevCPC486.imLevel[n.obj.mnolev] < DevCPC486.imLevel[DevCPL486.level]) THEN sf := 1 END
577 | Nguard: sf := 2
578 | Neguard, Nderef: sf := 1
579 | Nindex:
580 IF (n.right.class # Nconst) OR (n.left.typ.comp = DynArr) THEN sf := 1 END;
581 IF sx > 0 THEN INC(sy) END
582 | Nmop:
583 CASE n.subcl OF
584 | is, adr, typfn, minus, abs, cap, val: sf := 1
585 | bit: sf := 2; INCL(ux, CX)
586 | conv:
587 IF n.typ.form = Int64 THEN sf := 2
588 ELSIF ~(n.typ.form IN realSet) THEN sf := 1;
589 IF n.left.typ.form IN realSet THEN INCL(ux, AX) END
590 END
591 | odd, cc, not:
592 END
593 | Ndop:
594 f := n.left.typ.form;
595 IF f # Bool THEN
596 CASE n.subcl OF
597 | times:
598 sf := 1;
599 IF f = Int8 THEN INCL(ux, AX) END
600 | div, mod:
601 sf := 3; INCL(ux, AX);
602 IF f > Int8 THEN INCL(ux, DX) END
603 | eql..geq:
604 IF f IN {String8, String16, Comp} THEN ux := ux + {AX, CX, SI, DI}; sf := 4
605 ELSIF f IN realSet THEN INCL(ux, AX); sf := 1
606 ELSE sf := 1
607 END
608 | ash, lsh, rot:
609 IF n.right.class = Nconst THEN sf := 1 ELSE sf := 2; INCL(ux, CX) END
610 | slash, plus, minus, msk, in, bit:
611 sf := 1
612 | len:
613 IF f IN {String8, String16} THEN ux := ux + {AX, CX, DI}; sf := 3
614 ELSE sf := 1
615 END
616 | min, max:
617 sf := 1;
618 IF f IN realSet THEN INCL(ux, AX) END
619 | queryfn:
620 ux := ux + {CX, SI, DI}; sf := 4
621 END;
622 IF sy > sx THEN INC(sx) ELSE INC(sy) END
623 END
624 | Nupto:
625 IF (n.right.class = Nconst) OR (n.left.class = Nconst) THEN sf := 2
626 ELSE sf := 3
627 END;
628 INCL(ux, CX); INC(sx)
629 | Ncall, Ncomp:
630 sf := 10; ux := wreg + {float}
631 | Nfield, Nconst, Nproc, Ntype:
632 END;
633 used := used + ux;
634 IF sx > size THEN size := sx END;
635 IF sy > size THEN size := sy END;
636 IF sf > size THEN size := sf END;
637 n := n.link
638 END;
639 IF size > 10 THEN size := 10 END
640 END Check;
642 PROCEDURE^ expr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
644 PROCEDURE DualExp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; hx, hy, stpx, stpy: SET);
645 VAR ux, uy: SET; sx, sy: INTEGER;
646 BEGIN
647 Check(left, ux, sx); Check(right, uy, sy);
648 IF sy > sx THEN
649 expr(right, y, hy + stpy, ux + stpy * {AX, CX});
650 expr(left, x, hx, stpx);
651 DevCPC486.Assert(y, hy, stpy)
652 ELSE
653 expr(left, x, hx + stpx, uy);
654 expr(right, y, hy, stpy);
655 DevCPC486.Assert(x, hx, stpx)
656 END;
657 END DualExp;
659 PROCEDURE IntDOp (n: DevCPT.Node; VAR x: DevCPL486.Item; hint: SET);
660 VAR y: DevCPL486.Item; rev: BOOLEAN;
661 BEGIN
662 DualExp(n.left, n.right, x, y, hint, hint, {stk}, {stk});
663 IF (x.mode = Reg) & DevCPC486.Fits(x, hint) THEN
664 DevCPC486.IntDOp(x, y, n.subcl, FALSE)
665 ELSIF (y.mode = Reg) & DevCPC486.Fits(y, hint) THEN
666 DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
667 ELSIF x.mode # Reg THEN
668 DevCPC486.Load(x, hint, {con}); DevCPC486.IntDOp(x, y, n.subcl, FALSE)
669 ELSIF y.mode # Reg THEN
670 DevCPC486.Load(y, hint, {con}); DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
671 ELSE
672 DevCPC486.IntDOp(x, y, n.subcl, FALSE)
673 END
674 END IntDOp;
676 PROCEDURE FloatDOp (n: DevCPT.Node; VAR x: DevCPL486.Item);
677 VAR y: DevCPL486.Item; ux, uy, uf: SET; sx, sy: INTEGER;
678 BEGIN
679 Check(n.left, ux, sx); Check(n.right, uy, sy);
680 IF (n.subcl = min) OR (n.subcl = max) THEN uf := {AX} ELSE uf := {} END;
681 IF (sy > sx) OR (sy = sx) & ((n.subcl = mod) OR (n.subcl = ash)) THEN
682 expr(n.right, x, {}, ux + {mem, stk});
683 expr(n.left, y, {}, uf);
684 DevCPC486.FloatDOp(x, y, n.subcl, TRUE)
685 ELSIF float IN uy THEN (* function calls in both operands *)
686 expr(n.left, y, {}, uy + {mem});
687 expr(n.right, x, {}, {mem, stk});
688 DevCPC486.FloatDOp(x, y, n.subcl, TRUE)
689 ELSE
690 expr(n.left, x, {}, uy + {mem, stk});
691 expr(n.right, y, {}, uf);
692 DevCPC486.FloatDOp(x, y, n.subcl, FALSE)
693 END
694 END FloatDOp;
696 PROCEDURE design (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
697 VAR obj: DevCPT.Object; y: DevCPL486.Item; ux, uy: SET; sx, sy: INTEGER;
698 BEGIN
699 CASE n.class OF
700 Nvar, Nvarpar:
701 obj := n.obj; x.mode := obj.mode; x.obj := obj; x.scale := 0;
702 IF obj.typ.comp = DynArr THEN x.mode := VarPar END;
703 IF obj.mnolev < 0 THEN x.offset := 0; x.tmode := Con
704 ELSIF x.mode = Var THEN x.offset := obj.adr; x.tmode := Con
705 ELSE x.offset := 0; x.tmode := VarPar
706 END
707 | Nfield:
708 design(n.left, x, hint, stop); DevCPC486.Field(x, n.obj)
709 | Nderef:
710 IF n.subcl # 0 THEN
711 expr(n.left, x, hint, stop);
712 IF n.typ.form = String8 THEN x.form := VString8 ELSE x.form := VString16 END
713 ELSE
714 expr(n.left, x, hint, stop + {mem} - {loaded}); DevCPC486.DeRef(x)
715 END
716 | Nindex:
717 Check(n.left, ux, sx); Check(n.right, uy, sy);
718 IF wreg - uy = {} THEN
719 expr(n.right, y, hint + stop, ux);
720 design(n.left, x, hint, stop);
721 IF x.scale # 0 THEN DevCPC486.Index(x, y, {}, {}) ELSE DevCPC486.Index(x, y, hint, stop) END
722 ELSE
723 design(n.left, x, hint, stop + uy);
724 IF x.scale # 0 THEN expr(n.right, y, {}, {}); DevCPC486.Index(x, y, {}, {})
725 ELSE expr(n.right, y, hint, stop); DevCPC486.Index(x, y, hint, stop)
726 END
727 END
728 | Nguard, Neguard:
729 IF n.typ.form = Pointer THEN
730 IF loaded IN stop THEN expr(n.left, x, hint, stop) ELSE expr(n.left, x, hint, stop + {mem}) END
731 ELSE design(n.left, x, hint, stop)
732 END;
733 DevCPC486.TypTest(x, n.typ, TRUE, n.class = Neguard)
734 | Nproc:
735 obj := n.obj; x.mode := obj.mode; x.obj := obj;
736 IF x.mode = TProc THEN x.offset := obj.num; (*mthno*) x.scale := n.subcl (* super *) END
737 END;
738 x.typ := n.typ
739 END design;
741 PROCEDURE IsAllocDynArr (x: DevCPT.Node): BOOLEAN;
742 BEGIN
743 IF (x.typ.comp = DynArr) & ~x.typ.untagged THEN
744 WHILE x.class = Nindex DO x := x.left END;
745 IF x.class = Nderef THEN RETURN TRUE END
746 END;
747 RETURN FALSE
748 END IsAllocDynArr;
750 PROCEDURE StringOp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; useLen: BOOLEAN);
751 VAR ax, ay: DevCPL486.Item; ux: SET; sx: INTEGER;
752 BEGIN
753 Check(left, ux, sx);
754 expr(right, y, wreg - {SI} + ux, {});
755 ay := y; DevCPC486.GetAdr(ay, wreg - {SI} + ux, {}); DevCPC486.Assert(ay, wreg - {SI}, ux);
756 IF useLen & IsAllocDynArr(left) THEN (* keep len descriptor *)
757 design(left, x, wreg - {CX}, {loaded});
758 DevCPC486.Prepare(x, wreg - {CX} + {deref}, {DI})
759 ELSE
760 expr(left, x, wreg - {DI}, {})
761 END;
762 ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI} + {stk, con});
763 DevCPC486.Load(ay, {}, wreg - {SI} + {con});
764 DevCPC486.Free(ax); DevCPC486.Free(ay)
765 END StringOp;
767 PROCEDURE AdrExpr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
768 BEGIN
769 IF n.class < Nconst THEN
770 design(n, x, hint + stop, {loaded}); DevCPC486.Prepare(x, hint + {deref}, stop)
771 ELSE expr(n, x, hint, stop)
772 END
773 END AdrExpr;
775 (* ---------- interface pointer reference counting ---------- *)
777 PROCEDURE HandleIPtrs (typ: DevCPT.Struct; VAR x, y: DevCPL486.Item; add, rel, init: BOOLEAN);
779 PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER);
780 VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
781 BEGIN
782 IF (typ.form = Pointer) & (typ.sysflag = interface) THEN
783 IF add THEN DevCPC486.IPAddRef(y, adr, TRUE) END;
784 IF rel THEN DevCPC486.IPRelease(x, adr, TRUE, init) END
785 ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
786 btyp := typ.BaseTyp;
787 IF btyp # NIL THEN FindPtrs(btyp, adr) END ;
788 fld := typ.link;
789 WHILE (fld # NIL) & (fld.mode = Fld) DO
790 IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) THEN
791 IF add THEN DevCPC486.IPAddRef(y, fld.adr + adr, TRUE) END;
792 IF rel THEN DevCPC486.IPRelease(x, fld.adr + adr, TRUE, init) END
793 ELSE FindPtrs(fld.typ, fld.adr + adr)
794 END;
795 fld := fld.link
796 END
797 ELSIF typ.comp = Array THEN
798 btyp := typ.BaseTyp; n := typ.n;
799 WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
800 IF DevCPC486.ContainsIPtrs(btyp) THEN
801 i := 0;
802 WHILE i < n DO FindPtrs(btyp, adr); INC(adr, btyp.size); INC(i) END
803 END
804 ELSIF typ.comp = DynArr THEN
805 IF DevCPC486.ContainsIPtrs(typ) THEN DevCPM.err(221) END
806 END
807 END FindPtrs;
809 BEGIN
810 FindPtrs(typ, 0)
811 END HandleIPtrs;
813 PROCEDURE CountedPtr (n: DevCPT.Node): BOOLEAN;
814 BEGIN
815 RETURN (n.typ.form = Pointer) & (n.typ.sysflag = interface)
816 & ((n.class = Ncall) OR (n.class = Ncomp) & (n.right.class = Ncall))
817 END CountedPtr;
819 PROCEDURE IPAssign (nx, ny: DevCPT.Node; VAR x, y: DevCPL486.Item; ux: SET);
820 (* nx.typ.form = Pointer & nx.typ.sysflag = interface *)
821 BEGIN
822 expr(ny, y, {}, wreg - {SI} + {mem, stk});
823 IF (ny.class # Nconst) & ~CountedPtr(ny) THEN
824 DevCPC486.IPAddRef(y, 0, TRUE)
825 END;
826 IF nx # NIL THEN
827 DevCPC486.Assert(y, {}, wreg - {SI} + ux);
828 expr(nx, x, wreg - {DI}, {loaded});
829 IF (x.mode = Ind) & (x.reg IN wreg - {SI, DI}) OR (x.scale # 0) THEN
830 DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
831 x.mode := Ind; x.offset := 0; x.scale := 0
832 END;
833 DevCPC486.IPRelease(x, 0, TRUE, FALSE);
834 END
835 END IPAssign;
837 PROCEDURE IPStructAssign (typ: DevCPT.Struct);
838 VAR x, y: DevCPL486.Item;
839 BEGIN
840 IF typ.comp = DynArr THEN DevCPM.err(270) END;
841 (* addresses in SI and DI *)
842 x.mode := Ind; x.reg := DI; x.offset := 0; x.scale := 0;
843 y.mode := Ind; y.reg := SI; y.offset := 0; y.scale := 0;
844 HandleIPtrs(typ, x, y, TRUE, TRUE, FALSE)
845 END IPStructAssign;
847 PROCEDURE IPFree (nx: DevCPT.Node; VAR x: DevCPL486.Item);
848 BEGIN
849 expr(nx, x, wreg - {DI}, {loaded}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
850 x.mode := Ind; x.offset := 0; x.scale := 0;
851 IF nx.typ.form = Comp THEN
852 HandleIPtrs(nx.typ, x, x, FALSE, TRUE, TRUE)
853 ELSE (* nx.typ.form = Pointer & nx.typ.sysflag = interface *)
854 DevCPC486.IPRelease(x, 0, TRUE, TRUE);
855 END
856 END IPFree;
858 (* unchanged val parameters allways counted because of aliasing problems REMOVED! *)
860 PROCEDURE InitializeIPVars (proc: DevCPT.Object);
861 VAR x: DevCPL486.Item; obj: DevCPT.Object;
862 BEGIN
863 x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer;
864 obj := proc.link;
865 WHILE obj # NIL DO
866 IF (obj.mode = Var) & obj.used THEN (* changed value parameters *)
867 x.offset := obj.adr;
868 HandleIPtrs(obj.typ, x, x, TRUE, FALSE, FALSE)
869 END;
870 obj := obj.link
871 END
872 END InitializeIPVars;
874 PROCEDURE ReleaseIPVars (proc: DevCPT.Object);
875 VAR x, ax, dx, si, di: DevCPL486.Item; obj: DevCPT.Object;
876 BEGIN
877 obj := proc.link;
878 WHILE (obj # NIL) & ((obj.mode # Var) OR ~obj.used OR ~DevCPC486.ContainsIPtrs(obj.typ)) DO
879 obj := obj.link
880 END;
881 IF obj = NIL THEN
882 obj := proc.scope.scope;
883 WHILE (obj # NIL) & ~DevCPC486.ContainsIPtrs(obj.typ) DO obj := obj.link END;
884 IF obj = NIL THEN RETURN END
885 END;
886 DevCPL486.MakeReg(ax, AX, Int32); DevCPL486.MakeReg(si, SI, Int32);
887 DevCPL486.MakeReg(dx, DX, Int32); DevCPL486.MakeReg(di, DI, Int32);
888 IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(ax, si) END;
889 IF proc.typ.form = Int64 THEN DevCPL486.GenMove(dx, di) END;
890 x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer;
891 obj := proc.link;
892 WHILE obj # NIL DO
893 IF (obj.mode = Var) & obj.used THEN (* value parameters *)
894 x.offset := obj.adr;
895 HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE)
896 END;
897 obj := obj.link
898 END;
899 obj := proc.scope.scope;
900 WHILE obj # NIL DO (* local variables *)
901 IF obj.used THEN
902 x.offset := obj.adr;
903 HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE);
904 END;
905 obj := obj.link
906 END;
907 IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(si, ax) END;
908 IF proc.typ.form = Int64 THEN DevCPL486.GenMove(di, dx) END
909 END ReleaseIPVars;
911 PROCEDURE CompareIntTypes (
912 typ: DevCPT.Struct; VAR id: DevCPL486.Item; VAR exit: DevCPL486.Label; VAR num: INTEGER
913 );
914 VAR x, y: DevCPL486.Item; local: DevCPL486.Label;
915 BEGIN
916 local := DevCPL486.NewLbl;
917 typ := typ.BaseTyp; num := 0;
918 WHILE (typ # NIL) & (typ # DevCPT.undftyp) DO
919 IF (typ.sysflag = interface) & (typ.ext # NIL) THEN
920 IF num > 0 THEN DevCPC486.JumpT(x, local) END;
921 DevCPC486.GuidFromString(typ.ext, y);
922 x := id; DevCPC486.GetAdr(x, wreg - {SI}, {mem});
923 x := y; DevCPC486.GetAdr(x, wreg - {DI}, {});
924 x := id; DevCPC486.CmpString(x, y, eql, FALSE);
925 INC(num)
926 END;
927 typ := typ.BaseTyp
928 END;
929 IF num > 0 THEN DevCPC486.JumpF(x, exit) END;
930 IF num > 1 THEN DevCPL486.SetLabel(local) END
931 END CompareIntTypes;
933 PROCEDURE InstallQueryInterface (typ: DevCPT.Struct; proc: DevCPT.Object);
934 VAR this, id, int, unk, c: DevCPL486.Item; nil, end: DevCPL486.Label; num: INTEGER;
935 BEGIN
936 nil := DevCPL486.NewLbl; end := DevCPL486.NewLbl;
937 this.mode := Ind; this.reg := BP; this.offset := 8; this.scale := 0; this.form := Pointer; this.typ := DevCPT.anyptrtyp;
938 id.mode := DInd; id.reg := BP; id.offset := 12; id.scale := 0; id.form := Pointer;
939 int.mode := DInd; int.reg := BP; int.offset := 16; int.scale := 0; int.form := Pointer;
940 DevCPC486.GetAdr(int, {}, {AX, CX, SI, DI, mem}); int.mode := Ind; int.offset := 0;
941 DevCPL486.MakeConst(c, 0, Pointer); DevCPC486.Assign(int, c);
942 unk.mode := Ind; unk.reg := BP; unk.offset := 8; unk.scale := 0; unk.form := Pointer; unk.typ := DevCPT.punktyp;
943 DevCPC486.Load(unk, {}, {});
944 unk.mode := Ind; unk.offset := 8;
945 DevCPC486.Load(unk, {}, {});
946 DevCPL486.GenComp(c, unk);
947 DevCPL486.GenJump(4, nil, TRUE);
948 DevCPL486.MakeReg(c, int.reg, Pointer);
949 DevCPL486.GenPush(c);
950 c.mode := Ind; c.reg := BP; c.offset := 12; c.scale := 0; c.form := Pointer;
951 DevCPL486.GenPush(c);
952 DevCPL486.GenPush(unk);
953 c.mode := Ind; c.reg := unk.reg; c.offset := 0; c.scale := 0; c.form := Pointer;
954 DevCPL486.GenMove(c, unk);
955 unk.mode := Ind; unk.offset := 0; unk.scale := 0; unk.form := Pointer;
956 DevCPL486.GenCall(unk);
957 DevCPC486.Free(unk);
958 DevCPL486.GenJump(-1, end, FALSE);
959 DevCPL486.SetLabel(nil);
960 DevCPL486.MakeConst(c, 80004002H, Int32); (* E_NOINTERFACE *)
961 DevCPC486.Result(proc, c);
962 CompareIntTypes(typ, id, end, num);
963 IF num > 0 THEN
964 DevCPC486.Load(this, {}, {});
965 DevCPC486.Assign(int, this);
966 DevCPC486.IPAddRef(this, 0, FALSE);
967 DevCPL486.MakeConst(c, 0, Int32); (* S_OK *)
968 DevCPC486.Result(proc, c);
969 END;
970 DevCPL486.SetLabel(end)
971 END InstallQueryInterface;
973 (* -------------------- *)
975 PROCEDURE ActualPar (n: DevCPT.Node; fp: DevCPT.Object; rec: BOOLEAN; VAR tag: DevCPL486.Item);
976 VAR ap: DevCPL486.Item; x: DevCPT.Node; niltest: BOOLEAN;
977 BEGIN
978 IF n # NIL THEN
979 ActualPar(n.link, fp.link, FALSE, ap);
980 niltest := FALSE;
981 IF fp.mode = VarPar THEN
982 IF (n.class = Ndop) & ((n.subcl = thisarrfn) OR (n.subcl = thisrecfn)) THEN
983 expr(n.right, ap, {}, {}); DevCPC486.Push(ap); (* push type/length *)
984 expr(n.left, ap, {}, {}); DevCPC486.Push(ap); (* push adr *)
985 RETURN
986 ELSIF (fp.vis = outPar) & DevCPC486.ContainsIPtrs(fp.typ) & (ap.typ # DevCPT.niltyp) THEN
987 IPFree(n, ap)
988 ELSE
989 x := n;
990 WHILE (x.class = Nfield) OR (x.class = Nindex) DO x := x.left END;
991 niltest := x.class = Nderef; (* explicit nil test needed *)
992 AdrExpr(n, ap, {}, {})
993 END
994 ELSIF (n.class = Nmop) & (n.subcl = conv) THEN
995 IF n.typ.form IN {String8, String16} THEN expr(n, ap, {}, {}); DevCPM.err(265)
996 ELSIF (DevCPT.Includes(n.typ.form, n.left.typ.form) OR DevCPT.Includes(n.typ.form, fp.typ.form))
997 & (n.typ.form # Set) & (fp.typ # DevCPT.bytetyp) THEN expr(n.left, ap, {}, {high});
998 ELSE expr(n, ap, {}, {high});
999 END
1000 ELSE expr(n, ap, {}, {high});
1001 IF CountedPtr(n) THEN DevCPM.err(270) END
1002 END;
1003 DevCPC486.Param(fp, rec, niltest, ap, tag)
1004 END
1005 END ActualPar;
1007 PROCEDURE Call (n: DevCPT.Node; VAR x: DevCPL486.Item);
1008 VAR tag: DevCPL486.Item; proc: DevCPT.Object; m: BYTE;
1009 BEGIN
1010 IF n.left.class = Nproc THEN
1011 proc := n.left.obj; m := proc.mode;
1012 ELSE proc := NIL; m := 0
1013 END;
1014 IF (m = CProc) & (n.right # NIL) THEN
1015 ActualPar(n.right.link, n.obj.link, FALSE, tag);
1016 expr(n.right, tag, wreg - {AX}, {}); (* tag = first param *)
1017 ELSE
1018 IF proc # NIL THEN DevCPC486.PrepCall(proc) END;
1019 ActualPar(n.right, n.obj, (m = TProc) & (n.left.subcl = 0), tag);
1020 END;
1021 IF proc # NIL THEN design(n.left, x, {}, {}) ELSE expr(n.left, x, {}, {}) END;
1022 DevCPC486.Call(x, tag)
1023 END Call;
1025 PROCEDURE Mem (n: DevCPT.Node; VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET);
1026 VAR offset: INTEGER;
1027 BEGIN
1028 IF (n.class = Ndop) & (n.subcl IN {plus, minus}) & (n.right.class = Nconst) THEN
1029 expr(n.left, x, hint, stop + {mem}); offset := n.right.conval.intval;
1030 IF n.subcl = minus THEN offset := -offset END
1031 ELSE
1032 expr(n, x, hint, stop + {mem}); offset := 0
1033 END;
1034 DevCPC486.Mem(x, offset, typ)
1035 END Mem;
1037 PROCEDURE^ CompStat (n: DevCPT.Node);
1038 PROCEDURE^ CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item);
1040 PROCEDURE condition (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR false, true: DevCPL486.Label);
1041 VAR local: DevCPL486.Label; y, z: DevCPL486.Item; ux: SET; sx, num: INTEGER; f: BYTE; typ: DevCPT.Struct;
1042 BEGIN
1043 IF n.class = Nmop THEN
1044 CASE n.subcl OF
1045 not: condition(n.left, x, true, false); DevCPC486.Not(x)
1046 | is: IF n.left.typ.form = Pointer THEN expr(n.left, x, {}, {mem})
1047 ELSE design(n.left, x, {}, {})
1048 END;
1049 DevCPC486.TypTest(x, n.obj.typ, FALSE, FALSE)
1050 | odd: expr(n.left, x, {}, {}); DevCPC486.Odd(x)
1051 | cc: expr(n.left, x, {}, {}); x.mode := Cond; x.form := Bool
1052 | val: DevCPM.err(220)
1053 END
1054 ELSIF n.class = Ndop THEN
1055 CASE n.subcl OF
1056 and: local := DevCPL486.NewLbl; condition(n.left, y, false, local);
1057 DevCPC486.JumpF(y, false);
1058 IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
1059 condition(n.right, x, false, true)
1060 | or: local := DevCPL486.NewLbl; condition(n.left, y, local, true);
1061 DevCPC486.JumpT(y, true);
1062 IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
1063 condition(n.right, x, false, true)
1064 | eql..geq:
1065 f := n.left.typ.form;
1066 IF f = Int64 THEN DevCPM.err(260)
1067 ELSIF f IN {String8, String16, Comp} THEN
1068 IF (n.left.class = Nmop) & (n.left.subcl = conv) THEN (* converted must be source *)
1069 StringOp(n.right, n.left, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, TRUE)
1070 ELSE
1071 StringOp(n.left, n.right, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, FALSE)
1072 END
1073 ELSIF f IN {Real32, Real64} THEN FloatDOp(n, x)
1074 ELSE
1075 IF CountedPtr(n.left) OR CountedPtr(n.right) THEN DevCPM.err(270) END;
1076 DualExp(n.left, n.right, x, y, {}, {}, {stk}, {stk});
1077 IF (x.mode = Reg) OR (y.mode = Con) THEN DevCPC486.IntDOp(x, y, n.subcl, FALSE)
1078 ELSIF (y.mode = Reg) OR (x.mode = Con) THEN DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
1079 ELSE DevCPC486.Load(x, {}, {}); DevCPC486.IntDOp(x, y, n.subcl, FALSE)
1080 END
1081 END
1082 | in: DualExp(n.left, n.right, x, y, {}, {}, {short, mem, stk}, {con, stk});
1083 DevCPC486.In(x, y)
1084 | bit: Check(n.left, ux, sx);
1085 expr(n.right, x, {}, ux + {short});
1086 Mem(n.left, y, DevCPT.notyp, {}, {});
1087 DevCPC486.Load(x, {}, {short});
1088 DevCPC486.In(x, y)
1089 | queryfn:
1090 AdrExpr(n.right, x, {}, {CX, SI, DI});
1091 CompareIntTypes(n.left.typ, x, false, num);
1092 IF num > 0 THEN
1093 Check(n.right.link, ux, sx); IPAssign(n.right.link, n.left, x, y, ux); DevCPC486.Assign(x, y);
1094 x.offset := 1 (* true *)
1095 ELSE x.offset := 0 (* false *)
1096 END;
1097 x.mode := Con; DevCPC486.MakeCond(x)
1098 END
1099 ELSIF n.class = Ncomp THEN
1100 CompStat(n.left); condition(n.right, x, false, true); CompRelease(n.left, x);
1101 IF x.mode = Stk THEN DevCPL486.GenCode(9DH); (* pop flags *) x.mode := Cond END
1102 ELSE expr(n, x, {}, {}); DevCPC486.MakeCond(x) (* const, var, or call *)
1103 END
1104 END condition;
1106 PROCEDURE expr(n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
1107 VAR y, z: DevCPL486.Item; f, g: BYTE; cval: DevCPT.Const; false, true: DevCPL486.Label;
1108 uy: SET; sy: INTEGER; r: REAL;
1109 BEGIN
1110 f := n.typ.form;
1111 IF (f = Bool) & (n.class IN {Ndop, Nmop}) THEN
1112 false := DevCPL486.NewLbl; true := DevCPL486.NewLbl;
1113 condition(n, y, false, true);
1114 DevCPC486.LoadCond(x, y, false, true, hint, stop + {mem})
1115 ELSE
1116 CASE n.class OF
1117 Nconst:
1118 IF n.obj = NIL THEN cval := n.conval ELSE cval := n.obj.conval END;
1119 CASE f OF
1120 Byte..Int32, NilTyp, Pointer, Char16: DevCPL486.MakeConst(x, cval.intval, f)
1121 | Int64:
1122 DevCPL486.MakeConst(x, cval.intval, f);
1123 DevCPE.GetLongWords(cval, x.scale, x.offset)
1124 | Set: DevCPL486.MakeConst(x, SYSTEM.VAL(INTEGER, cval.setval), Set)
1125 | String8, String16, Real32, Real64: DevCPL486.AllocConst(x, cval, f)
1126 | Comp:
1127 ASSERT(n.typ = DevCPT.guidtyp);
1128 IF n.conval # NIL THEN DevCPC486.GuidFromString(n.conval.ext, x)
1129 ELSE DevCPC486.GuidFromString(n.obj.typ.ext, x)
1130 END
1131 END
1132 | Nupto: (* n.typ = DevCPT.settyp *)
1133 Check(n.right, uy, sy);
1134 expr(n.left, x, {}, wreg - {CX} + {high, mem, stk});
1135 DevCPC486.MakeSet(x, TRUE, FALSE, hint + stop + uy, {});
1136 DevCPC486.Assert(x, {}, uy);
1137 expr(n.right, y, {}, wreg - {CX} + {high, mem, stk});
1138 DevCPC486.MakeSet(y, TRUE, TRUE, hint + stop, {});
1139 DevCPC486.Load(x, hint + stop, {});
1140 IF x.mode = Con THEN DevCPC486.IntDOp(y, x, msk, TRUE); x := y
1141 ELSE DevCPC486.IntDOp(x, y, msk, FALSE)
1142 END
1143 | Nmop:
1144 CASE n.subcl OF
1145 | bit:
1146 expr(n.left, x, {}, wreg - {CX} + {high, mem, stk});
1147 DevCPC486.MakeSet(x, FALSE, FALSE, hint + stop, {})
1148 | conv:
1149 IF f IN {String8, String16} THEN
1150 expr(n.left, x, hint, stop);
1151 IF f = String8 THEN x.form := VString16to8 END (* SHORT *)
1152 ELSE
1153 IF n.left.class = Nconst THEN (* largeint -> longreal *)
1154 ASSERT((n.left.typ.form = Int64) & (f = Real64));
1155 DevCPL486.AllocConst(x, n.left.conval, n.left.typ.form);
1156 ELSE
1157 expr(n.left, x, hint + stop, {high});
1158 END;
1159 DevCPC486.Convert(x, f, -1, hint + stop, {}) (* ??? *)
1160 END
1161 | val:
1162 expr(n.left, x, hint + stop, {high, con}); DevCPC486.Convert(x, f, n.typ.size, hint, stop) (* ??? *)
1163 | adr:
1164 IF n.left.class = Ntype THEN
1165 x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ;
1166 ELSE
1167 AdrExpr(n.left, x, hint + stop, {});
1168 END;
1169 DevCPC486.GetAdr(x, hint + stop, {})
1170 | typfn:
1171 IF n.left.class = Ntype THEN
1172 x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ;
1173 IF x.obj.typ.untagged THEN DevCPM.err(111) END
1174 ELSE
1175 expr(n.left, x, hint + stop, {});
1176 DevCPC486.Tag(x, y); DevCPC486.Free(x); x := y
1177 END;
1178 DevCPC486.Load(x, hint + stop, {})
1179 | minus, abs, cap:
1180 expr(n.left, x, hint + stop, {mem, stk});
1181 IF f = Int64 THEN DevCPM.err(260)
1182 ELSIF f IN realSet THEN DevCPC486.FloatMOp(x, n.subcl)
1183 ELSE DevCPC486.IntMOp(x, n.subcl)
1184 END
1185 END
1186 | Ndop:
1187 IF (f IN realSet) & (n.subcl # lsh) & (n.subcl # rot) THEN
1188 IF (n.subcl = ash) & (n.right.class = Nconst) & (n.right.conval.realval >= 0) THEN
1189 expr(n.left, x, {}, {mem, stk});
1190 cval := n.right.conval; sy := SHORT(ENTIER(cval.realval)); cval.realval := 1;
1191 WHILE sy > 0 DO cval.realval := cval.realval * 2; DEC(sy) END;
1192 DevCPL486.AllocConst(y, cval, Real32);
1193 DevCPC486.FloatDOp(x, y, times, FALSE)
1194 ELSE FloatDOp(n, x)
1195 END
1196 ELSIF (f = Int64) OR (n.typ = DevCPT.intrealtyp) THEN DevCPM.err(260); expr(n.left, x, {}, {})
1197 ELSE
1198 CASE n.subcl OF
1199 times:
1200 IF f = Int8 THEN
1201 DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, con, stk});
1202 DevCPC486.IntDOp(x, y, times, FALSE)
1203 ELSE IntDOp(n, x, hint + stop)
1204 END
1205 | div, mod:
1206 DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, DX, mem, stk});
1207 DevCPC486.DivMod(x, y, n.subcl = mod)
1208 | plus:
1209 IF n.typ.form IN {String8, String16} THEN DevCPM.err(265); expr(n.left, x, {}, {})
1210 ELSE IntDOp(n, x, hint + stop)
1211 END
1212 | slash, minus, msk, min, max:
1213 IntDOp(n, x, hint + stop)
1214 | ash, lsh, rot:
1215 uy := {}; IF n.right.class # Nconst THEN uy := {CX} END;
1216 DualExp(n^.right, n^.left, y, x, {}, hint + stop, wreg - {CX} + {high, mem, stk}, uy + {con, mem, stk});
1217 DevCPC486.Shift(x, y, n^.subcl)
1218 | len:
1219 IF n.left.typ.form IN {String8, String16} THEN
1220 expr(n.left, x, wreg - {DI} , {}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
1221 DevCPC486.StrLen(x, n.left.typ, FALSE)
1222 ELSE
1223 design(n.left, x, hint + stop, {}); expr(n.right, y, {}, {}); DevCPC486.Len(x, y)
1224 END
1225 END
1226 END
1227 | Ncall:
1228 Call(n, x)
1229 | Ncomp:
1230 CompStat(n.left); expr(n.right, x, hint, stop); CompRelease(n.left, x);
1231 IF x.mode = Stk THEN DevCPC486.Pop(x, x.form, hint, stop) END
1232 ELSE
1233 design(n, x, hint + stop, stop * {loaded}); DevCPC486.Prepare(x, hint + stop, {}) (* ??? *)
1234 END
1235 END;
1236 x.typ := n.typ;
1237 DevCPC486.Assert(x, hint, stop)
1238 END expr;
1240 PROCEDURE AddCopy (n: DevCPT.Node; VAR dest, dadr, len: DevCPL486.Item; last: BOOLEAN);
1241 VAR adr, src: DevCPL486.Item; u: SET; s: INTEGER;
1242 BEGIN
1243 Check(n, u, s);
1244 DevCPC486.Assert(dadr, wreg - {DI}, u + {SI, CX});
1245 IF len.mode # Con THEN DevCPC486.Assert(len, wreg - {CX}, u + {SI, DI}) END;
1246 expr(n, src, wreg - {SI}, {});
1247 adr := src; DevCPC486.GetAdr(adr, {}, wreg - {SI} + {con});
1248 IF len.mode # Con THEN DevCPC486.Load(len, {}, wreg - {CX} + {con}) END;
1249 DevCPC486.Load(dadr, {}, wreg - {DI} + {con});
1250 DevCPC486.AddCopy(dest, src, last)
1251 END AddCopy;
1253 PROCEDURE StringCopy (left, right: DevCPT.Node);
1254 VAR x, y, ax, ay, len: DevCPL486.Item;
1255 BEGIN
1256 IF IsAllocDynArr(left) THEN expr(left, x, wreg - {CX}, {DI}) (* keep len descriptor *)
1257 ELSE expr(left, x, wreg - {DI}, {})
1258 END;
1259 ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI});
1260 DevCPC486.Free(x); DevCPC486.ArrayLen(x, len, wreg - {CX}, {});
1261 WHILE right.class = Ndop DO
1262 ASSERT(right.subcl = plus);
1263 AddCopy(right.left, x, ax, len, FALSE);
1264 right := right.right
1265 END;
1266 AddCopy(right, x, ax, len, TRUE);
1267 DevCPC486.Free(len)
1268 END StringCopy;
1270 PROCEDURE Checkpc;
1271 BEGIN
1272 DevCPE.OutSourceRef(DevCPM.errpos)
1273 END Checkpc;
1275 PROCEDURE^ stat (n: DevCPT.Node; VAR end: DevCPL486.Label);
1277 PROCEDURE CondStat (if, last: DevCPT.Node; VAR hint: INTEGER; VAR else, end: DevCPL486.Label);
1278 VAR local: DevCPL486.Label; x: DevCPL486.Item; cond, lcond: DevCPT.Node;
1279 BEGIN
1280 local := DevCPL486.NewLbl;
1281 DevCPM.errpos := if.conval.intval; Checkpc; cond := if.left;
1282 IF (last # NIL) & (cond.class = Ndop) & (cond.subcl >= eql) & (cond.subcl <= geq)
1283 & (last.class = Ndop) & (last.subcl >= eql) & (last.subcl <= geq)
1284 & SameExp(cond.left, last.left) & SameExp(cond.right, last.right) THEN (* reuse comparison *)
1285 DevCPC486.setCC(x, cond.subcl, ODD(hint), hint >= 2)
1286 ELSIF (last # NIL) & (cond.class = Nmop) & (cond.subcl = is) & (last.class = Nmop) & (last.subcl = is)
1287 & SameExp(cond.left, last.left) THEN
1288 DevCPC486.ShortTypTest(x, cond.obj.typ) (* !!! *)
1289 ELSE condition(cond, x, else, local)
1290 END;
1291 hint := x.reg;
1292 DevCPC486.JumpF(x, else);
1293 IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
1294 stat(if.right, end);
1295 END CondStat;
1297 PROCEDURE IfStat (n: DevCPT.Node; withtrap: BOOLEAN; VAR end: DevCPL486.Label);
1298 VAR else, local: DevCPL486.Label; if, last: DevCPT.Node; hint: INTEGER;
1299 BEGIN (* n.class = Nifelse *)
1300 if := n.left; last := NIL;
1301 WHILE (if # NIL) & ((if.link # NIL) OR (n.right # NIL) OR withtrap) DO
1302 else := DevCPL486.NewLbl;
1303 CondStat(if, last, hint, else, end);
1304 IF sequential THEN DevCPC486.Jump(end) END;
1305 DevCPL486.SetLabel(else); last := if.left; if := if.link
1306 END;
1307 IF n.right # NIL THEN stat(n.right, end)
1308 ELSIF withtrap THEN DevCPM.errpos := n.conval.intval; Checkpc; DevCPC486.Trap(withTrap); sequential := FALSE
1309 ELSE CondStat(if, last, hint, end, end)
1310 END
1311 END IfStat;
1313 PROCEDURE CasePart (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR else: DevCPL486.Label; last: BOOLEAN);
1314 VAR this, higher: DevCPL486.Label; m: DevCPT.Node; low, high: INTEGER;
1315 BEGIN
1316 IF n # NIL THEN
1317 this := SHORT(ENTIER(n.conval.realval));
1318 IF useTree IN n.conval.setval THEN
1319 IF n.left # NIL THEN
1320 IF n.right # NIL THEN
1321 higher := DevCPL486.NewLbl;
1322 DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, higher, TRUE, FALSE);
1323 CasePart(n.left, x, else, FALSE);
1324 DevCPL486.SetLabel(higher);
1325 CasePart(n.right, x, else, last)
1326 ELSE
1327 DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, FALSE);
1328 CasePart(n.left, x, else, last);
1329 END
1330 ELSE
1331 DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, TRUE);
1332 IF n.right # NIL THEN CasePart(n.right, x, else, last)
1333 ELSIF ~last THEN DevCPC486.Jump(else)
1334 END
1335 END
1336 ELSE
1337 IF useTable IN n.conval.setval THEN
1338 m := n; WHILE m.left # NIL DO m := m.left END; low := m.conval.intval;
1339 m := n; WHILE m.right # NIL DO m := m.right END; high := m.conval.intval2;
1340 DevCPC486.CaseTableJump(x, low, high, else);
1341 actual := low; last := TRUE
1342 END;
1343 CasePart(n.left, x, else, FALSE);
1344 WHILE actual < n.conval.intval DO
1345 DevCPL486.GenCaseEntry(else, FALSE); INC(actual)
1346 END;
1347 WHILE actual < n.conval.intval2 DO
1348 DevCPL486.GenCaseEntry(this, FALSE); INC(actual)
1349 END;
1350 DevCPL486.GenCaseEntry(this, last & (n.right = NIL)); INC(actual);
1351 CasePart(n.right, x, else, last)
1352 END;
1353 n.conval.realval := this
1354 END
1355 END CasePart;
1357 PROCEDURE CaseStat (n: DevCPT.Node; VAR end: DevCPL486.Label);
1358 VAR x: DevCPL486.Item; case, lab: DevCPT.Node; low, high, tab: INTEGER; else, this: DevCPL486.Label;
1359 BEGIN
1360 expr(n.left, x, {}, {mem, con, short, float, stk}); else := DevCPL486.NewLbl;
1361 IF (n.right.right # NIL) & (n.right.right.class = Ngoto) THEN (* jump to goto optimization *)
1362 CasePart(n.right.link, x, else, FALSE); DevCPC486.Free(x);
1363 n.right.right.right.conval.intval2 := else; sequential := FALSE
1364 ELSE
1365 CasePart(n.right.link, x, else, TRUE); DevCPC486.Free(x);
1366 DevCPL486.SetLabel(else);
1367 IF n.right.conval.setval # {} THEN stat(n.right.right, end)
1368 ELSE DevCPC486.Trap(caseTrap); sequential := FALSE
1369 END
1370 END;
1371 case := n.right.left;
1372 WHILE case # NIL DO (* case.class = Ncasedo *)
1373 IF sequential THEN DevCPC486.Jump(end) END;
1374 lab := case.left;
1375 IF (case.right # NIL) & (case.right.class = Ngoto) THEN (* jump to goto optimization *)
1376 case.right.right.conval.intval2 := SHORT(ENTIER(lab.conval.realval));
1377 ASSERT(lab.link = NIL); sequential := FALSE
1378 ELSE
1379 WHILE lab # NIL DO
1380 this := SHORT(ENTIER(lab.conval.realval)); DevCPL486.SetLabel(this); lab := lab.link
1381 END;
1382 stat(case.right, end)
1383 END;
1384 case := case.link
1385 END
1386 END CaseStat;
1388 PROCEDURE Dim(n: DevCPT.Node; VAR x, nofel: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct);
1389 VAR len: DevCPL486.Item; u: SET; s: INTEGER;
1390 BEGIN
1391 Check(n, u, s);
1392 IF (nofel.mode = Reg) & (nofel.reg IN u) THEN DevCPC486.Push(nofel) END;
1393 expr(n, len, {}, {mem, short});
1394 IF nofel.mode = Stk THEN DevCPC486.Pop(nofel, Int32, {}, {}) END;
1395 IF len.mode = Stk THEN DevCPC486.Pop(len, Int32, {}, {}) END;
1396 DevCPC486.MulDim(len, nofel, fact, dimtyp);
1397 IF n.link # NIL THEN
1398 Dim(n.link, x, nofel, fact, dimtyp.BaseTyp);
1399 ELSE
1400 DevCPC486.New(x, nofel, fact)
1401 END;
1402 DevCPC486.SetDim(x, len, dimtyp)
1403 END Dim;
1405 PROCEDURE CompStat (n: DevCPT.Node);
1406 VAR x, y, sp, old, len, nofel: DevCPL486.Item; fact: INTEGER; typ: DevCPT.Struct;
1407 BEGIN
1408 Checkpc;
1409 WHILE (n # NIL) & DevCPM.noerr DO
1410 ASSERT(n.class = Nassign);
1411 IF n.subcl = assign THEN
1412 IF n.right.typ.form IN {String8, String16} THEN
1413 StringCopy(n.left, n.right)
1414 ELSE
1415 IF (n.left.typ.sysflag = interface) & ~CountedPtr(n.right) THEN
1416 IPAssign(NIL, n.right, x, y, {}); (* no Release *)
1417 ELSE expr(n.right, y, {}, {})
1418 END;
1419 expr(n.left, x, {}, {});
1420 DevCPC486.Assign(x, y)
1421 END
1422 ELSE ASSERT(n.subcl = newfn);
1423 typ := n.left.typ.BaseTyp;
1424 ASSERT(typ.comp = DynArr);
1425 ASSERT(n.right.link = NIL);
1426 expr(n.right, y, {}, wreg - {CX} + {mem, stk});
1427 DevCPL486.MakeReg(sp, SP, Int32);
1428 DevCPC486.CopyReg(sp, old, {}, {CX});
1429 DevCPC486.CopyReg(y, len, {}, {CX});
1430 IF typ.BaseTyp.form = Char16 THEN
1431 DevCPL486.MakeConst(x, 2, Int32); DevCPL486.GenMul(x, y, FALSE)
1432 END;
1433 DevCPC486.StackAlloc;
1434 DevCPC486.Free(y);
1435 expr(n.left, x, {}, {}); DevCPC486.Assign(x, sp);
1436 DevCPC486.Push(len);
1437 DevCPC486.Push(old);
1438 typ.sysflag := stackArray
1439 END;
1440 n := n.link
1441 END
1442 END CompStat;
1444 PROCEDURE CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item);
1445 VAR x, y, sp: DevCPL486.Item;
1446 BEGIN
1447 IF n.link # NIL THEN CompRelease(n.link, res) END;
1448 ASSERT(n.class = Nassign);
1449 IF n.subcl = assign THEN
1450 IF (n.left.typ.form = Pointer) & (n.left.typ.sysflag = interface) THEN
1451 IF res.mode = Cond THEN
1452 DevCPL486.GenCode(9CH); (* push flags *)
1453 res.mode := Stk
1454 ELSIF res.mode = Reg THEN
1455 IF res.form < Int16 THEN DevCPC486.Push(res)
1456 ELSE DevCPC486.Assert(res, {}, {AX, CX, DX})
1457 END
1458 END;
1459 expr(n.left, x, wreg - {DI}, {loaded});
1460 DevCPC486.IPRelease(x, 0, TRUE, TRUE);
1461 n.left.obj.used := FALSE
1462 END
1463 ELSE ASSERT(n.subcl = newfn);
1464 DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenPop(sp);
1465 DevCPL486.MakeConst(y, 0, Pointer);
1466 expr(n.left, x, {}, {}); DevCPC486.Assign(x, y)
1467 END
1468 END CompRelease;
1470 PROCEDURE Assign(n: DevCPT.Node; ux: SET);
1471 VAR r: DevCPT.Node; f: BYTE; false, true: DevCPL486.Label; x, y, z: DevCPL486.Item; uf, uy: SET; s: INTEGER;
1472 BEGIN
1473 r := n.right; f := r.typ.form; uf := {};
1474 IF (r.class IN {Nmop, Ndop}) THEN
1475 IF (r.subcl = conv) & (f # Set) &
1476 (*
1477 (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) THEN r := r.left;
1478 IF ~(f IN realSet) & (r.typ.form IN realSet) & (r.typ # DevCPT.intrealtyp) THEN uf := {AX} END (* entier *)
1479 *)
1480 (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) &
1481 ((f IN realSet) OR ~(r.left.typ.form IN realSet)) THEN r := r.left
1482 ELSIF (f IN {Char8..Int32, Set, Char16, String8, String16}) & SameExp(n.left, r.left) THEN
1483 IF r.class = Ndop THEN
1484 IF (r.subcl IN {slash, plus, minus, msk}) OR (r.subcl = times) & (f = Set) THEN
1485 expr(r.right, y, {}, ux); expr(n.left, x, {}, {});
1486 DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, r.subcl, FALSE);
1487 RETURN
1488 ELSIF r.subcl IN {ash, lsh, rot} THEN
1489 expr(r.right, y, wreg - {CX} + {high, mem}, ux); expr(n.left, x, {}, {});
1490 DevCPC486.Load(y, {}, wreg - {CX} + {high}); DevCPC486.Shift(x, y, r.subcl);
1491 RETURN
1492 END
1493 ELSE
1494 IF r.subcl IN {minus, abs, cap} THEN
1495 expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, r.subcl); RETURN
1496 END
1497 END
1498 ELSIF f = Bool THEN
1499 IF (r.subcl = not) & SameExp(n.left, r.left) THEN
1500 expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, not); RETURN
1501 END
1502 END
1503 END;
1504 IF (n.left.typ.sysflag = interface) & (n.left.typ.form = Pointer) THEN IPAssign(n.left, r, x, y, ux)
1505 ELSE expr(r, y, {high}, ux); expr(n.left, x, {}, uf + {loaded}); (* high ??? *)
1506 END;
1507 DevCPC486.Assign(x, y)
1508 END Assign;
1510 PROCEDURE stat (n: DevCPT.Node; VAR end: DevCPL486.Label);
1511 VAR x, y, nofel: DevCPL486.Item; local, next, loop, prevExit: DevCPL486.Label; fact, sx, sz: INTEGER; ux, uz: SET;
1512 BEGIN
1513 sequential := TRUE; INC(nesting);
1514 WHILE (n # NIL) & DevCPM.noerr DO
1515 IF n.link = NIL THEN next := end ELSE next := DevCPL486.NewLbl END;
1516 DevCPM.errpos := n.conval.intval; DevCPL486.BegStat;
1517 CASE n.class OF
1518 | Ninittd:
1519 (* done at load-time *)
1520 | Nassign:
1521 Checkpc;
1522 Check(n.left, ux, sx);
1523 CASE n.subcl OF
1524 assign:
1525 IF n.left.typ.form = Comp THEN
1526 IF (n.right.class = Ndop) & (n.right.typ.form IN {String8, String16}) THEN
1527 StringCopy(n.left, n.right)
1528 ELSE
1529 StringOp(n.left, n.right, x, y, TRUE);
1530 IF DevCPC486.ContainsIPtrs(n.left.typ) THEN IPStructAssign(n.left.typ) END;
1531 DevCPC486.Copy(x, y, FALSE)
1532 END
1533 ELSE Assign(n, ux)
1534 END
1535 | getfn:
1536 Mem(n.right, y, n.left.typ, {}, ux);
1537 expr(n.left, x, {}, {loaded});
1538 DevCPC486.Assign(x, y)
1539 | putfn:
1540 expr(n.right, y, {}, ux);
1541 Mem(n.left, x, n.right.typ, {}, {});
1542 DevCPC486.Assign(x, y)
1543 | incfn, decfn:
1544 expr(n.right, y, {}, ux); expr(n.left, x, {}, {});
1545 IF n.left.typ.form = Int64 THEN
1546 DevCPC486.LargeInc(x, y, n.subcl = decfn)
1547 ELSE
1548 DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, SHORT(SHORT(plus - incfn + n.subcl)), FALSE)
1549 END
1550 | inclfn:
1551 expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, FALSE, ux, {});
1552 DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {});
1553 DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, plus, FALSE)
1554 | exclfn:
1555 expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, TRUE, ux, {});
1556 DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {});
1557 DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, times, FALSE)
1558 | getrfn:
1559 expr(n.right, y, {}, {});
1560 IF y.offset < 8 THEN
1561 DevCPL486.MakeReg(y, y.offset, n.left.typ.form); (* ??? *)
1562 expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y)
1563 ELSE DevCPM.err(220)
1564 END
1565 | putrfn:
1566 expr(n.left, x, {}, {});
1567 IF x.offset < 8 THEN
1568 DevCPL486.MakeReg(x, x.offset, n.right.typ.form); (* ??? *)
1569 expr(n.right, y, wreg - {x.reg}, {}); DevCPC486.Assign(x, y)
1570 ELSE DevCPM.err(220)
1571 END
1572 | newfn:
1573 y.typ := n.left.typ;
1574 IF n.right # NIL THEN
1575 IF y.typ.BaseTyp.comp = Record THEN
1576 expr(n.right, nofel, {}, {AX, CX, DX, mem, stk});
1577 DevCPC486.New(y, nofel, 1);
1578 ELSE (*open array*)
1579 nofel.mode := Con; nofel.form := Int32; fact := 1;
1580 Dim(n.right, y, nofel, fact, y.typ.BaseTyp)
1581 END
1582 ELSE
1583 DevCPL486.MakeConst(nofel, 0, Int32);
1584 DevCPC486.New(y, nofel, 1);
1585 END;
1586 DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y)
1587 | sysnewfn:
1588 expr(n.right, y, {}, {mem, short}); DevCPC486.SysNew(y);
1589 DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); DevCPC486.Assign(x, y)
1590 | copyfn:
1591 StringOp(n.left, n.right, x, y, TRUE);
1592 DevCPC486.Copy(x, y, TRUE)
1593 | movefn:
1594 Check(n.right.link, uz, sz);
1595 expr(n.right, y, {}, wreg - {SI} + {short} + ux + uz);
1596 expr(n.left, x, {}, wreg - {DI} + {short} + uz);
1597 expr(n.right.link, nofel, {}, wreg - {CX} + {mem, stk, short});
1598 DevCPC486.Load(x, {}, wreg - {DI} + {con});
1599 DevCPC486.Load(y, {}, wreg - {SI} + {con});
1600 DevCPC486.SysMove(nofel)
1601 END;
1602 sequential := TRUE
1603 | Ncall:
1604 Checkpc;
1605 Call(n, x); sequential := TRUE
1606 | Nifelse:
1607 IF (n.subcl # assertfn) OR assert THEN IfStat(n, FALSE, next) END
1608 | Ncase:
1609 Checkpc;
1610 CaseStat(n, next)
1611 | Nwhile:
1612 local := DevCPL486.NewLbl;
1613 IF n.right # NIL THEN DevCPC486.Jump(local) END;
1614 loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop);
1615 stat(n.right, local); DevCPL486.SetLabel(local);
1616 DevCPM.errpos := n.conval.intval; Checkpc;
1617 condition(n.left, x, next, loop); DevCPC486.JumpT(x, loop); sequential := TRUE
1618 | Nrepeat:
1619 loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop);
1620 local := DevCPL486.NewLbl; stat(n.left, local); DevCPL486.SetLabel(local);
1621 DevCPM.errpos := n.conval.intval; Checkpc;
1622 condition(n.right, x, loop, next); DevCPC486.JumpF(x, loop); sequential := TRUE
1623 | Nloop:
1624 prevExit := Exit; Exit := next;
1625 loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); stat(n.left, loop);
1626 IF sequential THEN DevCPC486.Jump(loop) END;
1627 next := Exit; Exit := prevExit; sequential := FALSE
1628 | Nexit:
1629 Checkpc;
1630 DevCPC486.Jump(Exit); sequential := FALSE
1631 | Nreturn:
1632 IF n.left # NIL THEN
1633 Checkpc;
1634 IF (n.obj.typ.sysflag = interface) & (n.obj.typ.form = Pointer)
1635 & (n.left.class # Nconst) & ~CountedPtr(n.left) THEN IPAssign(NIL, n.left, y, x, {})
1636 ELSE expr(n.left, x, wreg - {AX}, {})
1637 END;
1638 DevCPC486.Result(n.obj, x)
1639 END;
1640 IF (nesting > 1) OR (n.link # NIL) THEN DevCPC486.Jump(Return) END;
1641 sequential := FALSE
1642 | Nwith:
1643 IfStat(n, n.subcl = 0, next)
1644 | Ntrap:
1645 Checkpc;
1646 DevCPC486.Trap(n.right.conval.intval); sequential := TRUE
1647 | Ncomp:
1648 CompStat(n.left); stat(n.right, next); x.mode := 0; CompRelease(n.left, x)
1649 | Ndrop:
1650 Checkpc;
1651 expr(n.left, x, {}, {}); DevCPC486.Free(x)
1652 | Ngoto:
1653 IF n.left # NIL THEN
1654 Checkpc;
1655 condition(n.left, x, next, n.right.conval.intval2);
1656 DevCPC486.JumpT(x, n.right.conval.intval2)
1657 ELSE
1658 DevCPC486.Jump(n.right.conval.intval2);
1659 sequential := FALSE
1660 END
1661 | Njsr:
1662 DevCPL486.GenJump(-3, n.right.conval.intval2, FALSE) (* call n.right *)
1663 | Nret:
1664 DevCPL486.GenReturn(0); sequential := FALSE (* ret 0 *)
1665 | Nlabel:
1666 DevCPL486.SetLabel(n.conval.intval2)
1667 END;
1668 DevCPC486.CheckReg; DevCPL486.EndStat; n := n.link;
1669 IF n = NIL THEN end := next
1670 ELSIF next # DevCPL486.NewLbl THEN DevCPL486.SetLabel(next)
1671 END
1672 END;
1673 DEC(nesting)
1674 END stat;
1676 PROCEDURE CheckFpu (n: DevCPT.Node; VAR useFpu: BOOLEAN);
1677 BEGIN
1678 WHILE n # NIL DO
1679 IF n.typ.form IN {Real32, Real64} THEN useFpu := TRUE END;
1680 CASE n.class OF
1681 | Ncase:
1682 CheckFpu(n.left, useFpu); CheckFpu(n.right.left, useFpu); CheckFpu(n.right.right, useFpu)
1683 | Ncasedo:
1684 CheckFpu(n.right, useFpu)
1685 | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard:
1686 CheckFpu(n.left, useFpu)
1687 | Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex:
1688 CheckFpu(n.left, useFpu); CheckFpu(n.right, useFpu)
1689 | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
1690 END;
1691 n := n.link
1692 END
1693 END CheckFpu;
1695 PROCEDURE procs(n: DevCPT.Node);
1696 VAR proc, obj: DevCPT.Object; i, j: INTEGER; end: DevCPL486.Label;
1697 ch: SHORTCHAR; name: DevCPT.Name; useFpu: BOOLEAN;
1698 BEGIN
1699 INC(DevCPL486.level); nesting := 0;
1700 WHILE (n # NIL) & DevCPM.noerr DO
1701 DevCPC486.imLevel[DevCPL486.level] := DevCPC486.imLevel[DevCPL486.level - 1]; proc := n.obj;
1702 IF imVar IN proc.conval.setval THEN INC(DevCPC486.imLevel[DevCPL486.level]) END;
1703 procs(n.left);
1704 DevCPM.errpos := n.conval.intval;
1705 useFpu := FALSE; CheckFpu(n.right, useFpu);
1706 DevCPC486.Enter(proc, n.right = NIL, useFpu);
1707 InitializeIPVars(proc);
1708 end := DevCPL486.NewLbl; Return := DevCPL486.NewLbl; stat(n.right, end);
1709 DevCPM.errpos := n.conval.intval2; Checkpc;
1710 IF sequential OR (end # DevCPL486.NewLbl) THEN
1711 DevCPL486.SetLabel(end);
1712 IF (proc.typ # DevCPT.notyp) & (proc.sysflag # noframe) THEN DevCPC486.Trap(funcTrap) END
1713 END;
1714 DevCPL486.SetLabel(Return);
1715 ReleaseIPVars(proc);
1716 DevCPC486.Exit(proc, n.right = NIL);
1717 IF proc.mode = TProc THEN
1718 name := proc.link.typ.strobj.name^$; i := 0;
1719 WHILE name[i] # 0X DO INC(i) END;
1720 name[i] := "."; INC(i); j := 0; ch := proc.name[0];
1721 WHILE (ch # 0X) & (i < LEN(name)-1) DO name[i] := ch; INC(i); INC(j); ch := proc.name[j] END ;
1722 name[i] := 0X;
1723 ELSE name := proc.name^$
1724 END;
1725 DevCPE.OutRefName(name); DevCPE.OutRefs(proc.scope.right);
1726 n := n.link
1727 END;
1728 DEC(DevCPL486.level)
1729 END procs;
1731 PROCEDURE Module*(prog: DevCPT.Node);
1732 VAR end: DevCPL486.Label; name: DevCPT.Name; obj, p: DevCPT.Object; n: DevCPT.Node;
1733 aAd, rAd: INTEGER; typ: DevCPT.Struct; useFpu: BOOLEAN;
1734 BEGIN
1735 DevCPH.UseReals(prog, {DevCPH.longDop, DevCPH.longMop});
1736 DevCPM.NewObj(DevCPT.SelfName);
1737 IF DevCPM.noerr THEN
1738 DevCPE.OutHeader; n := prog.right;
1739 WHILE (n # NIL) & (n.class = Ninittd) DO n := n.link END;
1740 useFpu := FALSE; CheckFpu(n, useFpu);
1741 DevCPC486.Enter(NIL, n = NIL, useFpu);
1742 end := DevCPL486.NewLbl; stat(n, end); DevCPL486.SetLabel(end);
1743 DevCPM.errpos := prog.conval.intval2; Checkpc;
1744 DevCPC486.Exit(NIL, n = NIL);
1745 IF prog.link # NIL THEN (* close section *)
1746 DevCPL486.SetLabel(DevCPE.closeLbl);
1747 useFpu := FALSE; CheckFpu(prog.link, useFpu);
1748 DevCPC486.Enter(NIL, FALSE, useFpu);
1749 end := DevCPL486.NewLbl; stat(prog.link, end); DevCPL486.SetLabel(end);
1750 DevCPM.errpos := SHORT(ENTIER(prog.conval.realval)); Checkpc;
1751 DevCPC486.Exit(NIL, FALSE)
1752 END;
1753 name := "$$"; DevCPE.OutRefName(name); DevCPE.OutRefs(DevCPT.topScope.right);
1754 DevCPM.errpos := prog.conval.intval;
1755 WHILE query # NIL DO
1756 typ := query.typ; query.typ := DevCPT.int32typ;
1757 query.conval.intval := 20; (* parameters *)
1758 query.conval.intval2 := -8; (* saved registers *)
1759 DevCPC486.Enter(query, FALSE, FALSE);
1760 InstallQueryInterface(typ, query);
1761 DevCPC486.Exit(query, FALSE);
1762 name := "QueryInterface"; DevCPE.OutRefName(name);
1763 query := query.nlink
1764 END;
1765 procs(prog.left);
1766 DevCPC486.InstallStackAlloc;
1767 addRef := NIL; release := NIL; release2 := NIL;
1768 DevCPC486.intHandler := NIL;
1769 IF DevCPM.noerr THEN DevCPE.OutCode END;
1770 IF ~DevCPM.noerr THEN DevCPM.DeleteObj END
1771 END
1772 END Module;
1774 END DevCPV486.