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