1 MODULE Dev0CPC486;
3 (* THIS IS TEXT COPY OF CPC486.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 DevCPL486 := Dev0CPL486;
22 CONST
23 initializeAll = FALSE; (* initialize all local variable to zero *)
24 initializeOut = FALSE; (* initialize all OUT parameters to zero *)
25 initializeDyn = FALSE; (* initialize all open array OUT parameters to zero *)
26 initializeStr = FALSE; (* initialize rest of string value parameters to zero *)
28 FpuControlRegister = 33EH; (* value for fpu control register initialization *)
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; Guid = 23;
35 VString16to8 = 29; VString8 = 30; VString16 = 31;
36 intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64};
38 (* composite structure forms *)
39 Basic = 1; Array = 2; DynArr = 3; Record = 4;
41 (* item base modes (=object modes) *)
42 Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
44 (* item modes for i386 *)
45 Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
47 (* symbol values and ops *)
48 times = 1; slash = 2; div = 3; mod = 4;
49 and = 5; plus = 6; minus = 7; or = 8; eql = 9;
50 neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
51 in = 15; is = 16; ash = 17; msk = 18; len = 19;
52 conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
53 adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
54 getrfn = 26; putrfn = 27;
55 min = 34; max = 35; typ = 36;
57 (* procedure flags (conval.setval) *)
58 hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isGuarded = 30; isCallback = 31;
60 (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
61 newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
63 false = 0; true = 1; nil = 0;
65 (* registers *)
66 AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
67 stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; wreg = {AX, BX, CX, DX, SI, DI};
69 (* GenShiftOp *)
70 ROL = 0; ROR = 8H; SHL = 20H; SHR = 28H; SAR = 38H;
72 (* GenBitOp *)
73 BT = 20H; BTS = 28H; BTR = 30H;
75 (* GenFDOp *)
76 FADD = 0; FMUL = 8H; FCOM = 10H; FCOMP = 18H; FSUB = 20H; FSUBR = 28H; FDIV = 30H; FDIVR = 38H;
78 (* GenFMOp *)
79 FABS = 1E1H; FCHS = 1E0H; FTST = 1E4H; FSTSW = 7E0H; FUCOM = 2E9H;
81 (* GenCode *)
82 SAHF = 9EH; WAIT = 9BH;
84 (* condition codes *)
85 ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *)
86 ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *)
87 ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1;
88 ccAlways = -1; ccNever = -2; ccCall = -3;
90 (* sysflag *)
91 untagged = 1; callback = 2; noAlign = 3; union = 7;
92 interface = 10; ccall = -10; guarded = 10; 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 (* module visibility of objects *)
101 internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
103 (* pointer init limits *)
104 MaxPtrs = 10; MaxPush = 4;
106 Tag0Offset = 12;
107 Mth0Offset = -4;
108 ArrDOffs = 8;
109 numPreIntProc = 2;
111 stackAllocLimit = 2048;
114 VAR
115 imLevel*: ARRAY 64 OF BYTE;
116 intHandler*: DevCPT.Object;
117 inxchk, ovflchk, ranchk, typchk, ptrinit, hints: BOOLEAN;
118 WReg, BReg, AllReg: SET; FReg: INTEGER;
119 ptrTab: ARRAY MaxPtrs OF INTEGER;
120 stkAllocLbl: DevCPL486.Label;
121 procedureUsesFpu: BOOLEAN;
124 PROCEDURE Init* (opt: SET);
125 CONST chk = 0; achk = 1; hint = 29;
126 BEGIN
127 inxchk := chk IN opt; ovflchk := achk IN opt; ranchk := achk IN opt; typchk := chk IN opt; ptrinit := chk IN opt;
128 hints := hint IN opt;
129 stkAllocLbl := DevCPL486.NewLbl
130 END Init;
132 PROCEDURE Reversed (cond: BYTE): BYTE; (* reversed condition *)
133 BEGIN
134 IF cond = lss THEN RETURN gtr
135 ELSIF cond = gtr THEN RETURN lss
136 ELSIF cond = leq THEN RETURN geq
137 ELSIF cond = geq THEN RETURN leq
138 ELSE RETURN cond
139 END
140 END Reversed;
142 PROCEDURE Inverted (cc: INTEGER): INTEGER; (* inverted sense of condition code *)
143 BEGIN
144 IF ODD(cc) THEN RETURN cc-1 ELSE RETURN cc+1 END
145 END Inverted;
147 PROCEDURE setCC* (VAR x: DevCPL486.Item; rel: BYTE; reversed, signed: BOOLEAN);
148 BEGIN
149 IF reversed THEN rel := Reversed(rel) END;
150 CASE rel OF
151 false: x.offset := ccNever
152 | true: x.offset := ccAlways
153 | eql: x.offset := ccE
154 | neq: x.offset := ccNE
155 | lss: IF signed THEN x.offset := ccL ELSE x.offset := ccB END
156 | leq: IF signed THEN x.offset := ccLE ELSE x.offset := ccBE END
157 | gtr: IF signed THEN x.offset := ccG ELSE x.offset := ccA END
158 | geq: IF signed THEN x.offset := ccGE ELSE x.offset := ccAE END
159 END;
160 x.mode := Cond; x.form := Bool; x.reg := 0;
161 IF reversed THEN x.reg := 1 END;
162 IF signed THEN INC(x.reg, 2) END
163 END setCC;
165 PROCEDURE StackAlloc*; (* pre: len = CX bytes; post: len = CX words *)
166 BEGIN
167 DevCPL486.GenJump(ccCall, stkAllocLbl, FALSE)
168 END StackAlloc;
170 PROCEDURE^ CheckAv* (reg: INTEGER);
172 PROCEDURE AdjustStack (val: INTEGER);
173 VAR c, sp: DevCPL486.Item;
174 BEGIN
175 IF val < -stackAllocLimit THEN
176 CheckAv(CX);
177 DevCPL486.MakeConst(c, -val, Int32); DevCPL486.MakeReg(sp, CX, Int32); DevCPL486.GenMove(c, sp);
178 StackAlloc
179 ELSIF val # 0 THEN
180 DevCPL486.MakeConst(c, val, Int32); DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenAdd(c, sp, FALSE)
181 END
182 END AdjustStack;
184 PROCEDURE DecStack (form: INTEGER);
185 BEGIN
186 IF form IN {Real64, Int64} THEN AdjustStack(-8) ELSE AdjustStack(-4) END
187 END DecStack;
189 PROCEDURE IncStack (form: INTEGER);
190 BEGIN
191 IF form IN {Real64, Int64} THEN AdjustStack(8) ELSE AdjustStack(4) END
192 END IncStack;
194 (*-----------------register handling------------------*)
196 PROCEDURE SetReg* (reg: SET);
197 BEGIN
198 AllReg := reg; WReg := reg; BReg := reg * {0..3} + SYSTEM.LSH(reg * {0..3}, 4); FReg := 8
199 END SetReg;
201 PROCEDURE CheckReg*;
202 VAR reg: SET;
203 BEGIN
204 reg := AllReg - WReg;
205 IF reg # {} THEN
206 DevCPM.err(-777); (* register not released *)
207 IF AX IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " AX" END;
208 IF BX IN reg THEN DevCPM.errorMes := DevCPM.errorMes +" BX" END;
209 IF CX IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " CX" END;
210 IF DX IN reg THEN DevCPM.errorMes := DevCPM.errorMes +" DX" END;
211 IF SI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " SI" END;
212 IF DI IN reg THEN DevCPM.errorMes := DevCPM.errorMes + " DI" END;
213 WReg := AllReg; BReg := AllReg * {0..3} + SYSTEM.LSH(AllReg * {0..3}, 4)
214 END;
215 IF FReg < 8 THEN DevCPM.err(-778); FReg := 8 (* float register not released *)
216 ELSIF FReg > 8 THEN DevCPM.err(-779); FReg := 8
217 END
218 END CheckReg;
220 PROCEDURE CheckAv* (reg: INTEGER);
221 BEGIN
222 ASSERT(reg IN WReg)
223 END CheckAv;
225 PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET);
226 VAR n: INTEGER; s, s1: SET;
227 BEGIN
228 CASE f OF
229 | Byte, Bool, Char8, Int8:
230 s := BReg * {0..3} - stop;
231 IF (high IN stop) OR (high IN hint) & (s - hint # {}) THEN n := 0;
232 IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
233 IF s - hint # {} THEN s := s - hint END;
234 WHILE ~(n IN s) DO INC(n) END
235 ELSE
236 s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0;
237 IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
238 s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4);
239 IF s1 # {} THEN s := s1 END;
240 WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END;
241 IF ~(n IN s) THEN n := n + 4 END
242 END;
243 EXCL(BReg, n); EXCL(WReg, n MOD 4)
244 | Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16:
245 s := WReg - stop;
246 IF high IN stop THEN s := s * {0..3} END;
247 IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END;
248 s1 := s - hint;
249 IF high IN hint THEN s1 := s1 * {0..3} END;
250 IF s1 # {} THEN s := s1 END;
251 IF 0 IN s THEN n := 0
252 ELSIF 2 IN s THEN n := 2
253 ELSIF 6 IN s THEN n := 6
254 ELSIF 7 IN s THEN n := 7
255 ELSIF 1 IN s THEN n := 1
256 ELSE n := 3
257 END;
258 EXCL(WReg, n);
259 IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END
260 | Real32, Real64:
261 IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END;
262 DEC(FReg); n := 0
263 END;
264 DevCPL486.MakeReg(x, n, f);
265 END GetReg;
267 PROCEDURE FreeReg (n, f: INTEGER);
268 BEGIN
269 IF f <= Int8 THEN
270 INCL(BReg, n);
271 IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END
272 ELSIF f IN realSet THEN
273 INC(FReg)
274 ELSIF n IN AllReg THEN
275 INCL(WReg, n);
276 IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
277 END
278 END FreeReg;
280 PROCEDURE FreeWReg (n: INTEGER);
281 BEGIN
282 IF n IN AllReg THEN
283 INCL(WReg, n);
284 IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
285 END
286 END FreeWReg;
288 PROCEDURE Free* (VAR x: DevCPL486.Item);
289 BEGIN
290 CASE x.mode OF
291 | Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END
292 | Ind: FreeWReg(x.reg);
293 IF x.scale # 0 THEN FreeWReg(x.index) END
294 | Reg: FreeReg(x.reg, x.form);
295 IF x.form = Int64 THEN FreeWReg(x.index) END
296 ELSE
297 END
298 END Free;
300 PROCEDURE FreeHi (VAR x: DevCPL486.Item); (* free hi byte of word reg *)
301 BEGIN
302 IF x.mode = Reg THEN
303 IF x.form = Int64 THEN FreeWReg(x.index)
304 ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4)
305 END
306 END
307 END FreeHi;
309 PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN; (* x.mode = Reg *)
310 BEGIN
311 IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END;
312 IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop))
313 ELSIF x.form IN realSet THEN RETURN ~(float IN stop)
314 ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop)
315 ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop))
316 END
317 END Fits;
319 PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET);
320 VAR rh: DevCPL486.Item;
321 BEGIN
322 IF f = Int64 THEN
323 GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r);
324 GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh);
325 r.form := Int64; r.index := rh.reg
326 ELSE
327 IF f < Int16 THEN INCL(stop, high) END;
328 GetReg(r, f, hint, stop); DevCPL486.GenPop(r)
329 END
330 END Pop;
332 PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
334 PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET); (* = Assert(x, hint, stop + {mem, stk}) *)
335 VAR r: DevCPL486.Item; f: BYTE;
336 BEGIN
337 f := x.typ.form;
338 IF x.mode = Con THEN
339 IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END;
340 IF con IN stop THEN
341 IF f = Int64 THEN LoadLong(x, hint, stop)
342 ELSE
343 GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r);
344 x.mode := Reg; x.reg := r.reg; x.form := f
345 END
346 END
347 ELSIF x.mode = Stk THEN
348 IF f IN realSet THEN
349 GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form)
350 ELSE
351 Pop(r, f, hint, stop)
352 END;
353 x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f
354 ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN
355 Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r);
356 x.mode := Reg; x.reg := r.reg; x.form := Int32
357 ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN
358 IF f = Int64 THEN LoadLong(x, hint, stop)
359 ELSE
360 Free(x); GetReg(r, f, hint, stop);
361 IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END;
362 x.mode := Reg; x.reg := r.reg; x.form := f
363 END
364 END
365 END Load;
367 PROCEDURE Push* (VAR x: DevCPL486.Item);
368 VAR y: DevCPL486.Item;
369 BEGIN
370 IF x.form IN realSet THEN
371 Load(x, {}, {}); DecStack(x.form);
372 Free(x); x.mode := Stk;
373 IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END;
374 DevCPL486.GenFStore(x, TRUE)
375 ELSIF x.form = Int64 THEN
376 Free(x); x.form := Int32; y := x;
377 IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END;
378 DevCPL486.GenPush(y); DevCPL486.GenPush(x);
379 x.mode := Stk; x.form := Int64
380 ELSE
381 IF x.form < Int16 THEN Load(x, {}, {high})
382 ELSIF x.form = Int16 THEN Load(x, {}, {})
383 END;
384 Free(x); DevCPL486.GenPush(x); x.mode := Stk
385 END
386 END Push;
388 PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET);
389 VAR r: DevCPL486.Item;
390 BEGIN
391 IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN
392 IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x)
393 ELSE Load(x, hint, stop);
394 END
395 ELSE
396 CASE x.mode OF
397 | Var, VarPar: IF ~(mem IN stop) THEN RETURN END
398 | Con: IF ~(con IN stop) THEN RETURN END
399 | Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
400 | Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
401 | Stk: IF ~(stk IN stop) THEN RETURN END
402 | Reg: IF Fits(x, stop) THEN RETURN END
403 ELSE RETURN
404 END;
405 IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x)
406 ELSE Load(x, hint, stop)
407 END
408 END
409 END Assert;
411 (*------------------------------------------------*)
413 PROCEDURE LoadR (VAR x: DevCPL486.Item);
414 BEGIN
415 IF x.mode # Reg THEN
416 Free(x); DevCPL486.GenFLoad(x);
417 IF x.mode = Stk THEN IncStack(x.form) END;
418 GetReg(x, Real32, {}, {})
419 END
420 END LoadR;
422 PROCEDURE PushR (VAR x: DevCPL486.Item);
423 BEGIN
424 IF x.mode # Reg THEN LoadR(x) END;
425 DecStack(x.form);
426 Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE)
427 END PushR;
429 PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET);
430 VAR r: DevCPL486.Item;
431 BEGIN
432 IF x.mode = Stk THEN
433 Pop(x, x.form, hint, stop)
434 ELSE
435 Free(x); GetReg(r, x.form, hint, stop);
436 DevCPL486.GenMove(x, r);
437 x.mode := Reg; x.reg := r.reg
438 END
439 END LoadW;
441 PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET);
442 VAR r: DevCPL486.Item;
443 BEGIN
444 IF x.mode = Stk THEN
445 Pop(x, x.form, hint, stop);
446 IF (x.form < Int32) OR (x.form = Char16) THEN
447 r := x; x.form := Int32; DevCPL486.GenExtMove(r, x)
448 END
449 ELSE
450 Free(x);
451 IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END;
452 IF x.mode = Con THEN x.form := r.form END;
453 IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END;
454 x.mode := Reg; x.reg := r.reg; x.form := r.form
455 END
456 END LoadL;
458 PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
459 VAR r, rh, c: DevCPL486.Item; offs: INTEGER;
460 BEGIN
461 IF x.form = Int64 THEN
462 IF x.mode = Stk THEN
463 Pop(x, x.form, hint, stop)
464 ELSIF x.mode = Reg THEN
465 FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop);
466 FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop);
467 x.form := Int32; DevCPL486.GenMove(x, r);
468 x.reg := x.index; DevCPL486.GenMove(x, rh);
469 x.reg := r.reg; x.index := rh.reg
470 ELSE
471 GetReg(rh, Int32, hint, stop + {AX});
472 Free(x);
473 GetReg(r, Int32, hint, stop);
474 x.form := Int32; offs := x.offset;
475 IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END;
476 DevCPL486.GenMove(x, rh);
477 x.offset := offs;
478 DevCPL486.GenMove(x, r);
479 x.mode := Reg; x.reg := r.reg; x.index := rh.reg
480 END
481 ELSE
482 LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh);
483 x.index := rh.reg
484 END;
485 x.form := Int64
486 END LoadLong;
488 (*------------------------------------------------*)
490 PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET);
491 BEGIN
492 ASSERT(x.mode = Reg);
493 GetReg(y, x.form, hint, stop);
494 DevCPL486.GenMove(x, y)
495 END CopyReg;
497 PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET);
498 VAR r: DevCPL486.Item;
499 BEGIN
500 IF x.mode = DInd THEN
501 x.mode := Ind
502 ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN
503 x.mode := Reg
504 ELSE
505 Free(x); GetReg(r, Pointer, hint, stop);
506 IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END;
507 x.mode := Reg; x.reg := r.reg; x.form := Pointer
508 END;
509 x.form := Pointer; x.typ := DevCPT.anyptrtyp;
510 Assert(x, hint, stop)
511 END GetAdr;
513 PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN);
514 VAR r, v: DevCPL486.Item;
515 BEGIN
516 IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer
517 ELSIF niltest THEN
518 GetAdr(x, {}, {mem, stk});
519 DevCPL486.MakeReg(r, AX, Int32);
520 v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg;
521 DevCPL486.GenTest(r, v)
522 ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer
523 ELSE GetAdr(x, {}, {})
524 END;
525 Free(x); DevCPL486.GenPush(x)
526 END PushAdr;
528 PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET);
529 VAR n: BYTE;
530 BEGIN
531 a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ;
532 IF lev = DevCPL486.level THEN a.reg := BP
533 ELSE
534 a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev]));
535 WHILE n > 0 DO
536 a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n)
537 END
538 END
539 END LevelBase;
541 PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *)
542 BEGIN
543 IF x.tmode = VarPar THEN
544 LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr;
545 ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind));
546 len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32
547 END;
548 INC(len.offset, typ.n * 4 + 4);
549 IF typ.sysflag = stackArray THEN len.offset := -4 END
550 END LenDesc;
552 PROCEDURE Tag* (VAR x, tag: DevCPL486.Item);
553 VAR typ: DevCPT.Struct;
554 BEGIN
555 typ := x.typ;
556 IF typ.form = Pointer THEN typ := typ.BaseTyp END;
557 IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final type *)
558 DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ)
559 ELSIF x.typ.form = Pointer THEN
560 ASSERT(x.mode = Reg);
561 tag.mode := Ind; tag.reg := x.reg; tag.offset := -4;
562 IF x.typ.sysflag = interface THEN tag.offset := 0 END
563 ELSIF x.tmode = VarPar THEN
564 LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4;
565 Free(tag) (* ??? *)
566 ELSIF x.tmode = Ind THEN
567 ASSERT(x.mode = Ind);
568 tag := x; tag.offset := -4
569 ELSE
570 DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ)
571 END;
572 tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp
573 END Tag;
575 PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER;
576 BEGIN
577 WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END;
578 IF typ # NIL THEN RETURN typ.n
579 ELSE RETURN 0
580 END
581 END NumOfIntProc;
583 PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN;
584 VAR fld: DevCPT.Object;
585 BEGIN
586 WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END;
587 IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE
588 ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
589 REPEAT
590 fld := typ.link;
591 WHILE (fld # NIL) & (fld.mode = Fld) DO
592 IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName)
593 OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END;
594 fld := fld.link
595 END;
596 typ := typ.BaseTyp
597 UNTIL typ = NIL
598 END;
599 RETURN FALSE
600 END ContainsIPtrs;
602 PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item);
603 VAR cv: DevCPT.Const;
604 BEGIN
605 IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END;
606 cv := DevCPT.NewConst();
607 cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str;
608 DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp
609 END GuidFromString;
611 PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN);
612 VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
613 BEGIN
614 ASSERT(x.mode IN {Reg, Ind, Abs});
615 ASSERT({AX, CX, DX} - WReg = {});
616 IF hints THEN
617 IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END
618 END;
619 IF x.mode # Reg THEN
620 GetReg(r, Pointer, {}, {});
621 p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
622 ELSE r := x
623 END;
624 IF nilTest THEN
625 DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r);
626 lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
627 END;
628 DevCPL486.GenPush(r); p := r;
629 IF x.mode # Reg THEN Free(r) END;
630 GetReg(r, Pointer, {}, {});
631 p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r);
632 p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p);
633 IF nilTest THEN DevCPL486.SetLabel(lbl) END;
634 END IPAddRef;
636 PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN);
637 VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
638 BEGIN
639 ASSERT(x.mode IN {Ind, Abs});
640 ASSERT({AX, CX, DX} - WReg = {});
641 IF hints THEN
642 IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END
643 END;
644 GetReg(r, Pointer, {}, {});
645 p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
646 DevCPL486.MakeConst(c, 0, Pointer);
647 IF nilTest THEN
648 DevCPL486.GenComp(c, r);
649 lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
650 END;
651 IF nilSet THEN DevCPL486.GenMove(c, p) END;
652 DevCPL486.GenPush(r);
653 p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r);
654 p.offset := 8; Free(r); DevCPL486.GenCall(p);
655 IF nilTest THEN DevCPL486.SetLabel(lbl) END;
656 END IPRelease;
658 PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET);
659 VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct;
660 BEGIN
661 IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN
662 DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ;
663 WHILE typ.comp = DynArr DO (* complete dynamic array iterations *)
664 LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp;
665 IF x.tmode = VarPar THEN Free(len) END; (* ??? *)
666 END;
667 n := x.scale; i := 0;
668 WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END;
669 IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *)
670 DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n
671 END
672 END;
673 CASE x.mode OF
674 Var, VarPar:
675 lev := x.obj.mnolev;
676 IF lev <= 0 THEN
677 x.mode := Abs
678 ELSE
679 LevelBase(y, lev, hint, stop);
680 IF x.mode # VarPar THEN
681 x.mode := Ind
682 ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN
683 x.mode := DInd; x.offset := x.obj.adr
684 ELSE
685 y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind
686 END;
687 x.reg := y.reg
688 END;
689 x.form := x.typ.form
690 | LProc, XProc, IProc:
691 x.mode := Con; x.offset := 0; x.form := ProcTyp
692 | TProc, CProc:
693 x.form := ProcTyp
694 | Ind, Abs, Stk, Reg:
695 IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END
696 END
697 END Prepare;
699 PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object);
700 BEGIN
701 INC(x.offset, field.adr); x.tmode := Con
702 END Field;
704 PROCEDURE DeRef* (VAR x: DevCPL486.Item);
705 VAR btyp: DevCPT.Struct;
706 BEGIN
707 x.mode := Ind; x.tmode := Ind; x.scale := 0;
708 btyp := x.typ.BaseTyp;
709 IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0
710 ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size
711 ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4
712 ELSE x.offset := 0
713 END
714 END DeRef;
716 PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET); (* x[y] *)
717 VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER;
718 BEGIN
719 btyp := x.typ.BaseTyp; elsize := btyp.size;
720 IF elsize = 0 THEN Free(y)
721 ELSIF x.typ.comp = Array THEN
722 len.mode := Con; len.obj := NIL;
723 IF y.mode = Con THEN
724 INC(x.offset, y.offset * elsize)
725 ELSE
726 Load(y, hint, stop + {mem, stk, short});
727 IF inxchk THEN
728 DevCPL486.MakeConst(len, x.typ.n, Int32);
729 DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap)
730 END;
731 IF x.scale = 0 THEN x.index := y.reg
732 ELSE
733 IF x.scale MOD elsize # 0 THEN
734 IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4
735 ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2
736 ELSE elsize := 1
737 END;
738 DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32);
739 DevCPL486.GenMul(len, y, FALSE)
740 END;
741 DevCPL486.MakeConst(len, x.scale DIV elsize, Int32);
742 DevCPL486.MakeReg(idx, x.index, Int32);
743 DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y)
744 END;
745 x.scale := elsize
746 END;
747 x.tmode := Con
748 ELSE (* x.typ.comp = DynArr *)
749 IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END;
750 LenDesc(x, len, x.typ);
751 IF x.scale # 0 THEN
752 DevCPL486.MakeReg(idx, x.index, Int32);
753 DevCPL486.GenMul(len, idx, FALSE)
754 END;
755 IF (y.mode # Con) OR (y.offset # 0) THEN
756 IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN
757 Load(y, hint, stop + {mem, stk, con, short})
758 ELSE y.form := Int32
759 END;
760 IF inxchk & ~x.typ.untagged THEN
761 DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap)
762 END;
763 IF (y.mode = Con) & (btyp.comp # DynArr) THEN
764 INC(x.offset, y.offset * elsize)
765 ELSIF x.scale = 0 THEN
766 WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END;
767 x.index := y.reg; x.scale := btyp.size
768 ELSE
769 DevCPL486.GenAdd(y, idx, FALSE); Free(y)
770 END
771 END;
772 IF x.tmode = VarPar THEN Free(len) END; (* ??? *)
773 IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END
774 END
775 END Index;
777 PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN);
778 VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct;
779 BEGIN
780 typ := x.typ;
781 IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END;
782 IF ~guard & typ.untagged THEN DevCPM.err(139)
783 ELSIF ~guard OR typchk & ~typ.untagged THEN
784 IF testtyp.untagged THEN DevCPM.err(139)
785 ELSE
786 IF (x.typ.form = Pointer) & (x.mode # Reg) THEN
787 GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag)
788 ELSE Tag(x, tag)
789 END;
790 IF ~guard THEN Free(x) END;
791 IF ~equal THEN
792 GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r);
793 tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev
794 END;
795 DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
796 DevCPL486.GenComp(tdes, tag);
797 IF guard THEN
798 IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END
799 ELSE setCC(x, eql, FALSE, FALSE)
800 END
801 END
802 END
803 END TypTest;
805 PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct);
806 VAR tag, tdes: DevCPL486.Item;
807 BEGIN
808 (* tag must be in AX ! *)
809 IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END;
810 IF testtyp.untagged THEN DevCPM.err(139)
811 ELSE
812 tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer;
813 DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
814 DevCPL486.GenComp(tdes, tag);
815 setCC(x, eql, FALSE, FALSE)
816 END
817 END ShortTypTest;
819 PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER);
820 VAR c: DevCPL486.Item;
821 BEGIN
822 ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4));
823 IF ranchk & (x.mode # Con) THEN
824 DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x);
825 IF min # 0 THEN
826 DevCPL486.GenAssert(ccLE, ranTrap);
827 c.offset := min; DevCPL486.GenComp(c, x);
828 DevCPL486.GenAssert(ccGE, ranTrap)
829 ELSIF max # 0 THEN
830 DevCPL486.GenAssert(ccBE, ranTrap)
831 ELSE
832 DevCPL486.GenAssert(ccNS, ranTrap)
833 END
834 END
835 END Check;
837 PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN);
838 VAR c: DevCPL486.Item; local: DevCPL486.Label;
839 BEGIN
840 IF useSt1 THEN DevCPL486.GenFMOp(5D1H); (* FST ST1 *)
841 ELSE DevCPL486.GenFMOp(1C0H); (* FLD ST0 *)
842 END;
843 DevCPL486.GenFMOp(1FCH); (* FRNDINT *)
844 DevCPL486.GenFMOp(0D1H); (* FCOM *)
845 CheckAv(AX);
846 DevCPL486.GenFMOp(FSTSW);
847 DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *)
848 (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
849 local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
850 DevCPL486.AllocConst(c, DevCPL486.one, Real32);
851 DevCPL486.GenFDOp(FSUB, c);
852 DevCPL486.SetLabel(local);
853 END Floor;
855 PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET);
856 BEGIN
857 IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END;
858 DevCPL486.GenFStore(x, TRUE);
859 IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END
860 END Entier;
862 PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET); (* x := y *)
863 (* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *)
864 VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item;
865 BEGIN
866 f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk});
867 IF y.form IN {Real32, Real64} THEN
868 IF f IN {Real32, Real64} THEN
869 IF m = Undef THEN
870 IF (y.form = Real64) & (f = Real32) THEN
871 IF y.mode # Reg THEN LoadR(y) END;
872 Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE)
873 END
874 ELSE
875 IF y.mode # Reg THEN LoadR(y) END;
876 IF m = Stk THEN DecStack(f) END;
877 IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END;
878 END
879 ELSE (* x not real *)
880 IF sysval THEN
881 IF y.mode = Reg THEN Free(y);
882 IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN
883 x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f
884 ELSE
885 ASSERT(y.form # Real64);
886 DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32;
887 IF m # Stk THEN
888 Pop(y, y.form, hint, stop);
889 IF f < Int16 THEN ASSERT(y.reg < 4) END;
890 y.form := f;
891 IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END
892 END
893 END
894 ELSE (* y.mode # Reg *)
895 y.form := f;
896 IF m # Undef THEN LoadW(y, hint, stop); Free(y);
897 IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END
898 END
899 END
900 ELSE (* not sysval *)
901 IF y.mode # Reg THEN LoadR(y) END;
902 Free(y);
903 IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN
904 Entier(x, y.typ, hint, stop);
905 ELSE
906 DecStack(f); y.mode := Stk;
907 IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END;
908 IF m = Stk THEN Entier(y, y.typ, {}, {})
909 ELSIF m = Undef THEN Entier(y, y.typ, hint, stop)
910 ELSE Entier(y, y.typ, hint, stop + {stk})
911 END;
912 IF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
913 ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
914 ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y)
915 END;
916 y.form := f;
917 IF (m # Undef) & (m # Stk) THEN
918 IF f = Int64 THEN
919 Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
920 IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END;
921 y.reg := y.index; DevCPL486.GenMove(y, z);
922 ELSE
923 Free(y); DevCPL486.GenMove(y, x);
924 END
925 END
926 END
927 END
928 END
929 ELSE (* y not real *)
930 IF sysval THEN
931 IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END;
932 IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END
933 ELSE
934 CASE y.form OF
935 | Byte, Bool:
936 IF f = Int64 THEN LoadLong(y, hint, stop)
937 ELSIF f >= Int16 THEN LoadL(y, hint, stop)
938 END
939 | Char8:
940 IF f = Int8 THEN Check(y, 0, 0)
941 ELSIF f = Int64 THEN LoadLong(y, hint, stop)
942 ELSIF f >= Int16 THEN LoadL(y, hint, stop)
943 END
944 | Char16:
945 IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
946 ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
947 ELSIF f = Int16 THEN Check(y, 0, 0)
948 ELSIF f = Char16 THEN (* ok *)
949 ELSIF f = Int64 THEN LoadLong(y, hint, stop)
950 ELSIF f >= Int32 THEN LoadL(y, hint, stop)
951 END
952 | Int8:
953 IF f = Char8 THEN Check(y, 0, 0)
954 ELSIF f = Int64 THEN LoadLong(y, hint, stop)
955 ELSIF f >= Int16 THEN LoadL(y, hint, stop)
956 END
957 | Int16:
958 IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
959 ELSIF f = Char16 THEN Check(y, 0, 0)
960 ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
961 ELSIF f = Int64 THEN LoadLong(y, hint, stop)
962 ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop)
963 END
964 | Int32, Set, Pointer, ProcTyp:
965 IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
966 ELSIF f = Char16 THEN Check(y, 0, 65536)
967 ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
968 ELSIF f = Int16 THEN Check(y, -32768, 32767)
969 ELSIF f = Int64 THEN LoadLong(y, hint, stop)
970 END
971 | Int64:
972 IF f IN {Bool..Int32, Char16} THEN
973 (* make range checks !!! *)
974 FreeHi(y)
975 END
976 END
977 END;
978 IF f IN {Real32, Real64} THEN
979 IF sysval THEN
980 IF (m # Undef) & (m # Reg) THEN
981 IF y.mode # Reg THEN LoadW(y, hint, stop) END;
982 Free(y);
983 IF m = Stk THEN DevCPL486.GenPush(y)
984 ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f
985 END
986 ELSE
987 IF y.mode = Reg THEN Push(y) END;
988 y.form := f;
989 IF m = Reg THEN LoadR(y) END
990 END
991 ELSE (* not sysval *) (* int -> float *)
992 IF y.mode = Reg THEN Push(y) END;
993 IF m = Stk THEN
994 Free(y); DevCPL486.GenFLoad(y); s := -4;
995 IF f = Real64 THEN DEC(s, 4) END;
996 IF y.mode = Stk THEN
997 IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END
998 END;
999 IF s # 0 THEN AdjustStack(s) END;
1000 GetReg(y, Real32, {}, {});
1001 Free(y); DevCPL486.GenFStore(x, TRUE)
1002 ELSIF m = Reg THEN
1003 LoadR(y)
1004 ELSIF m # Undef THEN
1005 LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE)
1006 END
1007 END
1008 ELSE
1009 y.form := f;
1010 IF m = Stk THEN
1011 IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END;
1012 Push(y)
1013 ELSIF m # Undef THEN
1014 IF f = Int64 THEN
1015 IF y.mode # Reg THEN LoadLong(y, hint, stop) END;
1016 Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
1017 IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END;
1018 y.reg := y.index; DevCPL486.GenMove(y, z);
1019 ELSE
1020 IF y.mode # Reg THEN LoadW(y, hint, stop) END;
1021 Free(y); DevCPL486.GenMove(y, x)
1022 END
1023 END
1024 END
1025 END
1026 END ConvMove;
1028 PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET); (* size >= 0: sysval *)
1029 VAR y: DevCPL486.Item;
1030 BEGIN
1031 ASSERT(x.mode # Con);
1032 IF (size >= 0)
1033 & ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4))
1034 OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END;
1035 (*
1036 IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.form IN {Comp, Int64})) THEN DevCPM.err(220) END;
1037 *)
1038 y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop)
1039 END Convert;
1041 PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET);
1042 VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item;
1043 BEGIN
1044 IF mem IN stop THEN GetReg(x, Bool, hint, stop) END;
1045 IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *)
1046 DevCPL486.GenSetCC(y.offset, x)
1047 ELSE
1048 end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl;
1049 DevCPL486.GenJump(y.offset, T1, TRUE); (* T1 to enable short jump *)
1050 DevCPL486.SetLabel(F);
1051 DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x);
1052 DevCPL486.GenJump(ccAlways, end, TRUE);
1053 DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1);
1054 DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x);
1055 DevCPL486.SetLabel(end)
1056 END;
1057 IF x.mode # Reg THEN Free(x) END
1058 END LoadCond;
1060 PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
1061 VAR local: DevCPL486.Label;
1062 BEGIN
1063 ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con));
1064 CASE subcl OF
1065 | eql..geq:
1066 DevCPL486.GenComp(y, x); Free(x);
1067 setCC(x, subcl, rev, x.typ.form IN {Int8..Int32})
1068 | times:
1069 IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END
1070 | slash:
1071 DevCPL486.GenXor(y, x)
1072 | plus:
1073 IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END
1074 | minus, msk:
1075 IF (x.form = Set) OR (subcl = msk) THEN (* and not *)
1076 IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x) (* y and not x *)
1077 ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x) (* x and y' *)
1078 ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x) (* x and not y *)
1079 ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x) (* not (not x or y) *)
1080 END
1081 ELSE (* minus *)
1082 IF rev THEN (* y - x *)
1083 IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x)
1084 ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk) (* ??? *)
1085 END
1086 ELSE (* x - y *)
1087 DevCPL486.GenSub(y, x, ovflchk)
1088 END
1089 END
1090 | min, max:
1091 local := DevCPL486.NewLbl;
1092 DevCPL486.GenComp(y, x);
1093 IF subcl = min THEN
1094 IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE)
1095 ELSE DevCPL486.GenJump(ccLE, local, TRUE)
1096 END
1097 ELSE
1098 IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE)
1099 ELSE DevCPL486.GenJump(ccGE, local, TRUE)
1100 END
1101 END;
1102 DevCPL486.GenMove(y, x);
1103 DevCPL486.SetLabel(local)
1104 END;
1105 Free(y);
1106 IF x.mode # Reg THEN Free(x) END
1107 END IntDOp;
1109 PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN); (* INC(x, y) or DEC(x, y) *)
1110 BEGIN
1111 ASSERT(x.form = Int64);
1112 IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END;
1113 Free(x); Free(y); x.form := Int32; y.form := Int32;
1114 IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END;
1115 INC(x.offset, 4);
1116 IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END;
1117 IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END;
1118 END LargeInc;
1120 PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
1121 VAR local: DevCPL486.Label; a, b: DevCPL486.Item;
1122 BEGIN
1123 ASSERT(x.mode = Reg);
1124 IF y.form = Int64 THEN LoadR(y) END;
1125 IF y.mode = Reg THEN rev := ~rev END;
1126 CASE subcl OF
1127 | eql..geq: DevCPL486.GenFDOp(FCOMP, y)
1128 | times: DevCPL486.GenFDOp(FMUL, y)
1129 | slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END
1130 | plus: DevCPL486.GenFDOp(FADD, y)
1131 | minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END
1132 | min, max:
1133 IF y.mode = Reg THEN
1134 DevCPL486.GenFMOp(0D1H); (* FCOM ST1 *)
1135 CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
1136 local := DevCPL486.NewLbl;
1137 IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END;
1138 DevCPL486.GenFMOp(5D1H); (* FST ST1 *)
1139 DevCPL486.SetLabel(local);
1140 DevCPL486.GenFMOp(5D8H) (* FSTP ST0 *)
1141 ELSE
1142 DevCPL486.GenFDOp(FCOM, y);
1143 CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
1144 local := DevCPL486.NewLbl;
1145 IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END;
1146 DevCPL486.GenFMOp(5D8H); (* FSTP ST0 *)
1147 DevCPL486.GenFLoad(y);
1148 DevCPL486.SetLabel(local)
1149 END
1150 (* largeint support *)
1151 | div:
1152 IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END;
1153 Floor(y, FALSE)
1154 | mod:
1155 IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
1156 IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
1157 DevCPL486.GenFMOp(1F8H); (* FPREM *)
1158 DevCPL486.GenFMOp(1E4H); (* FTST *)
1159 CheckAv(AX);
1160 DevCPL486.GenFMOp(FSTSW);
1161 DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX});
1162 DevCPL486.GenMove(a, b);
1163 DevCPL486.GenFMOp(0D1H); (* FCOM *)
1164 DevCPL486.GenFMOp(FSTSW);
1165 DevCPL486.GenXor(b, a); Free(b);
1166 (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
1167 local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
1168 DevCPL486.GenFMOp(0C1H); (* FADD ST1 *)
1169 DevCPL486.SetLabel(local);
1170 DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *)
1171 | ash:
1172 IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
1173 IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
1174 DevCPL486.GenFMOp(1FDH); (* FSCALE *)
1175 Floor(y, TRUE)
1176 END;
1177 IF y.mode = Stk THEN IncStack(y.form) END;
1178 Free(y);
1179 IF (subcl >= eql) & (subcl <= geq) THEN
1180 Free(x); CheckAv(AX);
1181 DevCPL486.GenFMOp(FSTSW);
1182 (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
1183 setCC(x, subcl, rev, FALSE)
1184 END
1185 END FloatDOp;
1187 PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
1188 VAR L: DevCPL486.Label; c: DevCPL486.Item;
1189 BEGIN
1190 CASE subcl OF
1191 | minus:
1192 IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END
1193 | abs:
1194 L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form);
1195 DevCPL486.GenComp(c, x);
1196 DevCPL486.GenJump(ccNS, L, TRUE);
1197 DevCPL486.GenNeg(x, ovflchk);
1198 DevCPL486.SetLabel(L)
1199 | cap:
1200 DevCPL486.MakeConst(c, -1 - 20H, x.form);
1201 DevCPL486.GenAnd(c, x)
1202 | not:
1203 DevCPL486.MakeConst(c, 1, x.form);
1204 DevCPL486.GenXor(c, x)
1205 END;
1206 IF x.mode # Reg THEN Free(x) END
1207 END IntMOp;
1209 PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
1210 BEGIN
1211 ASSERT(x.mode = Reg);
1212 IF subcl = minus THEN DevCPL486.GenFMOp(FCHS)
1213 ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS)
1214 END
1215 END FloatMOp;
1217 PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET);
1218 (* range neg result
1219 F F {x}
1220 F T -{x}
1221 T F {x..31}
1222 T T -{0..x} *)
1223 VAR c, r: DevCPL486.Item; val: INTEGER;
1224 BEGIN
1225 IF x.mode = Con THEN
1226 IF range THEN
1227 IF neg THEN val := -2 ELSE val := -1 END;
1228 x.offset := SYSTEM.LSH(val, x.offset)
1229 ELSE
1230 val := 1; x.offset := SYSTEM.LSH(val, x.offset);
1231 IF neg THEN x.offset := -1 - x.offset END
1232 END
1233 ELSE
1234 Check(x, 0, 31);
1235 IF neg THEN val := -2
1236 ELSIF range THEN val := -1
1237 ELSE val := 1
1238 END;
1239 DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r);
1240 IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END;
1241 Free(x); x.reg := r.reg
1242 END;
1243 x.typ := DevCPT.settyp; x.form := Set
1244 END MakeSet;
1246 PROCEDURE MakeCond* (VAR x: DevCPL486.Item);
1247 VAR c: DevCPL486.Item;
1248 BEGIN
1249 IF x.mode = Con THEN
1250 setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE)
1251 ELSE
1252 DevCPL486.MakeConst(c, 0, x.form);
1253 DevCPL486.GenComp(c, x); Free(x);
1254 setCC(x, neq, FALSE, FALSE)
1255 END
1256 END MakeCond;
1258 PROCEDURE Not* (VAR x: DevCPL486.Item);
1259 VAR a: INTEGER;
1260 BEGIN
1261 x.offset := Inverted(x.offset); (* invert cc *)
1262 END Not;
1264 PROCEDURE Odd* (VAR x: DevCPL486.Item);
1265 VAR c: DevCPL486.Item;
1266 BEGIN
1267 IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END;
1268 Free(x); DevCPL486.MakeConst(c, 1, x.form);
1269 IF x.mode = Reg THEN
1270 IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END;
1271 DevCPL486.GenAnd(c, x)
1272 ELSE
1273 c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x)
1274 END;
1275 setCC(x, neq, FALSE, FALSE)
1276 END Odd;
1278 PROCEDURE In* (VAR x, y: DevCPL486.Item);
1279 BEGIN
1280 IF y.form = Set THEN Check(x, 0, 31) END;
1281 DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y);
1282 setCC(x, lss, FALSE, FALSE); (* carry set *)
1283 END In;
1285 PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE); (* ASH, LSH, ROT *)
1286 VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER;
1287 BEGIN
1288 IF subcl = ash THEN opl := SHL; opr := SAR
1289 ELSIF subcl = lsh THEN opl := SHL; opr := SHR
1290 ELSE opl := ROL; opr := ROR
1291 END;
1292 IF y.mode = Con THEN
1293 IF y.offset > 0 THEN
1294 DevCPL486.GenShiftOp(opl, y, x)
1295 ELSIF y.offset < 0 THEN
1296 y.offset := -y.offset;
1297 DevCPL486.GenShiftOp(opr, y, x)
1298 END
1299 ELSE
1300 ASSERT(y.mode = Reg);
1301 Check(y, -31, 31);
1302 L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl;
1303 DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y);
1304 DevCPL486.GenJump(ccNS, L1, TRUE);
1305 DevCPL486.GenNeg(y, FALSE);
1306 DevCPL486.GenShiftOp(opr, y, x);
1307 DevCPL486.GenJump(ccAlways, L2, TRUE);
1308 DevCPL486.SetLabel(L1);
1309 DevCPL486.GenShiftOp(opl, y, x);
1310 DevCPL486.SetLabel(L2);
1311 Free(y)
1312 END;
1313 IF x.mode # Reg THEN Free(x) END
1314 END Shift;
1316 PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN);
1317 VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN;
1318 BEGIN
1319 ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE;
1320 IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END;
1321 DevCPL486.GenDiv(y, mod, pos); Free(y);
1322 IF mod THEN
1323 r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *) (* ??? *)
1324 END
1325 END DivMod;
1327 PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct); (* x := Mem[x+offset] *)
1328 BEGIN
1329 IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset)
1330 ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset
1331 END;
1332 x.scale := 0; x.typ := typ; x.form := typ.form
1333 END Mem;
1335 PROCEDURE SysMove* (VAR len: DevCPL486.Item); (* implementation of SYSTEM.MOVE *)
1336 BEGIN
1337 IF len.mode = Con THEN
1338 IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END
1339 ELSE
1340 Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len)
1341 END;
1342 FreeWReg(SI); FreeWReg(DI)
1343 END SysMove;
1345 PROCEDURE Len* (VAR x, y: DevCPL486.Item);
1346 VAR typ: DevCPT.Struct; dim: INTEGER;
1347 BEGIN
1348 dim := y.offset; typ := x.typ;
1349 IF typ.untagged THEN DevCPM.err(136) END;
1350 WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END;
1351 LenDesc(x, x, typ);
1352 END Len;
1354 PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER;
1355 BEGIN
1356 CASE x.form OF
1357 | String8, VString8: RETURN 1
1358 | String16, VString16: RETURN 2
1359 | VString16to8: RETURN 0
1360 | Comp: RETURN x.typ.BaseTyp.size
1361 END
1362 END StringWSize;
1364 PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN);
1365 VAR sw, dw: INTEGER;
1366 BEGIN
1367 CheckAv(CX);
1368 IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN
1369 DevCPL486.GenBlockComp(4, 4)
1370 ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index)
1371 ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index)
1372 ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index)
1373 ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index)
1374 ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x))
1375 END;
1376 FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE);
1377 END CmpString;
1379 PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item);
1380 VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct;
1381 BEGIN
1382 atyp := y.typ;
1383 WHILE ftyp.comp = DynArr DO
1384 IF ftyp.BaseTyp = DevCPT.bytetyp THEN
1385 IF atyp.comp = DynArr THEN
1386 IF atyp.untagged THEN DevCPM.err(137) END;
1387 LenDesc(y, len, atyp);
1388 IF y.tmode = VarPar THEN Free(len) END; (* ??? *)
1389 GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z);
1390 len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp;
1391 WHILE atyp.comp = DynArr DO
1392 LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE);
1393 IF y.tmode = VarPar THEN Free(z) END; (* ??? *)
1394 atyp := atyp.BaseTyp
1395 END;
1396 DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE);
1397 Free(len)
1398 ELSE
1399 DevCPL486.MakeConst(len, atyp.size, Int32)
1400 END
1401 ELSE
1402 IF atyp.comp = DynArr THEN LenDesc(y, len, atyp);
1403 IF atyp.untagged THEN DevCPM.err(137) END;
1404 IF y.tmode = VarPar THEN Free(len) END; (* ??? *)
1405 ELSE DevCPL486.MakeConst(len, atyp.n, Int32)
1406 END
1407 END;
1408 DevCPL486.GenPush(len);
1409 ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
1410 END
1411 END VarParDynArr;
1413 PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *)
1414 BEGIN
1415 IF y.mode = Con THEN
1416 IF y.form IN {Real32, Real64} THEN
1417 DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {});
1418 IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END (* ??? move const *)
1419 ELSIF x.form = Int64 THEN
1420 ASSERT(x.mode IN {Ind, Abs});
1421 y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x);
1422 y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x);
1423 DEC(x.offset, 4); x.form := Int64
1424 ELSE
1425 DevCPL486.GenMove(y, x)
1426 END
1427 ELSE
1428 IF y.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *)
1429 ASSERT(x.form = Pointer);
1430 GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer
1431 END;
1432 IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END;
1433 ConvMove(x, y, FALSE, {}, {})
1434 END;
1435 Free(x)
1436 END Assign;
1438 PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET);
1439 VAR c: DevCPL486.Item;
1440 BEGIN
1441 IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
1442 ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
1443 ELSE len.mode := Con
1444 END;
1445 len.typ := DevCPT.int32typ
1446 END ArrayLen;
1448 (*
1449 src dest zero
1450 sx = sy x b y b
1451 SHORT(lx) = sy x b+ x w y b
1452 SHORT(lx) = SHORT(ly) x b+ x w y b+
1454 lx = ly x w y w
1455 LONG(sx) = ly x b y w *
1456 LONG(SHORT(lx)) = ly x b+ x w* y w *
1458 sx := sy y b x b
1459 sx := SHORT(ly) y b+ y w x b
1461 lx := ly y w x w
1462 lx := LONG(sy) y b x w *
1463 lx := LONG(SHORT(ly)) y b+ y w* x w *
1464 *)
1466 PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *)
1467 BEGIN
1468 IF (x.typ.comp = DynArr) & x.typ.untagged THEN
1469 DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1)
1470 ELSE
1471 DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0)
1472 END;
1473 FreeWReg(SI); FreeWReg(DI)
1474 END AddCopy;
1476 PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *)
1477 VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item;
1478 BEGIN
1479 sx := x.typ.size; CheckAv(CX);
1480 IF y.form IN {String8, String16} THEN
1481 sy := y.index * y.typ.BaseTyp.size;
1482 IF x.typ.comp = Array THEN (* adjust size for optimal performance *)
1483 sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4;
1484 IF sy4 <= sx THEN sy := sy4
1485 ELSIF sy2 <= sx THEN sy := sy2
1486 ELSIF sy > sx THEN DevCPM.err(114); sy := 1
1487 END
1488 ELSIF inxchk & ~x.typ.untagged THEN (* check array length *)
1489 Free(x); LenDesc(x, c, x.typ);
1490 DevCPL486.MakeConst(y, y.index, Int32);
1491 DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap);
1492 Free(c)
1493 END;
1494 DevCPL486.GenBlockMove(1, sy)
1495 ELSIF x.typ.comp = DynArr THEN
1496 IF x.typ.untagged THEN
1497 DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1)
1498 ELSE
1499 Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c);
1500 DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0)
1501 END
1502 ELSIF y.form IN {VString16to8, VString8, VString16} THEN
1503 DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
1504 ASSERT(y.mode # Stk)
1505 ELSIF short THEN (* COPY *)
1506 sy := y.typ.size;
1507 IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END;
1508 DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
1509 IF y.mode = Stk THEN AdjustStack(sy) END
1510 ELSE (* := *)
1511 IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END;
1512 IF y.mode = Stk THEN AdjustStack(sy) END
1513 END;
1514 FreeWReg(SI); FreeWReg(DI)
1515 END Copy;
1517 PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN);
1518 VAR c: DevCPL486.Item;
1519 BEGIN
1520 CheckAv(AX); CheckAv(CX);
1521 DevCPL486.GenStringLength(typ.BaseTyp.size, -1);
1522 Free(x); GetReg(x, Int32, {}, wreg - {CX});
1523 DevCPL486.GenNot(x);
1524 IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END;
1525 FreeWReg(DI)
1526 END StrLen;
1528 PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); (* z := z * y *)
1529 VAR c: DevCPL486.Item;
1530 BEGIN
1531 IF y.mode = Con THEN fact := fact * y.offset
1532 ELSE
1533 IF ranchk OR inxchk THEN
1534 DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap)
1535 END;
1536 DevCPL486.GenPush(y);
1537 IF z.mode = Con THEN z := y
1538 ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y)
1539 END
1540 END
1541 END MulDim;
1543 PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *)
1544 (* y const or on stack *)
1545 VAR z: DevCPL486.Item; end: DevCPL486.Label;
1546 BEGIN
1547 ASSERT((x.mode = Reg) & (x.form = Pointer));
1548 z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32;
1549 IF y.mode = Con THEN y.form := Int32
1550 ELSE Pop(y, Int32, {}, {})
1551 END;
1552 end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE); (* flags set in New *)
1553 DevCPL486.GenMove(y, z);
1554 DevCPL486.SetLabel(end);
1555 IF y.mode = Reg THEN Free(y) END
1556 END SetDim;
1558 PROCEDURE SysNew* (VAR x: DevCPL486.Item);
1559 BEGIN
1560 DevCPM.err(141)
1561 END SysNew;
1563 PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER);
1564 (* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *)
1565 VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label;
1566 BEGIN
1567 typ := x.typ.BaseTyp;
1568 IF typ.untagged THEN DevCPM.err(138) END;
1569 IF typ.comp = Record THEN (* call to Kernel.NewRec(tag: Tag): ADDRESS *)
1570 DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ);
1571 IF ContainsIPtrs(typ) THEN INC(tag.offset) END;
1572 DevCPL486.GenPush(tag);
1573 p.mode := XProc; p.obj := DevCPE.KNewRec;
1574 ELSE eltyp := typ.BaseTyp;
1575 IF typ.comp = Array THEN
1576 nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n
1577 ELSE (* DynArr *)
1578 nofdim := typ.n+1;
1579 WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END
1580 END ;
1581 WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END;
1582 IF eltyp.comp = Record THEN
1583 IF eltyp.untagged THEN DevCPM.err(138) END;
1584 DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp);
1585 IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END;
1586 ELSIF eltyp.form = Pointer THEN
1587 IF ~eltyp.untagged THEN
1588 DevCPL486.MakeConst(tag, 0, Pointer) (* special TDesc in Kernel for ARRAY OF pointer *)
1589 ELSIF eltyp.sysflag = interface THEN
1590 DevCPL486.MakeConst(tag, -1, Pointer) (* special TDesc in Kernel for ARRAY OF interface pointer *)
1591 ELSE
1592 DevCPL486.MakeConst(tag, 12, Pointer)
1593 END
1594 ELSE (* eltyp is pointerless basic type *)
1595 CASE eltyp.form OF
1596 | Undef, Byte, Char8: n := 1;
1597 | Int16: n := 2;
1598 | Int8: n := 3;
1599 | Int32: n := 4;
1600 | Bool: n := 5;
1601 | Set: n := 6;
1602 | Real32: n := 7;
1603 | Real64: n := 8;
1604 | Char16: n := 9;
1605 | Int64: n := 10;
1606 | ProcTyp: n := 11;
1607 END;
1608 DevCPL486.MakeConst(tag, n, Pointer)
1609 (*
1610 DevCPL486.MakeConst(tag, eltyp.size, Pointer)
1611 *)
1612 END;
1613 IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL
1614 ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk)
1615 END;
1616 DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p);
1617 DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag);
1618 p.mode := XProc; p.obj := DevCPE.KNewArr;
1619 END;
1620 DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX});
1621 IF typ.comp = DynArr THEN (* set flags for nil test *)
1622 DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x)
1623 ELSIF typ.comp = Record THEN
1624 n := NumOfIntProc(typ);
1625 IF n > 0 THEN (* interface method table pointer setup *)
1626 DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x);
1627 lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE);
1628 tag.offset := - 4 * (n + numPreIntProc);
1629 p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer;
1630 DevCPL486.GenMove(tag, p);
1631 IF nofel.mode # Con THEN (* unk pointer setup *)
1632 p.offset := 8;
1633 DevCPL486.GenMove(nofel, p);
1634 Free(nofel)
1635 END;
1636 DevCPL486.SetLabel(lbl);
1637 END
1638 END
1639 END New;
1641 PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item); (* returns tag if rec *)
1642 VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct;
1643 BEGIN
1644 par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form;
1645 IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END;
1646 IF ap.typ = DevCPT.niltyp THEN
1647 IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN
1648 DevCPM.err(142)
1649 END;
1650 DevCPL486.GenPush(ap)
1651 ELSIF par.typ.comp = DynArr THEN
1652 IF ap.form IN {String8, String16} THEN
1653 IF ~par.typ.untagged THEN
1654 DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c)
1655 END;
1656 ap.mode := Con; DevCPL486.GenPush(ap);
1657 ELSIF ap.form IN {VString8, VString16} THEN
1658 DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a);
1659 IF ~par.typ.untagged THEN
1660 DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c);
1661 Free(ap); StrLen(c, ap.typ, TRUE);
1662 DevCPL486.GenPush(c); Free(c)
1663 END;
1664 DevCPL486.GenPush(a)
1665 ELSE
1666 IF ~par.typ.untagged THEN
1667 IF ap.typ.comp = DynArr THEN niltest := FALSE END; (* ap dereferenced for length descriptor *)
1668 VarParDynArr(par.typ, ap)
1669 END;
1670 PushAdr(ap, niltest)
1671 END
1672 ELSIF fp.mode = VarPar THEN
1673 recTyp := ap.typ;
1674 IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END;
1675 IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN
1676 Tag(ap, tag);
1677 IF rec & (tag.mode # Con) THEN
1678 GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c
1679 END;
1680 DevCPL486.GenPush(tag);
1681 IF tag.mode # Con THEN niltest := FALSE END;
1682 PushAdr(ap, niltest);
1683 IF rec THEN Free(tag) END
1684 ELSE PushAdr(ap, niltest)
1685 END;
1686 tag.typ := recTyp
1687 ELSIF par.form = Comp THEN
1688 s := par.typ.size;
1689 IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN
1690 s := (s + 3) DIV 4 * 4; AdjustStack(-s);
1691 IF ap.form IN {String8, String16} THEN
1692 IF ap.index > 1 THEN (* nonempty string *)
1693 ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4;
1694 DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
1695 DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
1696 DevCPL486.GenBlockMove(1, ss);
1697 ELSE
1698 ss := 0;
1699 DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c)
1700 END;
1701 IF s > ss THEN
1702 DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
1703 DevCPL486.GenBlockStore(1, s - ss)
1704 END;
1705 ELSE
1706 DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
1707 DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
1708 DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n);
1709 DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
1710 DevCPL486.GenBlockStore(StringWSize(par), 0)
1711 END
1712 ELSE
1713 IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN (* empty string *)
1714 AdjustStack((4 - s) DIV 4 * 4);
1715 DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c)
1716 ELSE
1717 AdjustStack((-s) DIV 4 * 4);
1718 DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
1719 DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
1720 IF ap.form IN {String8, String16} THEN
1721 DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4)
1722 ELSIF ap.form IN {VString8, VString16, VString16to8} THEN
1723 DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n)
1724 ELSE
1725 DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4)
1726 END
1727 END
1728 END
1729 ELSIF ap.mode = Con THEN
1730 IF ap.form IN {Real32, Real64} THEN (* ??? push const *)
1731 DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE)
1732 ELSE
1733 ap.form := Int32;
1734 IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END;
1735 DevCPL486.GenPush(ap)
1736 END
1737 ELSIF ap.typ.form = Pointer THEN
1738 recTyp := ap.typ.BaseTyp;
1739 IF rec THEN
1740 Load(ap, {}, {}); Tag(ap, tag);
1741 IF tag.mode = Con THEN (* explicit nil test needed *)
1742 DevCPL486.MakeReg(a, AX, Int32);
1743 c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg;
1744 DevCPL486.GenTest(a, c)
1745 END
1746 END;
1747 DevCPL486.GenPush(ap); Free(ap);
1748 tag.typ := recTyp
1749 ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *)
1750 ASSERT(par.form = Pointer);
1751 PushAdr(ap, FALSE)
1752 ELSE
1753 ConvMove(par, ap, FALSE, {}, {high});
1754 END
1755 END Param;
1757 PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item);
1758 VAR r: DevCPL486.Item;
1759 BEGIN
1760 DevCPL486.MakeReg(r, AX, proc.typ.form); (* don't allocate AX ! *)
1761 IF res.mode = Con THEN
1762 IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res);
1763 ELSIF r.form = Int64 THEN
1764 r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r);
1765 r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r)
1766 ELSE DevCPL486.GenMove(res, r);
1767 END
1768 ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *)
1769 ASSERT(r.form = Pointer);
1770 GetAdr(res, {}, wreg - {AX})
1771 ELSE
1772 r.index := DX; (* for int64 *)
1773 ConvMove(r, res, FALSE, wreg - {AX} + {high}, {});
1774 END;
1775 Free(res)
1776 END Result;
1778 PROCEDURE InitFpu;
1779 VAR x: DevCPL486.Item;
1780 BEGIN
1781 DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x);
1782 DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H); (* FLDCW 0(SP) *)
1783 DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x); (* reset stack *)
1784 END InitFpu;
1786 PROCEDURE PrepCall* (proc: DevCPT.Object);
1787 VAR lev: BYTE; r: DevCPL486.Item;
1788 BEGIN
1789 lev := proc.mnolev;
1790 IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN
1791 DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r)
1792 END
1793 END PrepCall;
1795 PROCEDURE Call* (VAR x, tag: DevCPL486.Item); (* TProc: tag.typ = actual receiver type *)
1796 VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object;
1797 BEGIN
1798 IF x.mode IN {LProc, XProc, IProc} THEN
1799 lev := x.obj.mnolev; saved := FALSE;
1800 IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN (* pass static link *)
1801 n := imLevel[DevCPL486.level] - imLevel[lev];
1802 IF n > 0 THEN
1803 saved := TRUE;
1804 y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4;
1805 DevCPL486.MakeReg(r, BX, Pointer);
1806 WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END
1807 END
1808 END;
1809 DevCPL486.GenCall(x);
1810 IF x.obj.sysflag = ccall THEN (* remove parameters *)
1811 p := x.obj.link; n := 0;
1812 WHILE p # NIL DO
1813 IF p.mode = VarPar THEN INC(n, 4)
1814 ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
1815 END;
1816 p := p.link
1817 END;
1818 AdjustStack(n)
1819 END;
1820 IF saved THEN DevCPL486.GenPop(r) END;
1821 ELSIF x.mode = TProc THEN
1822 IF x.scale = 1 THEN (* super *)
1823 DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp)
1824 ELSIF x.scale = 2 THEN (* static call *)
1825 DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ;
1826 IF typ.form = Pointer THEN typ := typ.BaseTyp END;
1827 tag.obj := DevCPE.TypeObj(typ)
1828 ELSIF x.scale = 3 THEN (* interface method call *)
1829 DevCPM.err(200)
1830 END;
1831 IF tag.mode = Con THEN
1832 y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0
1833 ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final method *)
1834 y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0;
1835 IF tag.mode = Ind THEN (* nil test *)
1836 DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag)
1837 END
1838 ELSE
1839 IF tag.mode = Reg THEN y.reg := tag.reg
1840 ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y)
1841 END;
1842 y.mode := Ind; y.offset := 0; y.scale := 0
1843 END;
1844 IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset
1845 ELSIF tag.typ.untagged THEN DevCPM.err(140)
1846 ELSE
1847 IF x.obj.link.typ.sysflag = interface THEN (* correct method number *)
1848 x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset
1849 END;
1850 INC(y.offset, Mth0Offset - 4 * x.offset)
1851 END;
1852 DevCPL486.GenCall(y); Free(y)
1853 ELSIF x.mode = CProc THEN
1854 IF x.obj.link # NIL THEN (* tag = first param *)
1855 IF x.obj.link.mode = VarPar THEN
1856 GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag)
1857 ELSE
1858 (* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *)
1859 Result(x.obj.link, tag) (* use result load for first parameter *)
1860 END
1861 END;
1862 i := 1; n := ORD(x.obj.conval.ext^[0]);
1863 WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END
1864 ELSE (* proc var *)
1865 DevCPL486.GenCall(x); Free(x);
1866 IF x.typ.sysflag = ccall THEN (* remove parameters *)
1867 p := x.typ.link; n := 0;
1868 WHILE p # NIL DO
1869 IF p.mode = VarPar THEN INC(n, 4)
1870 ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
1871 END;
1872 p := p.link
1873 END;
1874 AdjustStack(n)
1875 END;
1876 x.typ := x.typ.BaseTyp
1877 END;
1878 IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128)
1879 & ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN (* restore fpu *)
1880 InitFpu
1881 END;
1882 CheckReg;
1883 IF x.typ.form = Int64 THEN
1884 GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX});
1885 x.index := y.reg; x.form := Int64
1886 ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high})
1887 END
1888 END Call;
1890 PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct); (* needs CX, SI, DI *)
1891 VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct;
1892 BEGIN
1893 IF typ.untagged THEN DevCPM.err(-137) END;
1894 ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer;
1895 DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32);
1896 DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32);
1897 DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp;
1898 WHILE bt.comp = DynArr DO
1899 INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp
1900 END;
1901 ptr.offset := adr; DevCPL486.GenMove(ptr, src);
1902 DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE);
1903 (* CX = length in bytes *)
1904 StackAlloc;
1905 (* CX = length in 32bit words *)
1906 DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr);
1907 DevCPL486.GenBlockMove(4, 0) (* 32bit moves *)
1908 END CopyDynArray;
1910 PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER);
1911 VAR i, j, x: INTEGER;
1912 BEGIN
1913 (* align *)
1914 i := 1;
1915 WHILE i < n DO
1916 x := tab[i]; j := i-1;
1917 WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END;
1918 tab[j+1] := x; INC(i)
1919 END;
1920 (* eliminate equals *)
1921 i := 1; j := 1;
1922 WHILE i < n DO
1923 IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END;
1924 INC(i)
1925 END;
1926 n := j
1927 END Sort;
1929 PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER);
1930 VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
1931 BEGIN
1932 IF typ.form IN {Pointer, ProcTyp} THEN
1933 IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END;
1934 INC(num);
1935 IF adr MOD 4 # 0 THEN
1936 IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END;
1937 INC(num)
1938 END
1939 ELSIF typ.comp = Record THEN
1940 btyp := typ.BaseTyp;
1941 IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ;
1942 fld := typ.link;
1943 WHILE (fld # NIL) & (fld.mode = Fld) DO
1944 IF (fld.name^ = DevCPM.HdPtrName) OR
1945 (fld.name^ = DevCPM.HdUtPtrName) OR
1946 (fld.name^ = DevCPM.HdProcName) THEN
1947 FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num)
1948 ELSE FindPtrs(fld.typ, fld.adr + adr, num)
1949 END;
1950 fld := fld.link
1951 END
1952 ELSIF typ.comp = Array THEN
1953 btyp := typ.BaseTyp; n := typ.n;
1954 WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
1955 IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
1956 i := num; FindPtrs(btyp, adr, num);
1957 IF num # i THEN i := 1;
1958 WHILE (i < n) & (num <= MaxPtrs) DO
1959 INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i)
1960 END
1961 END
1962 END
1963 END
1964 END FindPtrs;
1966 PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item);
1967 VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct;
1968 BEGIN
1969 x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr;
1970 DevCPL486.MakeReg(y, DI, Int32);
1971 IF par.typ.comp # DynArr THEN
1972 DevCPL486.GenMove(x, y);
1973 lbl := DevCPL486.NewLbl;
1974 IF ODD(par.sysflag DIV nilBit) THEN
1975 DevCPL486.GenComp(zreg, y);
1976 DevCPL486.GenJump(ccE, lbl, TRUE)
1977 END;
1978 size := par.typ.size;
1979 IF size <= 16 THEN
1980 x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0;
1981 WHILE size > 0 DO
1982 IF size = 1 THEN x.form := Int8; s := 1
1983 ELSIF size = 2 THEN x.form := Int16; s := 2
1984 ELSE x.form := Int32; s := 4
1985 END;
1986 zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s)
1987 END;
1988 zreg.form := Int32
1989 ELSE
1990 DevCPL486.GenBlockStore(1, size)
1991 END;
1992 DevCPL486.SetLabel(lbl)
1993 ELSIF initializeDyn & ~par.typ.untagged THEN (* untagged open arrays not initialized !!! *)
1994 DevCPL486.GenMove(x, y);
1995 DevCPL486.MakeReg(len, CX, Int32);
1996 INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *)
1997 bt := par.typ.BaseTyp;
1998 WHILE bt.comp = DynArr DO
1999 INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp
2000 END;
2001 size := bt.size;
2002 IF size MOD 4 = 0 THEN size := size DIV 4; s := 4
2003 ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2
2004 ELSE s := 1
2005 END;
2006 DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE);
2007 DevCPL486.GenBlockStore(s, 0)
2008 END
2009 END InitOutPar;
2011 PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER);
2012 VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER;
2013 BEGIN
2014 op := 0; par := proc.link;
2015 WHILE par # NIL DO (* count out parameters [with COM pointers] *)
2016 IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END;
2017 par := par.link
2018 END;
2019 DevCPL486.MakeConst(zero, 0, Int32);
2020 IF (op = 0) & (size <= 8) THEN (* use PUSH 0 *)
2021 WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END
2022 ELSE
2023 DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z);
2024 IF size <= 32 THEN (* use PUSH reg *)
2025 WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END
2026 ELSE (* use string store *)
2027 AdjustStack(-size);
2028 DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
2029 DevCPL486.GenBlockStore(1, size)
2030 END;
2031 IF op > 0 THEN
2032 par := proc.link;
2033 WHILE par # NIL DO (* init out parameters [with COM pointers] *)
2034 IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END;
2035 par := par.link
2036 END
2037 END
2038 END
2039 END AllocAndInitAll;
2041 PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); (* needs AX *)
2042 VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object;
2043 BEGIN
2044 IF ptrinit & (proc.scope # NIL) THEN
2045 nofptrs := 0; obj := proc.scope.scope; (* local variables *)
2046 WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO
2047 FindPtrs(obj.typ, obj.adr, nofptrs);
2048 obj := obj.link
2049 END;
2050 IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN
2051 base := proc.conval.intval2;
2052 Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0;
2053 WHILE i < nofptrs DO
2054 DEC(a, 4);
2055 IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END;
2056 INC(i)
2057 END;
2058 IF a # base THEN INC(gaps) END;
2059 IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN
2060 DevCPL486.MakeConst(z, 0, Pointer);
2061 IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END;
2062 i := 0; a := size + base;
2063 WHILE i < nofptrs DO
2064 DEC(a, 4);
2065 IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END;
2066 DevCPL486.GenPush(z); INC(i)
2067 END;
2068 IF a # base THEN AdjustStack(base - a) END
2069 ELSE
2070 AdjustStack(-size);
2071 DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z);
2072 x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0;
2073 WHILE i < nofptrs DO
2074 x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
2075 END
2076 END
2077 ELSE
2078 AdjustStack(-size)
2079 END
2080 ELSE
2081 nofptrs := 0;
2082 AdjustStack(-size)
2083 END
2084 END AllocAndInitPtrs1;
2086 PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER); (* needs AX, CX, DI *)
2087 VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label;
2088 BEGIN
2089 IF ptrinit THEN
2090 zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer);
2091 IF nofptrs > MaxPtrs THEN
2092 DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE;
2093 x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr;
2094 DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y);
2095 DevCPL486.GenStrStore(size)
2096 END;
2097 obj := proc.link; (* parameters *)
2098 WHILE obj # NIL DO
2099 IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
2100 nofptrs := 0;
2101 IF obj.typ.comp = DynArr THEN (* currently not initialized *)
2102 ELSE FindPtrs(obj.typ, 0, nofptrs)
2103 END;
2104 IF nofptrs > 0 THEN
2105 IF ~zeroed THEN
2106 DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE
2107 END;
2108 x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr;
2109 DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
2110 IF ODD(obj.sysflag DIV nilBit) THEN
2111 DevCPL486.GenComp(zero, y);
2112 lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
2113 END;
2114 IF nofptrs > MaxPtrs THEN
2115 DevCPL486.GenStrStore(obj.typ.size)
2116 ELSE
2117 Sort(ptrTab, nofptrs);
2118 x.reg := DI; i := 0;
2119 WHILE i < nofptrs DO
2120 x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
2121 END
2122 END;
2123 IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END
2124 END
2125 END;
2126 obj := obj.link
2127 END
2128 END
2129 END InitPtrs2;
2131 PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN;
2132 VAR obj: DevCPT.Object; nofptrs: INTEGER;
2133 BEGIN
2134 IF ptrinit THEN
2135 obj := proc.link;
2136 WHILE obj # NIL DO
2137 IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
2138 nofptrs := 0;
2139 IF obj.typ.comp = DynArr THEN (* currently not initialized *)
2140 ELSE FindPtrs(obj.typ, 0, nofptrs)
2141 END;
2142 IF nofptrs > 0 THEN RETURN TRUE END
2143 END;
2144 obj := obj.link
2145 END
2146 END;
2147 RETURN FALSE
2148 END NeedOutPtrInit;
2150 PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN);
2151 VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER;
2152 BEGIN
2153 procedureUsesFpu := useFpu;
2154 SetReg({AX, CX, DX, SI, DI});
2155 DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer);
2156 IF proc # NIL THEN (* enter proc *)
2157 DevCPL486.SetLabel(proc.adr);
2158 IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN
2159 DevCPL486.GenPush(fp);
2160 DevCPL486.GenMove(sp, fp);
2161 adr := proc.conval.intval2; size := -adr;
2162 IF isGuarded IN proc.conval.setval THEN
2163 DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r);
2164 DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
2165 DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r);
2166 r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL;
2167 DevCPL486.GenPush(r1);
2168 intHandler.used := TRUE;
2169 r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler;
2170 DevCPL486.GenPush(r1);
2171 r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL;
2172 DevCPL486.GenCode(64H); DevCPL486.GenPush(r1);
2173 DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1);
2174 DEC(size, 24)
2175 ELSE
2176 IF imVar IN proc.conval.setval THEN (* set down pointer *)
2177 DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4)
2178 END;
2179 IF isCallback IN proc.conval.setval THEN
2180 DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
2181 DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8)
2182 END
2183 END;
2184 ASSERT(size >= 0);
2185 IF initializeAll THEN
2186 AllocAndInitAll(proc, adr, size, np)
2187 ELSE
2188 AllocAndInitPtrs1(proc, adr, size, np); (* needs AX *)
2189 InitPtrs2(proc, adr, size, np); (* needs AX, CX, DI *)
2190 END;
2191 par := proc.link; (* parameters *)
2192 WHILE par # NIL DO
2193 IF (par.mode = Var) & (par.typ.comp = DynArr) THEN
2194 CopyDynArray(par.adr, par.typ)
2195 END;
2196 par := par.link
2197 END;
2198 IF imVar IN proc.conval.setval THEN
2199 DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r)
2200 END
2201 END
2202 ELSIF ~empty THEN (* enter module *)
2203 DevCPL486.GenPush(fp);
2204 DevCPL486.GenMove(sp, fp);
2205 DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r);
2206 DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r)
2207 END;
2208 IF useFpu THEN InitFpu END
2209 END Enter;
2211 PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN);
2212 VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER;
2213 BEGIN
2214 DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer);
2215 IF proc # NIL THEN (* exit proc *)
2216 IF proc.sysflag # noframe THEN
2217 IF ~empty OR NeedOutPtrInit(proc) THEN
2218 IF isGuarded IN proc.conval.setval THEN (* remove exception frame *)
2219 x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32;
2220 DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r);
2221 x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL;
2222 DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x);
2223 size := 12
2224 ELSE
2225 size := 0;
2226 IF imVar IN proc.conval.setval THEN INC(size, 4) END;
2227 IF isCallback IN proc.conval.setval THEN INC(size, 8) END
2228 END;
2229 IF size > 0 THEN
2230 x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32;
2231 DevCPL486.GenLoadAdr(x, sp);
2232 IF size > 4 THEN
2233 DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
2234 DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r)
2235 END;
2236 IF size # 8 THEN
2237 DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r)
2238 END
2239 ELSE
2240 DevCPL486.GenMove(fp, sp)
2241 END;
2242 DevCPL486.GenPop(fp)
2243 END;
2244 IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0)
2245 ELSE DevCPL486.GenReturn(proc.conval.intval - 8)
2246 END
2247 END
2248 ELSE (* exit module *)
2249 IF ~empty THEN
2250 DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
2251 DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r);
2252 DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp)
2253 END;
2254 DevCPL486.GenReturn(0)
2255 END
2256 END Exit;
2258 PROCEDURE InstallStackAlloc*;
2259 VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label;
2260 BEGIN
2261 IF stkAllocLbl # DevCPL486.NewLbl THEN
2262 DevCPL486.SetLabel(stkAllocLbl);
2263 DevCPL486.MakeReg(ax, AX, Int32);
2264 DevCPL486.MakeReg(cx, CX, Int32);
2265 DevCPL486.MakeReg(sp, SP, Int32);
2266 DevCPL486.GenPush(ax);
2267 DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE);
2268 l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE);
2269 DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx);
2270 DevCPL486.SetLabel(l1);
2271 DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx);
2272 DevCPL486.GenMove(cx, ax);
2273 DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax);
2274 DevCPL486.GenSub(ax, sp, FALSE);
2275 DevCPL486.GenMove(cx, ax);
2276 DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax);
2277 l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE);
2278 l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1);
2279 DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c);
2280 DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE);
2281 DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE);
2282 DevCPL486.GenJump(ccNE, l1, TRUE);
2283 DevCPL486.SetLabel(l2);
2284 DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE);
2285 x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1;
2286 DevCPL486.GenMove(x, ax);
2287 DevCPL486.GenPush(ax);
2288 DevCPL486.GenMove(x, ax);
2289 DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx);
2290 DevCPL486.GenReturn(0);
2291 name := "$StackAlloc"; DevCPE.OutRefName(name);
2292 END
2293 END InstallStackAlloc;
2295 PROCEDURE Trap* (n: INTEGER);
2296 BEGIN
2297 DevCPL486.GenAssert(ccNever, n)
2298 END Trap;
2300 PROCEDURE Jump* (VAR L: DevCPL486.Label);
2301 BEGIN
2302 DevCPL486.GenJump(ccAlways, L, FALSE)
2303 END Jump;
2305 PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
2306 BEGIN
2307 DevCPL486.GenJump(x.offset, L, FALSE);
2308 END JumpT;
2310 PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
2311 BEGIN
2312 DevCPL486.GenJump(Inverted(x.offset), L, FALSE);
2313 END JumpF;
2315 PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label);
2316 VAR c: DevCPL486.Item; n: INTEGER;
2317 BEGIN
2318 n := high - low + 1;
2319 DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE);
2320 DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x);
2321 DevCPL486.GenJump(ccAE, else, FALSE);
2322 DevCPL486.GenCaseJump(x)
2323 END CaseTableJump;
2325 PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN);
2326 VAR c: DevCPL486.Item;
2327 BEGIN
2328 IF high = low THEN
2329 DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
2330 IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END;
2331 DevCPL486.GenJump(ccE, this, FALSE)
2332 ELSIF first THEN
2333 DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
2334 DevCPL486.GenJump(ccL, else, FALSE);
2335 DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
2336 DevCPL486.GenJump(ccLE, this, FALSE);
2337 ELSE
2338 DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
2339 DevCPL486.GenJump(ccG, else, FALSE);
2340 DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
2341 DevCPL486.GenJump(ccGE, this, FALSE);
2342 END
2343 END CaseJump;
2345 BEGIN
2346 imLevel[0] := 0
2347 END Dev0CPC486.