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