DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / gpcp-linux.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Remove batch
[gpcp-linux.git] / gpcp / ExprDesc.cp
1 (* ==================================================================== *)
2 (* *)
3 (* ExprDesc Module for the Gardens Point Component Pascal Compiler. *)
4 (* Implements Expr. Descriptors that are extensions of Symbols.Expr *)
5 (* Copyright (c) John Gough 1999, 2000. *)
6 (* *)
7 (* ==================================================================== *)
8
9 MODULE ExprDesc;
10
11 IMPORT
12 GPCPcopyright,
13 RTS,
14 Console,
15 Builtin,
16 G := CompState,
17 S := CPascalS,
18 L := LitValue,
19 D := Symbols,
20 I := IdDesc,
21 T := TypeDesc,
22 H := DiagHelper,
23 V := VarSets,
24 FileNames;
25
26 (* ============================================================ *)
27
28 CONST (* expr-kinds *)
29 (* leaves *)
30 qualId* = 0; numLt* = 1; realLt* = 2; charLt* = 3; strLt* = 4;
31 nilLt* = 5; tBool* = 6; fBool* = 7; setLt* = 8; setXp* = 9;
32
33 (* unaries *)
34 deref* = 10; selct* = 11; tCheck* = 12; mkStr* = 13; fnCall* = 14;
35 prCall* = 15; mkBox* = 16; compl* = 17; sprMrk* = 18; neg* = 19;
36 absVl* = 20; entVl* = 21; capCh* = 22; strLen* = 23; strChk* = 24;
37 cvrtUp* = 25; cvrtDn* = 26; oddTst* = 27; mkNStr* = 28; getTp* = 29;
38
39 (* leaves *)
40 typOf* = 30; infLt* = 31; nInfLt* = 32;
41
42 (* binaries *) index* = 32; range* = 33; lenOf* = 34;
43 maxOf* = 35; minOf* = 36; bitAnd* = 37; bitOr* = 38; bitXor* = 39;
44 plus* = 40; minus* = 41; greT* = 42; greEq* = 43; notEq* = 44;
45 lessEq* = 45; lessT* = 46; equal* = 47; isOp* = 48; inOp* = 49;
46 mult* = 50; slash* = 51; modOp* = 52; divOp* = 53; blNot* = 54;
47 blOr* = 55; blAnd* = 56; strCat* = 57; ashInt* = 58; rem0op* = 59;
48 div0op* = 60; lshInt* = 61; rotInt* = 62;
49
50 (* more unaries *)
51 adrOf* = 70;
52
53
54 (* ============================================================ *)
55
56 TYPE
57 LeafX* = POINTER TO EXTENSIBLE RECORD (D.Expr)
58 (* ... inherited from Expr ... ------------- *
59 * kind- : INTEGER; (* tag for unions *)
60 * token* : S.Token; (* exp mark token *)
61 * type* : Type;
62 * ----------------------------------------- *)
63 value* : L.Value;
64 END; (* ------------------------------ *)
65
66 IdLeaf* = POINTER TO RECORD (LeafX)
67 ident* : D.Idnt; (* qualified-idnt *)
68 END;
69
70 SetExp* = POINTER TO RECORD (LeafX)
71 varSeq* : D.ExprSeq;
72 END;
73
74
75 (* ============================================================ *)
76
77 TYPE
78 UnaryX* = POINTER TO EXTENSIBLE RECORD (D.Expr)
79 (* ... inherited from Expr ... ------------- *
80 * kind- : INTEGER; (* tag for unions *)
81 * token* : S.Token; (* exp mark token *)
82 * type* : Type;
83 * ----------------------------------------- *)
84 kid* : D.Expr;
85 END; (* ------------------------------ *)
86
87 IdentX* = POINTER TO RECORD (UnaryX)
88 ident* : D.Idnt; (* field selction *)
89 END;
90
91 CallX* = POINTER TO RECORD (UnaryX)
92 actuals* : D.ExprSeq;
93 END;
94
95 (* ============================================================ *)
96
97 TYPE
98 BinaryX* = POINTER TO RECORD (D.Expr)
99 (* ... inherited from Expr ... ------------- *
100 * kind- : INTEGER; (* tag for unions *)
101 * token* : S.Token; (* exp mark token *)
102 * type* : Type;
103 * ----------------------------------------- *)
104 lKid* : D.Expr;
105 rKid* : D.Expr;
106 END; (* ------------------------------ *)
107
108 (* ============================================================ *)
109
110 PROCEDURE isPowerOf2(val : LONGINT) : BOOLEAN;
111 VAR lo, hi : INTEGER;
112 BEGIN
113 IF val < 0 THEN
114 RETURN FALSE;
115 ELSE
116 lo := RTS.loInt(val);
117 hi := RTS.hiInt(val);
118 IF hi = 0 THEN
119 RETURN BITS(lo) * BITS(-lo) = BITS(lo);
120 ELSIF lo = 0 THEN
121 RETURN BITS(hi) * BITS(-hi) = BITS(hi);
122 ELSE
123 RETURN FALSE;
124 END;
125 END;
126 END isPowerOf2;
127
128 (* -------------------------------------------- *)
129
130 PROCEDURE coverType(a,b : D.Type) : D.Type;
131 BEGIN
132 IF a.includes(b) THEN RETURN a;
133 ELSIF b.includes(a) THEN RETURN b;
134 ELSIF a = Builtin.uBytTp THEN RETURN coverType(Builtin.sIntTp, b);
135 ELSIF b = Builtin.uBytTp THEN RETURN coverType(a, Builtin.sIntTp);
136 ELSE RETURN NIL;
137 END;
138 END coverType;
139
140 (* -------------------------------------------- *)
141
142 PROCEDURE log2(val : LONGINT) : INTEGER;
143 VAR lo, hi, nm : INTEGER;
144 BEGIN
145 lo := RTS.loInt(val);
146 hi := RTS.hiInt(val);
147 IF hi = 0 THEN
148 FOR nm := 0 TO 31 DO
149 IF ODD(lo) THEN RETURN nm ELSE lo := lo DIV 2 END;
150 END;
151 ELSE
152 FOR nm := 32 TO 63 DO
153 IF ODD(hi) THEN RETURN nm ELSE hi := hi DIV 2 END;
154 END;
155 END;
156 THROW("Bad log2 argument");
157 RETURN 0;
158 END log2;
159
160 (* ============================================================ *)
161 PROCEDURE^ (x : LeafX)charValue*() : CHAR,NEW;
162 PROCEDURE^ convert(expr : D.Expr; dstT : D.Type) : D.Expr;
163 PROCEDURE^ FormalsVsActuals*(prcX : D.Expr; actSeq : D.ExprSeq);
164 (* ============================================================ *)
165 (* LeafX Constructor methods *)
166 (* ============================================================ *)
167
168 PROCEDURE mkLeafVal*(k : INTEGER; v : L.Value) : LeafX;
169 VAR n : LeafX;
170 BEGIN
171 NEW(n); n.token := S.prevTok;
172 n.SetKind(k); n.value := v; RETURN n;
173 END mkLeafVal;
174
175 (* -------------------------------------------- *)
176
177 PROCEDURE mkNilX*() : LeafX;
178 VAR n : LeafX;
179 BEGIN
180 NEW(n);
181 n.type := Builtin.anyPtr;
182 n.token := S.prevTok;
183 n.SetKind(nilLt); RETURN n;
184 END mkNilX;
185
186 (* -------------------------------------------- *)
187
188 PROCEDURE mkInfX*() : LeafX;
189 VAR n : LeafX;
190 BEGIN
191 NEW(n);
192 (*
193 * Here is a dirty trick!
194 * We assign this the type SHORTREAL, and trap
195 * the attempt to coerce the value to REAL.
196 * If the value is coerced we assign it the type
197 * Bi.realTp so that the correct constant is emitted.
198 *)
199 n.type := Builtin.sReaTp;
200 n.token := S.prevTok;
201 n.SetKind(infLt); RETURN n;
202 END mkInfX;
203
204 (* -------------------------------------------- *)
205
206 PROCEDURE mkNegInfX*() : LeafX;
207 VAR n : LeafX;
208 BEGIN
209 NEW(n);
210 n.type := Builtin.sReaTp;
211 n.token := S.prevTok;
212 n.SetKind(nInfLt); RETURN n;
213 END mkNegInfX;
214
215 (* -------------------------------------------- *)
216
217 PROCEDURE mkTrueX*() : LeafX;
218 VAR n : LeafX;
219 BEGIN
220 NEW(n);
221 n.type := Builtin.boolTp;
222 n.token := S.prevTok;
223 n.SetKind(tBool); RETURN n;
224 END mkTrueX;
225
226 (* -------------------------------------------- *)
227
228 PROCEDURE mkFalseX*() : LeafX;
229 VAR n : LeafX;
230 BEGIN
231 NEW(n);
232 n.type := Builtin.boolTp;
233 n.token := S.prevTok;
234 n.SetKind(fBool); RETURN n;
235 END mkFalseX;
236
237 (* -------------------------------------------- *)
238
239 PROCEDURE mkIdLeaf*(id : D.Idnt) : IdLeaf;
240 VAR l : IdLeaf;
241 BEGIN
242 NEW(l);
243 (* l.type := NIL; *)
244 l.token := S.prevTok;
245 l.SetKind(qualId); l.ident := id; RETURN l;
246 END mkIdLeaf;
247
248 (* -------------------------------------------- *)
249
250 PROCEDURE mkEmptySet*() : SetExp;
251 VAR l : SetExp;
252 BEGIN
253 NEW(l);
254 l.type := Builtin.setTp;
255 l.token := S.prevTok;
256 l.SetKind(setXp); RETURN l;
257 END mkEmptySet;
258
259 (* -------------------------------------------- *)
260
261 PROCEDURE mkSetLt*(s : SET) : SetExp;
262 VAR l : SetExp;
263 BEGIN
264 NEW(l);
265 l.token := S.prevTok;
266 l.SetKind(setLt);
267 l.type := Builtin.setTp;
268 l.value := L.newSetVal(s); RETURN l;
269 END mkSetLt;
270
271 (* -------------------------------------------- *)
272
273 PROCEDURE mkCharLt*(ch : CHAR) : LeafX;
274 VAR l : LeafX;
275 BEGIN
276 NEW(l);
277 l.token := S.prevTok;
278 l.type := Builtin.charTp;
279 l.SetKind(charLt);
280 l.value := L.newChrVal(ch); RETURN l;
281 END mkCharLt;
282
283 (* -------------------------------------------- *)
284
285 PROCEDURE mkNumLt*(nm : LONGINT) : LeafX;
286 VAR l : LeafX;
287 BEGIN
288 NEW(l);
289 l.token := S.prevTok;
290 l.SetKind(numLt);
291 IF (nm <= MAX(INTEGER)) & (nm >= MIN(INTEGER)) THEN
292 l.type := Builtin.intTp;
293 ELSE
294 l.type := Builtin.lIntTp;
295 END;
296 l.value := L.newIntVal(nm); RETURN l;
297 END mkNumLt;
298
299 (* -------------------------------------------- *)
300
301 PROCEDURE mkRealLt*(rv : REAL) : LeafX;
302 VAR l : LeafX;
303 BEGIN
304 NEW(l);
305 l.token := S.prevTok;
306 l.type := Builtin.realTp;
307 l.SetKind(realLt);
308 l.value := L.newFltVal(rv); RETURN l;
309 END mkRealLt;
310
311 (* -------------------------------------------- *)
312
313 PROCEDURE mkStrLt*(IN sv : ARRAY OF CHAR) : LeafX;
314 VAR l : LeafX;
315 BEGIN
316 NEW(l);
317 l.token := S.prevTok;
318 l.SetKind(strLt);
319 l.type := Builtin.strTp;
320 l.value := L.newStrVal(sv); RETURN l;
321 END mkStrLt;
322
323 (* -------------------------------------------- *)
324
325 PROCEDURE mkStrLenLt*(str : L.CharOpen; len : INTEGER) : LeafX;
326 VAR l : LeafX;
327 BEGIN
328 NEW(l);
329 l.token := S.prevTok;
330 l.SetKind(strLt);
331 l.type := Builtin.strTp;
332 l.value := L.newStrLenVal(str, len); RETURN l;
333 END mkStrLenLt;
334
335 (* -------------------------------------------- *)
336
337 PROCEDURE tokToStrLt*(pos,len : INTEGER) : LeafX;
338 (** Generate a LeafX for this string, stripping off the quote *
339 * characters which surround it in the scanner buffer. *)
340 VAR l : LeafX;
341 BEGIN
342 NEW(l);
343 l.token := S.prevTok;
344 l.SetKind(strLt);
345 l.type := Builtin.strTp;
346 l.value := L.newBufVal(pos+1,len-2); RETURN l;
347 END tokToStrLt;
348
349 (* -------------------------------------------- *)
350
351 PROCEDURE translateStrLt*(pos,len : INTEGER) : LeafX;
352 (** Generate a LeafX for this string, stripping off the quote *
353 * characters which surround it in the scanner buffer. *)
354 VAR l : LeafX;
355 BEGIN
356 NEW(l);
357 l.token := S.prevTok;
358 l.SetKind(strLt);
359 l.type := Builtin.strTp;
360 l.value := L.escapedString(pos+2,len-3); RETURN l;
361 END translateStrLt;
362
363 (* ============================================================ *)
364 (* UnaryX Constructor methods *)
365 (* ============================================================ *)
366
367 PROCEDURE newUnaryX*(tag : INTEGER; kid : D.Expr) : UnaryX;
368 VAR u : UnaryX;
369 BEGIN
370 NEW(u); u.token := S.prevTok;
371 u.SetKind(tag); u.kid := kid; RETURN u;
372 END newUnaryX;
373
374 (* -------------------------------------------- *)
375
376 PROCEDURE mkDeref*(kid : D.Expr) : D.Expr;
377 VAR new : UnaryX;
378 BEGIN
379 new := newUnaryX(deref, kid);
380 new.token := kid.token;
381 new.type := kid.type(T.Pointer).boundTp;
382 RETURN new;
383 END mkDeref;
384
385 (* ---------------------------- *)
386
387 PROCEDURE newIdentX*(tag : INTEGER; id : D.Idnt; kid : D.Expr) : IdentX;
388 VAR u : IdentX;
389 BEGIN
390 NEW(u); u.token := S.prevTok;
391 u.SetKind(tag); u.ident := id; u.kid := kid; RETURN u;
392 END newIdentX;
393
394 (* -------------------------------------------- *)
395
396 PROCEDURE newCallX*(tag : INTEGER; prm : D.ExprSeq; kid : D.Expr) : CallX;
397 VAR u : CallX;
398 BEGIN
399 (*
400 *
401 * NEW(u); u.token := S.prevTok;
402 *
403 * EXPERIMENTAL
404 *)
405 NEW(u); u.token := kid.token;
406 u.SetKind(tag); u.actuals := prm; u.kid := kid; RETURN u;
407 END newCallX;
408
409 (* -------------------------------------------- *)
410
411 PROCEDURE newCallT*(tag : INTEGER; prm : D.ExprSeq;
412 kid : D.Expr; tok : S.Token) : CallX;
413 VAR u : CallX;
414 BEGIN
415 NEW(u); u.token := tok;
416 u.SetKind(tag); u.actuals := prm; u.kid := kid; RETURN u;
417 END newCallT;
418
419 (* ============================================================ *)
420 (* BinaryX Constructor methods *)
421 (* ============================================================ *)
422
423 PROCEDURE newBinaryX*(tag : INTEGER; lSub,rSub : D.Expr) : BinaryX;
424 VAR b : BinaryX;
425 BEGIN
426 NEW(b); b.token := S.prevTok;
427 b.SetKind(tag); b.lKid := lSub; b.rKid := rSub; RETURN b;
428 END newBinaryX;
429
430 (* -------------------------------------------- *)
431
432 PROCEDURE newBinaryT*(k : INTEGER; l,r : D.Expr; t : S.Token) : BinaryX;
433 VAR b : BinaryX;
434 BEGIN
435 NEW(b); b.token := t;
436 b.SetKind(k); b.lKid := l; b.rKid := r; RETURN b;
437 END newBinaryT;
438
439 (* -------------------------------------------- *)
440
441 PROCEDURE maxOfType*(t : T.Base) : LeafX;
442 BEGIN
443 CASE t.tpOrd OF
444 | T.byteN : RETURN mkNumLt(MAX(BYTE));
445 | T.uBytN : RETURN mkNumLt(255);
446 | T.sIntN : RETURN mkNumLt(MAX(SHORTINT));
447 | T.intN : RETURN mkNumLt(MAX(INTEGER));
448 | T.lIntN : RETURN mkNumLt(MAX(LONGINT));
449 | T.sReaN : RETURN mkRealLt(MAX(SHORTREAL));
450 | T.realN : RETURN mkRealLt(MAX(REAL));
451 | T.sChrN : RETURN mkCharLt(MAX(SHORTCHAR));
452 | T.charN : RETURN mkCharLt(MAX(CHAR));
453 | T.setN : RETURN mkNumLt(31);
454 ELSE
455 RETURN NIL;
456 END;
457 END maxOfType;
458
459 (* -------------------------------------------- *)
460
461 PROCEDURE minOfType*(t : T.Base) : LeafX;
462 BEGIN
463 CASE t.tpOrd OF
464 | T.byteN : RETURN mkNumLt(MIN(BYTE));
465 | T.uBytN : RETURN mkNumLt(0);
466 | T.sIntN : RETURN mkNumLt(MIN(SHORTINT));
467 | T.intN : RETURN mkNumLt(MIN(INTEGER));
468 | T.lIntN : RETURN mkNumLt(MIN(LONGINT));
469 | T.sReaN : RETURN mkRealLt(-MAX(SHORTREAL)); (* for bootstrap *)
470 | T.realN : RETURN mkRealLt(-MAX(REAL)); (* for bootstrap *)
471 (*
472 * | T.sReaN : RETURN mkRealLt(MIN(SHORTREAL)); (* production version *)
473 * | T.realN : RETURN mkRealLt(MIN(REAL)); (* production version *)
474 *)
475 | T.sChrN,
476 T.charN : RETURN mkCharLt(0X);
477 | T.setN : RETURN mkNumLt(0);
478 ELSE
479 RETURN NIL;
480 END;
481 END minOfType;
482
483 (* ============================================================ *)
484
485 PROCEDURE coerceUp*(x : D.Expr; t : D.Type) : D.Expr;
486 (*
487 * Fix to string arrays coerced to native strings: kjg April 2006
488 *)
489 BEGIN
490 IF x.kind = realLt THEN RETURN x;
491 ELSIF (t = G.ntvStr) OR (t = G.ntvObj) & x.isString() THEN
492 RETURN newUnaryX(mkNStr, x);
493 ELSIF x.kind = numLt THEN
494 IF ~t.isRealType() THEN
495 x.type := t; RETURN x;
496 ELSE
497 RETURN mkRealLt(x(LeafX).value.long());
498 END;
499 ELSIF x.isInf() THEN
500 x.type := t; RETURN x;
501 ELSE
502 RETURN convert(x, t);
503 END;
504 END coerceUp;
505
506 (* ============================================================ *)
507 (* Various attribution methods *)
508 (* ============================================================ *)
509
510 PROCEDURE (i : LeafX)TypeErase*() : D.Expr, EXTENSIBLE;
511 (* If the type of the leaf is a compound, it must be erased *)
512 BEGIN
513 IF i.type.isCompoundType() THEN
514 Console.WriteString("FOUND A COMPOUND LEAFX!");Console.WriteLn;
515 END;
516 RETURN i;
517 END TypeErase;
518
519 PROCEDURE (i : IdLeaf)TypeErase*() : D.Expr;
520 BEGIN
521 RETURN i;
522 END TypeErase;
523
524 PROCEDURE (i : SetExp)TypeErase*() : D.Expr;
525 VAR
526 exprN : D.Expr;
527 index : INTEGER;
528 BEGIN
529 FOR index := 0 TO i.varSeq.tide - 1 DO
530 exprN := i.varSeq.a[index];
531 IF exprN # NIL THEN
532 exprN := exprN.TypeErase();
533 END;
534 END;
535 RETURN i;
536 END TypeErase;
537
538 PROCEDURE (i : UnaryX)TypeErase*() : D.Expr,EXTENSIBLE;
539 BEGIN
540 IF i.kid = NIL THEN RETURN NIL END;
541 i.kid := i.kid.TypeErase();
542 IF i.kid = NIL THEN RETURN NIL END;
543 RETURN i;
544 END TypeErase;
545
546 PROCEDURE (i : IdentX)TypeErase*() : D.Expr;
547 BEGIN
548 (* If the IdentX is a type assertion node, and
549 * the assertion is to a compound type, replace
550 * the IdentX with a sequance of assertions *)
551 IF i.kind = tCheck THEN
552 (* IF i.ident.... *)
553 END;
554 RETURN i; END TypeErase;
555
556 PROCEDURE (i : CallX)TypeErase*() : D.Expr;
557 VAR
558 exprN : D.Expr;
559 index : INTEGER;
560 BEGIN
561 FOR index := 0 TO i.actuals.tide - 1 DO
562 exprN := i.actuals.a[index];
563 IF exprN # NIL THEN
564 exprN := exprN.TypeErase();
565 END;
566 END;
567 RETURN i;
568 END TypeErase;
569
570 PROCEDURE (i : BinaryX)TypeErase*() : D.Expr;
571 VAR rslt : D.Expr;
572 BEGIN
573 IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
574 i.lKid := i.lKid.TypeErase(); (* process subtree *)
575 i.rKid := i.rKid.TypeErase(); (* process subtree *)
576 IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
577 RETURN i;
578 END TypeErase;
579
580 (* -------------------------------------------- *)
581
582 PROCEDURE isRelop(op : INTEGER) : BOOLEAN;
583 BEGIN
584 RETURN (op = equal) OR (op = notEq) OR (op = lessEq) OR
585 (op = lessT) OR (op = greEq) OR (op = greT) OR
586 (op = inOp) OR (op = isOp);
587 END isRelop;
588
589 (* -------------------------------------------- *)
590
591 PROCEDURE getQualType*(exp : D.Expr) : D.Type;
592 (* Return the qualified type with TypId descriptor in the *
593 * IdLeaf exp, otherwise return the NIL pointer. *)
594 VAR leaf : IdLeaf;
595 tpId : D.Idnt;
596 BEGIN
597 IF ~(exp IS IdLeaf) THEN RETURN NIL END;
598 leaf := exp(IdLeaf);
599 IF ~(leaf.ident IS I.TypId) THEN RETURN NIL END;
600 tpId := leaf.ident;
601 RETURN tpId.type;
602 END getQualType;
603
604 (* -------------------------------------------- *)
605
606 PROCEDURE CheckIsVariable*(e : D.Expr);
607 VAR
608 isVar : BOOLEAN;
609 BEGIN
610 IF (e = NIL) THEN RETURN; END;
611 WITH e : IdentX DO
612 IF e.ident IS I.OvlId THEN e.ident := e.ident(I.OvlId).fld; END;
613 isVar := (e.ident # NIL) & (e.ident IS I.FldId);
614 | e : IdLeaf DO
615 IF e.ident IS I.OvlId THEN e.ident := e.ident(I.OvlId).fld; END;
616 isVar := (e.ident # NIL) & ((e.ident IS I.VarId) OR (e.ident IS I.LocId));
617 | e : BinaryX DO
618 isVar := e.kind = index;
619 | e : UnaryX DO
620 IF e.kind = tCheck THEN
621 isVar := TRUE;
622 e.ExprError(222);
623 ELSE
624 isVar := e.kind = deref;
625 END;
626 ELSE
627 isVar := FALSE;
628 END;
629 IF (~isVar) THEN e.ExprError(85); END;
630 END CheckIsVariable;
631
632 (* -------------------------------------------- *)
633
634 PROCEDURE (i : LeafX)exprAttr*() : D.Expr,EXTENSIBLE;
635 BEGIN (* most of these are done already ... *)
636 IF (i.kind = numLt) & i.inRangeOf(Builtin.intTp) THEN
637 i.type := Builtin.intTp;
638 END;
639 RETURN i;
640 END exprAttr;
641
642 (* -------------------------------------------- *)
643
644 PROCEDURE (i : IdLeaf)exprAttr*() : D.Expr;
645 (* If this references a constant, then return literal *)
646 (* ----------------------------------------- *)
647 PROCEDURE constClone(i : IdLeaf) : D.Expr;
648 VAR conXp : D.Expr;
649 clone : LeafX;
650 (* ----------------------------------------- *
651 * We must clone the literal rather than *
652 * just take a reference copy, as it may *
653 * appear in a later error message. If it *
654 * does, it needs to have correct line:col. *
655 * ----------------------------------------- *)
656 BEGIN
657 conXp := i.ident(I.ConId).conExp;
658 WITH conXp : SetExp DO
659 clone := mkSetLt({});
660 clone.value := conXp.value;
661 | conXp : LeafX DO
662 clone := mkLeafVal(conXp.kind, conXp.value);
663 clone.type := conXp.type;
664 END;
665 clone.token := i.token;
666 RETURN clone;
667 END constClone;
668 (* --------------------------------- *)
669 BEGIN
670 IF (i.ident # NIL) & (i.ident IS I.ConId) THEN
671 IF i.ident(I.ConId).isStd THEN
672 IF i.ident = Builtin.trueC THEN RETURN mkTrueX();
673 ELSIF i.ident = Builtin.falsC THEN RETURN mkFalseX();
674 ELSIF i.ident = Builtin.nilC THEN RETURN mkNilX();
675 ELSIF i.ident = Builtin.infC THEN RETURN mkInfX();
676 ELSIF i.ident = Builtin.nInfC THEN RETURN mkNegInfX();
677 ELSE i.ExprError(19); RETURN NIL;
678 END;
679 ELSE
680 RETURN constClone(i);
681 END;
682 ELSE
683 RETURN i;
684 END;
685 END exprAttr;
686
687 (* -------------------------------------------- *)
688
689 PROCEDURE (i : SetExp)exprAttr*() : D.Expr;
690 VAR exprN : D.Expr; (* the n-th expression *)
691 index : INTEGER; (* reading index *)
692 write : INTEGER; (* writing index *)
693 cPart : SET; (* constant accumulator *)
694 rngXp : BinaryX;
695 num : INTEGER;
696
697 (* ----------------------------------- *)
698
699 PROCEDURE isLitRange(exp : BinaryX) : BOOLEAN;
700 BEGIN
701 RETURN (exp.lKid # NIL) &
702 (exp.rKid # NIL) &
703 (exp.lKid.kind = numLt) &
704 (exp.rKid.kind = numLt);
705 END isLitRange;
706
707 (* ----------------------------------- *)
708
709 PROCEDURE mkSetFromRange(exp : BinaryX) : SET;
710 VAR ln,rn : INTEGER;
711 BEGIN
712 ln := exp.lKid(LeafX).value.int();
713 rn := exp.rKid(LeafX).value.int();
714 IF (ln > 31) OR (ln < 0) THEN exp.lKid.ExprError(28); RETURN {} END;
715 IF (rn > 31) OR (rn < 0) THEN exp.rKid.ExprError(29); RETURN {} END;
716 IF rn < ln THEN exp.ExprError(30); RETURN {} END;
717 RETURN {ln .. rn}
718 END mkSetFromRange;
719
720 (* ----------------------------------- *)
721
722 BEGIN (* body of (i : SetExp)exprAttr *)
723 write := 0;
724 cPart := {};
725 FOR index := 0 TO i.varSeq.tide - 1 DO
726 exprN := i.varSeq.a[index];
727 IF exprN # NIL THEN
728 exprN := exprN.exprAttr();
729 IF exprN.kind = numLt THEN (* singleton element *)
730 num := exprN(LeafX).value.int();
731 IF (num < 32) & (num >= 0) THEN
732 INCL(cPart, num);
733 ELSE
734 exprN.ExprError(303);
735 END;
736 ELSIF exprN.kind = range THEN
737 rngXp := exprN(BinaryX);
738 IF isLitRange(rngXp) THEN (* const elem range *)
739 cPart := cPart + mkSetFromRange(rngXp);
740 ELSE
741 IF ~rngXp.lKid.isIntExpr() THEN rngXp.lKid.ExprError(37) END;
742 IF ~rngXp.rKid.isIntExpr() THEN rngXp.rKid.ExprError(37) END;
743 i.varSeq.a[write] := exprN; INC(write);
744 END;
745 ELSE (* variable element(s) *)
746 IF ~exprN.isIntExpr() THEN exprN.ExprError(37) END;
747 i.varSeq.a[write] := exprN; INC(write);
748 END;
749 END;
750 END;
751 IF write # i.varSeq.tide THEN (* expression changed *)
752 i.value := L.newSetVal(cPart);
753 IF write = 0 THEN (* set is all constant *)
754 i.SetKind(setLt);
755 END;
756 i.varSeq.ResetTo(write); (* truncate elem list *)
757 ELSIF write = 0 THEN (* this is empty set *)
758 i.SetKind(setLt);
759 END;
760 i.type := Builtin.setTp;
761 RETURN i;
762 END exprAttr;
763
764 (* -------------------------------------------- *)
765
766 PROCEDURE (i : UnaryX)exprAttr*() : D.Expr,EXTENSIBLE;
767 VAR leaf : LeafX;
768 rslt : D.Expr;
769 BEGIN
770 IF i.kid = NIL THEN RETURN NIL END;
771 i.kid := i.kid.exprAttr();
772 IF i.kid = NIL THEN RETURN NIL END;
773 rslt := i;
774 CASE i.kind OF
775 | neg : (* Fold constants and mark sets *)
776 IF i.kid.kind = setXp THEN
777 i.SetKind(compl);
778 i.type := Builtin.setTp;
779 ELSIF i.kid.kind = setLt THEN
780 leaf := i.kid(LeafX);
781 leaf.value := L.newSetVal(-leaf.value.set());
782 rslt := leaf;
783 ELSIF i.kid.kind = numLt THEN
784 leaf := i.kid(LeafX);
785 leaf.value := L.newIntVal(-leaf.value.long());
786 rslt := leaf;
787 ELSIF i.kid.kind = realLt THEN
788 leaf := i.kid(LeafX);
789 leaf.value := L.newFltVal(-leaf.value.real());
790 rslt := leaf;
791 ELSE
792 i.type := i.kid.type;
793 END;
794 | blNot : (* Type check subtree, and fold consts *)
795 IF i.kid.type # Builtin.boolTp THEN i.ExprError(36) END;
796 IF i.kid.kind = blNot THEN (* fold double negation *)
797 rslt := i.kid(UnaryX).kid;
798 ELSIF i.kid.kind = tBool THEN
799 rslt := mkFalseX();
800 ELSIF i.kid.kind = fBool THEN
801 rslt := mkTrueX();
802 ELSE
803 i.type := Builtin.boolTp;
804 END;
805 ELSE (* Nothing to do. Parser did type check already *)
806 (* mkStr, absVl, convert, capCh, entVl, strLen, lenOf, oddTst *)
807 (* tCheck *)
808 END;
809 RETURN rslt;
810 END exprAttr;
811
812 (* -------------------------------------------- *)
813
814 PROCEDURE (i : IdentX)exprAttr*() : D.Expr;
815 BEGIN
816 IF (i.kind = selct) & (i.ident # NIL) & (i.ident IS I.ConId) THEN
817 RETURN i.ident(I.ConId).conExp.exprAttr();
818 ELSE
819 ASSERT((i.kind = selct) OR
820 (i.kind = cvrtUp) OR (i.kind = cvrtDn));
821 RETURN i;
822 END;
823 END exprAttr;
824
825 (* -------------------------------------------- *)
826
827 PROCEDURE (i : CallX)exprAttr*() : D.Expr;
828 (* fnCall nodes are attributed during parsing of the designator *
829 * so there is nothing left to do here. Do not recurse further down. *)
830 BEGIN RETURN i END exprAttr;
831
832 (* -------------------------------------------- *)
833
834 PROCEDURE checkCall*(i : CallX) : D.Expr;
835 VAR prTp : T.Procedure;
836 prXp : D.Expr;
837
838 (* --------------------------- *)
839
840 PROCEDURE length(arg0 : D.Expr; arg1 : LeafX) : D.Expr;
841 VAR dimN : INTEGER;
842 dIdx : INTEGER;
843 cTyp : D.Type;
844 cLen : INTEGER;
845 BEGIN
846 dimN := arg1.value.int();
847 IF dimN < 0 THEN arg1.ExprError(46); RETURN NIL END;
848
849 (*
850 * Take care of LEN(typename) case ... kjg December 2004
851 *)
852 WITH arg0 : IdLeaf DO
853 IF arg0.ident IS I.TypId THEN arg0.type := arg0.ident.type END;
854 ELSE
855 END;
856
857 IF arg0.type.kind = T.ptrTp THEN arg0 := mkDeref(arg0) END;
858 cLen := 0;
859 cTyp := arg0.type;
860 IF cTyp.kind = T.vecTp THEN
861 IF dimN # 0 THEN arg1.ExprError(231) END;
862 ELSE
863 FOR dIdx := 0 TO dimN DO
864 IF cTyp.kind = T.arrTp THEN
865 cLen := cTyp(T.Array).length;
866 cTyp := cTyp(T.Array).elemTp;
867 ELSE
868 arg1.ExprError(40); RETURN NIL;
869 END;
870 END;
871 END;
872 IF cLen = 0 THEN (* must compute at runtime *)
873 RETURN newBinaryX(lenOf, arg0, arg1);
874 ELSE
875 RETURN mkNumLt(cLen);
876 END;
877 END length;
878
879 (* --------------------------- *)
880
881 PROCEDURE stdFunction(i : CallX; act : D.ExprSeq) : D.Expr;
882 (* Assert: prc holds a procedure ident descriptor of a standard Fn. *)
883 VAR prc : IdLeaf;
884 funI : I.PrcId;
885 rslt : D.Expr;
886 leaf : LeafX;
887 arg0 : D.Expr;
888 arg1 : D.Expr;
889 typ0 : D.Type;
890 dstT : D.Type;
891 funN : INTEGER;
892 lVal : LONGINT;
893 rVal : REAL;
894 ptrT : T.Pointer;
895 BEGIN
896 prc := i.kid(IdLeaf);
897 rslt := NIL;
898 arg0 := NIL;
899 arg1 := NIL;
900 funI := prc.ident(I.PrcId);
901 funN := funI.stdOrd;
902 IF act.tide >= 1 THEN
903 arg0 := act.a[0];
904 IF arg0 # NIL THEN arg0 := arg0.exprAttr() END;
905 IF act.tide >= 2 THEN
906 arg1 := act.a[1];
907 IF arg1 # NIL THEN arg1 := arg1.exprAttr() END;
908 IF arg1 = NIL THEN RETURN NIL END;
909 END;
910 IF arg0 = NIL THEN RETURN NIL END;
911 END;
912 (*
913 * Now we check the per-case semantics.
914 *)
915 CASE funN OF
916 (* ---------------------------- *)
917 | Builtin.absP :
918 IF act.tide = 0 THEN prc.ExprError(22);
919 ELSIF act.tide > 1 THEN prc.ExprError(23);
920 ELSE
921 IF arg0.isNumericExpr() THEN
922 IF arg0.kind = numLt THEN
923 leaf := arg0(LeafX); leaf.value := L.absV(leaf.value);
924 IF leaf.value = NIL THEN arg0.ExprError(39)END;
925 rslt := leaf;
926 ELSIF arg0.kind = realLt THEN
927 rslt := mkRealLt(ABS(arg0(LeafX).value.real()));
928 ELSE
929 rslt := newUnaryX(absVl, arg0);
930 END;
931 rslt.type := arg0.type;
932 ELSE
933 arg0.ExprError(38);
934 END;
935 END;
936 (* ---------------------------- *)
937 (* Extended to LONGINT (1:01:2013) *)
938 (* ---------------------------- *)
939 | Builtin.ashP :
940 IF act.tide < 2 THEN prc.ExprError(22);
941 ELSIF act.tide > 2 THEN prc.ExprError(23);
942 ELSE
943 IF ~arg0.isIntExpr() THEN arg0.ExprError(37) END;
944 IF ~arg1.isIntExpr() THEN arg1.ExprError(37) END;
945 (* NO FOLDING IN THIS VERSION
946 IF (arg0.kind = numLt) & (arg1.kind = numLt) THEN
947 rslt := mkNumLt(ASH(arg0(LeafX).value.int(),
948 arg1(LeafX).value.int()));
949 ELSE
950 *)
951 IF arg0.type = Builtin.lIntTp THEN
952 dstT := Builtin.lIntTp;
953 ELSE
954 IF arg0.type # Builtin.intTp THEN
955 arg0 := convert(arg0, Builtin.intTp);
956 END;
957 dstT := Builtin.intTp;
958 END;
959 IF arg1.type # Builtin.intTp THEN
960 arg1 := convert(arg1, Builtin.intTp);
961 END;
962 rslt := newBinaryX(ashInt, arg0, arg1);
963 (*
964 END;
965 *)
966 rslt.type := dstT;
967 END;
968 (* ---------------------------- *)
969 | Builtin.lshP :
970 IF act.tide < 2 THEN prc.ExprError(22);
971 ELSIF act.tide > 2 THEN prc.ExprError(23);
972 ELSE
973 IF ~arg0.isIntExpr() THEN arg0.ExprError(37) END;
974 IF ~arg1.isIntExpr() THEN arg1.ExprError(37) END;
975 (* FIXME, no folding yet ... *)
976 IF arg0.type = Builtin.lIntTp THEN
977 dstT := Builtin.lIntTp;
978 ELSE
979 IF arg0.type # Builtin.intTp THEN
980 arg0 := convert(arg0, Builtin.intTp);
981 END;
982 dstT := Builtin.intTp;
983 END;
984 IF arg1.type # Builtin.intTp THEN
985 arg1 := convert(arg1, Builtin.intTp);
986 END;
987 rslt := newBinaryX(lshInt, arg0, arg1);
988 rslt.type := dstT;
989 END;
990 (* ---------------------------- *)
991 | Builtin.rotP :
992 IF act.tide < 2 THEN prc.ExprError(22);
993 ELSIF act.tide > 2 THEN prc.ExprError(23);
994 ELSE
995 IF ~arg0.isIntExpr() THEN arg0.ExprError(37) END;
996 IF ~arg1.isIntExpr() THEN arg1.ExprError(37) END;
997 (* Do not convert arg0 to intTp *)
998 IF arg1.type # Builtin.intTp THEN
999 arg1 := convert(arg1, Builtin.intTp);
1000 END;
1001 rslt := newBinaryX(rotInt, arg0, arg1);
1002 rslt.type := arg0.type;
1003 END;
1004 (* ---------------------------- *)
1005 | Builtin.bitsP :
1006 IF act.tide < 1 THEN prc.ExprError(22);
1007 ELSIF act.tide > 1 THEN prc.ExprError(23);
1008 ELSE
1009 rslt := arg0;
1010 IF rslt.isIntExpr() THEN
1011 (*
1012 * BITS accepts an integer expression
1013 * which may be either short or long.
1014 * In the case of short values these
1015 * are sign-extended to 32 bits.
1016 * In the case of long values gpcp
1017 * performs an unsigned conversion to
1018 * uint32, capturing the 32 least
1019 * significant bits of the long value.
1020 *)
1021 IF rslt.kind = numLt THEN
1022 (* Pull out ALL of the bits of the numLt. *)
1023 (* At compile-time gpcp will convert from *)
1024 (* int64 to uint32 using the elsepart below *)
1025 rslt := mkSetLt(BITS(arg0(LeafX).value.long()));
1026 rslt.type := Builtin.setTp;
1027 ELSE
1028 (* Graft an unchecked conversion onto the *)
1029 (* root of the argument expression tree. *)
1030 rslt := convert(rslt, Builtin.setTp);
1031 END;
1032 ELSE
1033 arg0.ExprError(56);
1034 END;
1035 END;
1036 (* ---------------------------- *)
1037 | Builtin.capP :
1038 IF act.tide = 0 THEN prc.ExprError(22);
1039 ELSIF act.tide > 1 THEN prc.ExprError(23);
1040 ELSE
1041 IF arg0.isCharExpr() THEN
1042 IF arg0.isCharLit() THEN
1043 rslt := mkCharLt(CAP(arg0(LeafX).charValue()));
1044 ELSE
1045 rslt := newUnaryX(capCh, arg0);
1046 END;
1047 rslt.type := Builtin.charTp;
1048 ELSE
1049 arg0.ExprError(43);
1050 END;
1051 END;
1052 (* ---------------------------- *)
1053 | Builtin.chrP :
1054 IF act.tide = 0 THEN prc.ExprError(22);
1055 ELSIF act.tide > 1 THEN prc.ExprError(23);
1056 ELSE
1057 IF arg0.isIntExpr() THEN
1058 IF arg0.kind = numLt THEN
1059 lVal := arg0(LeafX).value.long();
1060 IF (lVal >= 0) & (lVal <= LONG(ORD(MAX(CHAR)))) THEN
1061 rslt := mkCharLt(CHR(lVal));
1062 rslt.type := Builtin.charTp;
1063 ELSE
1064 arg0.ExprError(44);
1065 END;
1066 ELSE
1067 rslt := convert(arg0, Builtin.charTp);
1068 END;
1069 ELSE
1070 arg0.ExprError(37);
1071 END;
1072 END;
1073 (* ---------------------------- *)
1074 | Builtin.entP :
1075 IF act.tide = 0 THEN prc.ExprError(22);
1076 ELSIF act.tide > 1 THEN prc.ExprError(23);
1077 ELSE
1078 dstT := Builtin.lIntTp;
1079 IF arg0.isRealExpr() THEN
1080 IF arg0.kind = realLt THEN
1081 leaf := mkLeafVal(numLt, L.entV(arg0(LeafX).value));
1082 IF leaf.value = NIL THEN
1083 arg0.ExprError(55);
1084 ELSIF i.inRangeOf(Builtin.intTp) THEN
1085 dstT := Builtin.intTp;
1086 END;
1087 rslt := leaf;
1088 ELSE
1089 rslt := newUnaryX(entVl, arg0);
1090 END;
1091 rslt.type := dstT;
1092 ELSE
1093 arg0.ExprError(45);
1094 END;
1095 END;
1096 (* ---------------------------- *)
1097 | Builtin.lenP :
1098 IF act.tide = 0 THEN prc.ExprError(22);
1099 ELSIF act.tide > 2 THEN prc.ExprError(23);
1100 ELSIF act.tide = 1 THEN
1101 IF arg0.kind = strLt THEN
1102 rslt := mkNumLt(arg0(LeafX).value.len());
1103 ELSIF arg0.kind = mkStr THEN
1104 rslt := newUnaryX(strLen, arg0);
1105 ELSE (* add default dimension *)
1106 D.AppendExpr(act, mkNumLt(0));
1107 END;
1108 END;
1109 IF act.tide = 2 THEN
1110 arg1 := act.a[1];
1111 IF arg1.kind = numLt THEN
1112 rslt := length(arg0, arg1(LeafX));
1113 ELSE
1114 arg1.ExprError(46);
1115 END;
1116 END;
1117 IF rslt # NIL THEN rslt.type := Builtin.intTp END;
1118 (* ---------------------------- *)
1119 | Builtin.tpOfP :
1120 IF G.strict THEN prc.ExprError(221); END;
1121 IF act.tide = 0 THEN prc.ExprError(22);
1122 ELSIF act.tide > 1 THEN prc.ExprError(23);
1123 ELSIF arg0.type = Builtin.metaTp THEN
1124 ASSERT(arg0 IS IdLeaf);
1125 rslt := arg0;
1126 rslt.SetKind(typOf);
1127 ELSIF arg0.isVarDesig() THEN
1128 IF arg0.type.isDynamicType() THEN
1129 rslt := newUnaryX(getTp, arg0);
1130 ELSE
1131 dstT := arg0.type;
1132 IF dstT.idnt = NIL THEN (* Anonymous type *)
1133 dstT.idnt := I.newAnonId(dstT.serial);
1134 dstT.idnt.type := dstT;
1135 END;
1136 rslt := mkIdLeaf(dstT.idnt);
1137 rslt.SetKind(typOf);
1138 END;
1139 ELSE arg0.ExprError(85);
1140 END;
1141 IF rslt # NIL THEN rslt.type := G.ntvTyp END;
1142 (* ---------------------------- *)
1143 | Builtin.adrP :
1144 IF G.strict THEN prc.ExprError(221); END;
1145 IF act.tide = 0 THEN prc.ExprError(22);
1146 ELSIF act.tide > 1 THEN prc.ExprError(23);
1147 ELSIF arg0.isVarDesig() THEN
1148 rslt := newUnaryX(adrOf, arg0);
1149 ELSE arg0.ExprError(85);
1150 END;
1151 IF rslt # NIL THEN rslt.type := Builtin.intTp END;
1152 (* ---------------------------- *)
1153 | Builtin.maxP,
1154 Builtin.minP :
1155 IF act.tide = 0 THEN prc.ExprError(22);
1156 ELSIF act.tide > 2 THEN prc.ExprError(23);
1157 ELSIF act.tide = 1 THEN (* should be the MAX(TypeName) case *)
1158 dstT := getQualType(arg0);
1159 IF dstT.kind # T.basTp THEN prc.ExprError(48) END;
1160 IF funN = Builtin.maxP THEN
1161 rslt := maxOfType(dstT(T.Base));
1162 ELSE
1163 rslt := minOfType(dstT(T.Base));
1164 END;
1165 IF rslt # NIL THEN rslt.type := dstT END;
1166 ELSE (* must be the MAX(exp1, exp2) case *)
1167 (*
1168 * Note that for literals, coverType is always >= int.
1169 *)
1170 dstT := coverType(arg0.type, arg1.type);
1171 IF dstT = NIL THEN arg0.ExprError(38);
1172 ELSIF (arg0.kind = numLt) & (arg1.kind = numLt) THEN
1173 IF funN = Builtin.maxP THEN
1174 lVal := MAX(arg0(LeafX).value.long(),arg1(LeafX).value.long());
1175 ELSE
1176 lVal := MIN(arg0(LeafX).value.long(),arg1(LeafX).value.long());
1177 END;
1178 rslt := mkNumLt(lVal);
1179 ELSIF (arg0.kind = realLt) & (arg1.kind = realLt) THEN
1180 IF funN = Builtin.maxP THEN
1181 rVal := MAX(arg0(LeafX).value.real(),arg1(LeafX).value.real());
1182 ELSE
1183 rVal := MIN(arg0(LeafX).value.real(),arg1(LeafX).value.real());
1184 END;
1185 rslt := mkRealLt(rVal);
1186 ELSE
1187 IF arg0.type # dstT THEN arg0 := convert(arg0, dstT) END;
1188 IF arg1.type # dstT THEN arg1 := convert(arg1, dstT) END;
1189 IF funN = Builtin.maxP THEN
1190 rslt := newBinaryX(maxOf, arg0, arg1)
1191 ELSE
1192 rslt := newBinaryX(minOf, arg0, arg1)
1193 END;
1194 END;
1195 IF rslt # NIL THEN rslt.type := dstT END;
1196 END;
1197 (* ---------------------------- *)
1198 | Builtin.oddP :
1199 IF act.tide = 0 THEN prc.ExprError(22);
1200 ELSIF act.tide > 1 THEN prc.ExprError(23);
1201 ELSE
1202 rslt := arg0;
1203 IF ~rslt.isIntExpr() THEN rslt.ExprError(37);
1204 ELSIF rslt.kind = numLt THEN (* calculate right now *)
1205 IF ODD(rslt(LeafX).value.int()) THEN
1206 rslt := mkTrueX();
1207 ELSE
1208 rslt := mkFalseX();
1209 END;
1210 ELSE (* else leave to runtime*)
1211 rslt := newUnaryX(oddTst, rslt);
1212 END;
1213 rslt.type := Builtin.boolTp;
1214 END;
1215 (* ---------------------------- *)
1216 | Builtin.ordP :
1217 IF act.tide = 0 THEN prc.ExprError(22);
1218 ELSIF act.tide > 1 THEN prc.ExprError(23);
1219 ELSE
1220 rslt := arg0;
1221 IF rslt.isCharLit() THEN
1222 rslt := mkNumLt(ORD(rslt(LeafX).charValue()));
1223 ELSIF rslt.kind = setLt THEN
1224 rslt := mkNumLt(rslt(LeafX).value.int());
1225 ELSIF rslt.isCharExpr() OR rslt.isSetExpr() THEN
1226 rslt := convert(rslt, Builtin.intTp);
1227 ELSE
1228 prc.ExprError(50);
1229 END;
1230 rslt.type := Builtin.intTp;
1231 END;
1232 (* ---------------------------- *)
1233 | Builtin.uBytP :
1234 IF act.tide = 0 THEN prc.ExprError(22);
1235 ELSIF act.tide > 1 THEN prc.ExprError(23);
1236 ELSE
1237 rslt := arg0;
1238 dstT := Builtin.uBytTp;
1239 IF rslt.kind = numLt THEN
1240 IF ~rslt.inRangeOf(dstT) THEN rslt.ExprError(26) END;
1241 ELSIF arg0.isNumericExpr() THEN
1242 rslt := convert(rslt, dstT);
1243 ELSE
1244 rslt.ExprError(226);
1245 END;
1246 rslt.type := dstT;
1247 END;
1248 (* ---------------------------- *)
1249 | Builtin.mStrP :
1250 IF G.strict THEN prc.ExprError(221); END;
1251 IF act.tide = 0 THEN prc.ExprError(22);
1252 ELSIF act.tide > 1 THEN prc.ExprError(23);
1253 ELSIF ~arg0.isString() & ~arg0.isCharArray() THEN
1254 arg0.ExprError(41);
1255 END;
1256 rslt := newUnaryX(mkNStr, arg0);
1257 rslt.type := G.ntvStr;
1258 (* ---------------------------- *)
1259 | Builtin.boxP :
1260 IF G.strict THEN prc.ExprError(221); END;
1261 IF act.tide = 0 THEN prc.ExprError(22);
1262 ELSIF act.tide > 1 THEN prc.ExprError(23);
1263 ELSE
1264 typ0 := arg0.type;
1265 rslt := newUnaryX(mkBox, arg0);
1266 WITH typ0 : T.Record DO
1267 IF D.isFn IN typ0.xAttr THEN
1268 ptrT := G.ntvObj(T.Pointer);
1269 ELSE
1270 ptrT := T.newPtrTp();
1271 ptrT.boundTp := typ0;
1272 END;
1273 | typ0 : T.Array DO
1274 ptrT := T.newPtrTp();
1275 IF typ0.length = 0 THEN (* typ0 already an open array *)
1276 ptrT.boundTp := typ0;
1277 ELSE (* corresponding open array *)
1278 ptrT.boundTp := T.mkArrayOf(typ0.elemTp);
1279 END;
1280 ELSE
1281 ptrT := T.newPtrTp();
1282 IF typ0.isStringType() THEN
1283 ptrT.boundTp := Builtin.chrArr;
1284 ELSE
1285 arg0.ExprError(140);
1286 END;
1287 END;
1288 rslt.type := ptrT;
1289 END;
1290 (* ---------------------------- *)
1291 | Builtin.shrtP :
1292 IF act.tide = 0 THEN prc.ExprError(22);
1293 ELSIF act.tide > 1 THEN prc.ExprError(23);
1294 ELSE
1295 rslt := arg0;
1296 IF rslt.kind = charLt THEN (* do right away *)
1297 IF ~rslt.inRangeOf(Builtin.sChrTp) THEN rslt.ExprError(168) END;
1298 rslt.type := Builtin.sChrTp;
1299 ELSIF rslt.kind = strLt THEN (* do right away *)
1300 IF ~L.isShortStr(rslt(LeafX).value) THEN
1301 rslt.ExprError(168) END;
1302 rslt.type := Builtin.sStrTp;
1303 ELSIF rslt.type = Builtin.strTp THEN (* do at runtime *)
1304 rslt := newUnaryX(strChk, rslt);
1305 rslt.type := Builtin.sStrTp;
1306 ELSE
1307 IF rslt.type = Builtin.lIntTp THEN dstT := Builtin.intTp;
1308 ELSIF rslt.type = Builtin.intTp THEN dstT := Builtin.sIntTp;
1309 ELSIF rslt.type = Builtin.sIntTp THEN dstT := Builtin.byteTp;
1310 ELSIF rslt.type = Builtin.realTp THEN dstT := Builtin.sReaTp;
1311 ELSIF rslt.type = Builtin.charTp THEN dstT := Builtin.sChrTp;
1312 ELSE rslt.ExprError(51); dstT := Builtin.intTp;
1313 END;
1314 IF rslt.kind = numLt THEN
1315 IF ~rslt.inRangeOf(dstT) THEN rslt.ExprError(26) END;
1316 ELSE
1317 rslt := convert(rslt, dstT);
1318 END;
1319 END;
1320 END;
1321 (* ---------------------------- *)
1322 | Builtin.longP :
1323 IF act.tide = 0 THEN prc.ExprError(22);
1324 ELSIF act.tide > 1 THEN prc.ExprError(23);
1325 ELSE
1326 rslt := arg0;
1327 IF rslt.type = Builtin.intTp THEN dstT := Builtin.lIntTp;
1328 ELSIF rslt.type = Builtin.sIntTp THEN dstT := Builtin.intTp;
1329 ELSIF rslt.type = Builtin.byteTp THEN dstT := Builtin.sIntTp;
1330 ELSIF rslt.type = Builtin.sReaTp THEN dstT := Builtin.realTp;
1331 ELSIF rslt.type = Builtin.sChrTp THEN dstT := Builtin.charTp;
1332 ELSE rslt.ExprError(47); dstT := Builtin.lIntTp;
1333 END;
1334 rslt := convert(rslt, dstT);
1335 END;
1336 (* ---------------------------- *)
1337 | Builtin.sizeP :
1338 prc.ExprError(167);
1339 (* ---------------------------- *)
1340 ELSE
1341 prc.ExprError(42);
1342 END;
1343 RETURN rslt;
1344 END stdFunction;
1345
1346 (* --------------------------- *)
1347
1348 PROCEDURE StdProcedure(i : CallX; act : D.ExprSeq);
1349 (* Assert: prc holds a procedure ident descriptor of a standard Pr. *)
1350 VAR prc : IdLeaf;
1351 funI : I.PrcId;
1352 funN : INTEGER;
1353 argN : INTEGER;
1354 errN : INTEGER;
1355 arg0 : D.Expr;
1356 arg1 : D.Expr;
1357 argT : D.Type;
1358 bndT : D.Type;
1359 ptrT : T.Pointer;
1360 (* --------------------------- *)
1361 PROCEDURE CheckNonZero(arg : D.Expr);
1362 BEGIN
1363 IF arg(LeafX).value.int() <= 0 THEN arg.ExprError(68) END;
1364 END CheckNonZero;
1365 (* --------------------------- *)
1366 BEGIN
1367 prc := i.kid(IdLeaf);
1368 arg0 := NIL;
1369 arg1 := NIL;
1370 funI := prc.ident(I.PrcId);
1371 funN := funI.stdOrd;
1372 IF act.tide >= 1 THEN
1373 arg0 := act.a[0].exprAttr();
1374 act.a[0] := arg0;
1375 IF act.tide >= 2 THEN
1376 arg1 := act.a[1].exprAttr();
1377 IF arg1 = NIL THEN RETURN END;
1378 act.a[1] := arg1;
1379 END;
1380 IF arg0 = NIL THEN RETURN END;
1381 END;
1382 (*
1383 * Now we check the per-case semantics.
1384 *)
1385 CASE funN OF
1386 (* ---------------------------- *)
1387 | Builtin.asrtP :
1388 IF act.tide = 0 THEN prc.ExprError(22);
1389 ELSIF act.tide > 2 THEN prc.ExprError(23);
1390 ELSE
1391 IF arg0.type # Builtin.boolTp THEN
1392 arg0.ExprError(36);
1393 END;
1394 IF (arg1 # NIL) & (arg1.kind # numLt) THEN
1395 arg1.ExprError(91);
1396 END;
1397 END;
1398 (* ---------------------------- *)
1399 | Builtin.incP,
1400 Builtin.decP :
1401 IF act.tide = 0 THEN prc.ExprError(22);
1402 ELSIF act.tide > 2 THEN prc.ExprError(23);
1403 ELSE
1404 IF arg0.isVarDesig() THEN
1405 arg0.CheckWriteable();
1406 IF ~arg0.isIntExpr() THEN arg0.ExprError(37) END;
1407 ELSE
1408 arg0.ExprError(85);
1409 END;
1410 IF arg1 = NIL THEN
1411 D.AppendExpr(act, mkNumLt(1));
1412 ELSIF ~arg1.isIntExpr() THEN
1413 arg1.ExprError(37);
1414 END;
1415 END;
1416 (* ---------------------------- *)
1417 | Builtin.inclP,
1418 Builtin.exclP :
1419 IF act.tide < 2 THEN prc.ExprError(22);
1420 ELSIF act.tide > 2 THEN prc.ExprError(23);
1421 ELSE
1422 IF arg0.isVarDesig() THEN
1423 arg0.CheckWriteable();
1424 IF ~arg0.isSetExpr() THEN arg0.ExprError(35) END;
1425 IF ~arg1.isIntExpr() THEN arg1.ExprError(37) END;
1426 ELSE
1427 arg0.ExprError(85);
1428 END;
1429 IF arg1.isIntExpr() THEN
1430 IF (arg1.kind = numLt) & (* Should be warning only? *)
1431 ~arg1.inRangeOf(Builtin.setTp) THEN arg1.ExprError(303) END;
1432 ELSE
1433 arg1.ExprError(37);
1434 END;
1435 END;
1436 (* ---------------------------- *)
1437 | Builtin.getP :
1438 IF act.tide = 0 THEN prc.ExprError(22);
1439 ELSIF act.tide > 2 THEN prc.ExprError(23);
1440 ELSE
1441 IF arg0.type # Builtin.intTp THEN arg0.ExprError(37) END;
1442 IF ~arg1.isVarDesig() THEN arg1.ExprError(85) END;
1443 IF arg1.type.kind # T.basTp THEN arg1.ExprError(48) END;
1444 END;
1445 (* ---------------------------- *)
1446 | Builtin.putP :
1447 IF act.tide = 0 THEN prc.ExprError(22);
1448 ELSIF act.tide > 2 THEN prc.ExprError(23);
1449 ELSE
1450 IF arg0.type # Builtin.intTp THEN arg0.ExprError(37) END;
1451 IF arg1.type.kind # T.basTp THEN arg1.ExprError(48) END;
1452 END;
1453 (* ---------------------------- *)
1454 | Builtin.cutP :
1455 IF act.tide < 2 THEN prc.ExprError(22);
1456 ELSIF act.tide > 2 THEN prc.ExprError(23);
1457 ELSIF arg0.isVarDesig() THEN
1458 arg0.CheckWriteable();
1459 IF ~arg0.isVectorExpr() THEN arg0.ExprError(229) END;
1460 ELSE
1461 arg0.ExprError(85);
1462 END;
1463 IF ~arg1.isIntExpr() THEN arg1.ExprError(37) END;
1464 (* ---------------------------- *)
1465 | Builtin.apndP :
1466 IF act.tide < 2 THEN prc.ExprError(22);
1467 ELSIF act.tide > 2 THEN prc.ExprError(23);
1468 ELSIF arg0.isVarDesig() THEN
1469 argT := arg0.type;
1470 arg0.CheckWriteable();
1471 WITH argT : T.Vector DO
1472 IF ~argT.elemTp.assignCompat(arg1) THEN
1473 IF arg1.type.isOpenArrType() THEN errN := 142;
1474 ELSIF arg1.type.isExtnRecType() THEN errN := 143;
1475 ELSIF (arg1.type.kind = T.prcTp) &
1476 (arg1.kind = qualId) &
1477 ~arg1.isProcVar() THEN errN := 165;
1478 ELSIF argT.elemTp.isCharArrayType() &
1479 arg1.type.isStringType() THEN errN := 27;
1480 ELSE errN := 83;
1481 END;
1482 IF errN # 83 THEN arg1.ExprError(errN);
1483 ELSE D.RepTypesErrTok(83, argT.elemTp, arg1.type, arg1.token);
1484 END;
1485 END;
1486 ELSE
1487 arg0.ExprError(229);
1488 END;
1489 ELSE
1490 arg0.ExprError(85);
1491 END;
1492 (* ---------------------------- *)
1493 | Builtin.subsP,
1494 Builtin.unsbP :
1495 IF G.strict THEN prc.ExprError(221); END;
1496 IF act.tide < 2 THEN prc.ExprError(22);
1497 ELSIF act.tide > 2 THEN prc.ExprError(23);
1498 ELSE
1499 IF arg0.isVarDesig() THEN
1500 arg0.CheckWriteable();
1501 IF ~arg0.type.isEventType() THEN arg0.ExprError(210) END;
1502 IF ~arg1.isProcLit() THEN arg1.ExprError(211) END;
1503 IF ~arg0.type.assignCompat(arg1) THEN arg1.ExprError(83) END;
1504 ELSE
1505 arg0.ExprError(85);
1506 END;
1507 END;
1508 (* ---------------------------- *)
1509 | Builtin.haltP :
1510 IF act.tide = 0 THEN prc.ExprError(22);
1511 ELSIF act.tide > 1 THEN prc.ExprError(23);
1512 ELSIF arg0.kind # numLt THEN arg0.ExprError(93);
1513 END;
1514 (* ---------------------------- *)
1515 | Builtin.throwP :
1516 IF G.strict THEN prc.ExprError(221); END;
1517 IF act.tide = 0 THEN prc.ExprError(22);
1518 ELSIF act.tide > 1 THEN prc.ExprError(23);
1519 ELSIF G.ntvExc.assignCompat(arg0) OR
1520 G.ntvStr.assignCompat(arg0) THEN (* skip *)
1521 ELSE arg0.ExprError(193);
1522 END;
1523 (* ---------------------------- *)
1524 | Builtin.newP :
1525 IF act.tide = 0 THEN prc.ExprError(22);
1526 ELSIF arg0.type # NIL THEN
1527 argT := arg0.type;
1528 IF ~arg0.isVarDesig() THEN
1529 arg0.ExprError(85);
1530 ELSE
1531 arg0.CheckWriteable();
1532 WITH argT : T.Base DO
1533 arg0.ExprError(90);
1534 | argT : T.Vector DO
1535 IF act.tide = 1 THEN prc.ExprError(95);
1536 ELSIF act.tide > 2 THEN prc.ExprError(97);
1537 ELSIF ~arg1.isIntExpr() THEN
1538 arg1.ExprError(98);
1539 ELSIF arg1.kind = numLt THEN
1540 CheckNonZero(arg1);
1541 END;
1542 | argT : T.Pointer DO
1543 bndT := argT.boundTp;
1544 IF act.tide = 1 THEN
1545 (*
1546 * Bound-type must be a record or a fixed
1547 * length, one-dimensional array type.
1548 *)
1549 IF bndT.kind = T.recTp THEN
1550 bndT(T.Record).InstantiateCheck(arg0.token);
1551 ELSIF bndT.kind = T.arrTp THEN
1552 IF bndT.isOpenArrType() THEN arg0.ExprError(95) END;
1553 ELSE
1554 arg0.ExprError(96);
1555 END;
1556 ELSE
1557 (*
1558 * This must be a possibly multi-dimensional array type.
1559 *)
1560 IF ~bndT.isOpenArrType() THEN
1561 arg0.ExprError(99);
1562 ELSIF ~arg1.isIntExpr() THEN
1563 arg1.ExprError(98);
1564 ELSE
1565 IF arg1.kind = numLt THEN CheckNonZero(arg1) END;
1566 bndT := bndT(T.Array).elemTp;
1567 FOR argN := 2 TO act.tide-1 DO
1568 arg1 := act.a[argN].exprAttr();
1569 IF arg1.kind = numLt THEN CheckNonZero(arg1) END;
1570 IF ~bndT.isOpenArrType() THEN
1571 arg0.ExprError(97);
1572 ELSIF ~arg1.isIntExpr() THEN
1573 arg1.ExprError(98);
1574 ELSE
1575 bndT := bndT(T.Array).elemTp;
1576 END;
1577 act.a[argN] := arg1; (* update expression *)
1578 END;
1579 (* check if we need more length params *)
1580 IF bndT.isOpenArrType() THEN arg1.ExprError(100) END;
1581 END;
1582 END;
1583 ELSE
1584 arg0.ExprError(94);
1585 END; (* with argT *)
1586 END; (* if isVarDesig() *)
1587 END; (* if *)
1588 (* ---------------------------- *)
1589 ELSE
1590 prc.ExprError(92);
1591 END;
1592 END StdProcedure;
1593
1594 (* --------------------------- *)
1595
1596 BEGIN (* body of checkCall *)
1597 prXp := i.kid;
1598 prTp := prXp.type(T.Procedure);
1599 IF i.kind = prCall THEN
1600 IF prXp.isStdProc() THEN
1601 StdProcedure(i, i.actuals);
1602 ELSIF prXp.kind = fnCall THEN
1603 prXp.ExprError(80);
1604 ELSE
1605 FormalsVsActuals(prXp, i.actuals);
1606 IF prTp.retType # NIL THEN i.ExprError(74) END;
1607 i.type := NIL;
1608 END;
1609 ELSIF i.kind = fnCall THEN
1610 IF prXp.isStdFunc() THEN
1611 RETURN stdFunction(i, i.actuals);
1612 ELSE
1613 FormalsVsActuals(prXp, i.actuals);
1614 IF prTp.retType = NIL THEN
1615 i.ExprError(24);
1616 ELSIF prTp.retType IS T.Opaque THEN
1617 prTp.retType := prTp.retType.elaboration();
1618 END;
1619 i.type := prTp.retType;
1620 END;
1621 ELSE
1622 Console.WriteString("unexpected callx"); Console.WriteLn; i.Diagnose(0);
1623 END;
1624 RETURN i;
1625 END checkCall;
1626
1627 (* -------------------------------------------- *)
1628
1629 PROCEDURE CheckSuper*(c : CallX; s : D.Scope);
1630 VAR kid1, kid2 : D.Expr;
1631 BEGIN
1632 (* ------------------------------------------------- *
1633 * Precondition: c.kid.kind = sprMrk.
1634 * The only correct expression cases are
1635 *
1636 * CallX
1637 * IdentX --- (kind = sprMrk)
1638 * IdLeaf --- (ident = s(MthId).rcvFrm)
1639 *
1640 * CallX
1641 * IdentX --- (kind = sprMrk)
1642 * UnaryX --- (kind = deref)
1643 * IdLeaf --- (ident = s(MthId).rcvFrm)
1644 *
1645 * ------------------------------------------------- *)
1646 kid1 := c.kid;
1647 kid1.ExprError(300); (* A warning only ... *)
1648 WITH kid1 : IdentX DO
1649 kid2 := kid1.kid;
1650 IF kid2.kind = deref THEN kid2 := kid2(UnaryX).kid END;
1651 WITH kid2 : IdLeaf DO
1652 WITH s : I.MthId DO
1653 IF kid2.ident # s.rcvFrm THEN c.ExprError(166) END;
1654 ELSE
1655 c.ExprError(166);
1656 END;
1657 ELSE
1658 c.ExprError(166);
1659 END;
1660 ELSE
1661 c.ExprError(166);
1662 END;
1663 END CheckSuper;
1664
1665 (* -------------------------------------------- *)
1666
1667 PROCEDURE (i : BinaryX)exprAttr*() : D.Expr;
1668 VAR rslt : D.Expr;
1669 kind : INTEGER;
1670
1671 (* --------------------------- *)
1672
1673 PROCEDURE chrOp(i : BinaryX) : D.Expr;
1674 VAR ch1,ch2 : CHAR;
1675 dRes : BOOLEAN;
1676 rslt : D.Expr;
1677 BEGIN
1678 rslt := i;
1679 IF i.lKid.isCharLit() & i.rKid.isCharLit() THEN
1680 ch1 := i.lKid(LeafX).charValue();
1681 ch2 := i.rKid(LeafX).charValue();
1682 CASE i.kind OF
1683 | greT : dRes := ch1 > ch2;
1684 | greEq : dRes := ch1 >= ch2;
1685 | notEq : dRes := ch1 # ch2;
1686 | lessEq : dRes := ch1 <= ch2;
1687 | lessT : dRes := ch1 < ch2;
1688 | equal : dRes := ch1 = ch2;
1689 ELSE i.ExprError(171); RETURN NIL;
1690 END;
1691 IF dRes THEN
1692 rslt := mkTrueX();
1693 ELSE
1694 rslt := mkFalseX();
1695 END;
1696 ELSIF ~isRelop(i.kind) THEN
1697 i.ExprError(171);
1698 ELSE
1699 i.lKid.type := Builtin.charTp;
1700 i.rKid.type := Builtin.charTp;
1701 END;
1702 rslt.type := Builtin.boolTp; RETURN rslt;
1703 END chrOp;
1704
1705 (* --------------------------- *)
1706
1707 PROCEDURE strOp(i : BinaryX) : D.Expr;
1708 VAR fold : BOOLEAN;
1709 sRes : INTEGER;
1710 bRes : BOOLEAN;
1711 rslt : D.Expr;
1712 BEGIN (* Pre: lKid,rKid are a string-valued expressions *)
1713 IF i.kind = strCat THEN RETURN i END; (* ALREADY DONE *)
1714 fold := i.lKid.isStrLit() & i.rKid.isStrLit();
1715 rslt := i;
1716 IF i.kind = plus THEN
1717 IF fold THEN
1718 rslt := mkLeafVal(strLt, L.concat(i.lKid(LeafX).value,
1719 i.rKid(LeafX).value));
1720 ELSE
1721 i.SetKind(strCat); (* can't assign via rslt, it is readonly! *)
1722 END;
1723 rslt.type := Builtin.strTp;
1724 ELSIF isRelop(i.kind) THEN
1725 IF fold THEN
1726 sRes := L.strCmp(i.lKid(LeafX).value, i.rKid(LeafX).value);
1727 CASE i.kind OF
1728 | greT : bRes := sRes > 1;
1729 | greEq : bRes := sRes >= 0;
1730 | notEq : bRes := sRes # 0;
1731 | lessEq : bRes := sRes <= 0;
1732 | lessT : bRes := sRes < 0;
1733 | equal : bRes := sRes = 0;
1734 END;
1735 IF bRes THEN
1736 rslt := mkTrueX();
1737 ELSE
1738 rslt := mkFalseX();
1739 END;
1740 (* ELSE nothing to do *)
1741 END;
1742 rslt.type := Builtin.boolTp;
1743 ELSE
1744 i.ExprError(171); RETURN NIL;
1745 END;
1746 RETURN rslt;
1747 END strOp;
1748
1749 (* --------------------------- *)
1750
1751 PROCEDURE setOp(i : BinaryX) : D.Expr;
1752 VAR newX : D.Expr;
1753 rsTp : D.Type;
1754 dRes : BOOLEAN;
1755 lSet,rSet,dSet : SET;
1756 BEGIN (* Pre: lKid is a set-valued expression *)
1757 rsTp := Builtin.setTp;
1758 dRes := FALSE; dSet := {};
1759 IF ~i.rKid.isSetExpr() THEN i.rKid.ExprError(35); RETURN NIL END;
1760 IF (i.lKid.kind = setLt) & (i.rKid.kind = setLt) THEN
1761 lSet := i.lKid(LeafX).value.set();
1762 rSet := i.rKid(LeafX).value.set();
1763 CASE i.kind OF
1764 | plus, bitOr: dSet := lSet + rSet;
1765 | minus : dSet := lSet - rSet;
1766 | mult, bitAnd: dSet := lSet * rSet;
1767 | slash,bitXor: dSet := lSet / rSet;
1768 | greT : dRes := lSet > rSet; rsTp := Builtin.boolTp;
1769 | greEq : dRes := lSet >= rSet; rsTp := Builtin.boolTp;
1770 | notEq : dRes := lSet # rSet; rsTp := Builtin.boolTp;
1771 | lessEq : dRes := lSet <= rSet; rsTp := Builtin.boolTp;
1772 | lessT : dRes := lSet < rSet; rsTp := Builtin.boolTp;
1773 | equal : dRes := lSet = rSet; rsTp := Builtin.boolTp;
1774 ELSE i.ExprError(171);
1775 END;
1776 IF rsTp # Builtin.boolTp THEN
1777 newX := mkSetLt(dSet);
1778 ELSIF dRes THEN
1779 newX := mkTrueX();
1780 ELSE
1781 newX := mkFalseX();
1782 END;
1783 ELSE
1784 CASE i.kind OF
1785 | plus : i.SetKind(bitOr);
1786 | mult : i.SetKind(bitAnd);
1787 | slash : i.SetKind(bitXor);
1788 | minus : i.SetKind(bitAnd);
1789 i.rKid := newUnaryX(compl, i.rKid);
1790 i.rKid.type := rsTp;
1791 | greT, greEq, notEq, lessEq, lessT, equal : rsTp := Builtin.boolTp;
1792 ELSE i.ExprError(171);
1793 END;
1794 newX := i;
1795 END;
1796 newX.type := rsTp; RETURN newX;
1797 END setOp;
1798
1799 (* --------------------------- *)
1800
1801 PROCEDURE numOp(i : BinaryX) : D.Expr;
1802 VAR newX : D.Expr;
1803 rsTp : D.Type;
1804 dRes : BOOLEAN;
1805 rLit : LONGINT;
1806 lVal, rVal, dVal : L.Value;
1807 lFlt, rFlt, dFlt : REAL;
1808 BEGIN (* Pre: rKid is a numeric expression *)
1809 dRes := FALSE; dFlt := 0.0; dVal := NIL;
1810 IF ~i.lKid.isNumericExpr() THEN i.lKid.ExprError(38); RETURN NIL END;
1811 IF i.kind = slash THEN
1812 rsTp := Builtin.realTp;
1813 ELSE
1814 rsTp := coverType(i.lKid.type, i.rKid.type);
1815 IF rsTp = NIL THEN i.ExprError(38); RETURN NIL END;
1816 END;
1817 (* First we coerce to a common type, if that is necessary *)
1818 IF rsTp # i.lKid.type THEN i.lKid := coerceUp(i.lKid, rsTp) END;
1819 IF rsTp # i.rKid.type THEN i.rKid := coerceUp(i.rKid, rsTp) END;
1820
1821 IF (i.lKid.kind = numLt) & (i.rKid.kind = numLt) THEN
1822 lVal := i.lKid(LeafX).value;
1823 rVal := i.rKid(LeafX).value;
1824 CASE i.kind OF
1825 | plus : dVal := L.addV(lVal, rVal);
1826 | minus : dVal := L.subV(lVal, rVal);
1827 | mult : dVal := L.mulV(lVal, rVal);
1828 | modOp : dVal := L.modV(lVal, rVal);
1829 | divOp : dVal := L.divV(lVal, rVal);
1830
1831 | rem0op : dVal := L.rem0V(lVal, rVal);
1832 | div0op : dVal := L.div0V(lVal, rVal);
1833
1834 | slash : dVal := L.slashV(lVal, rVal); rsTp := Builtin.realTp;
1835 | greT : dRes := lVal.long() > rVal.long(); rsTp := Builtin.boolTp;
1836 | greEq : dRes := lVal.long() >= rVal.long(); rsTp := Builtin.boolTp;
1837 | notEq : dRes := lVal.long() # rVal.long(); rsTp := Builtin.boolTp;
1838 | lessEq : dRes := lVal.long() <= rVal.long(); rsTp := Builtin.boolTp;
1839 | lessT : dRes := lVal.long() < rVal.long(); rsTp := Builtin.boolTp;
1840 | equal : dRes := lVal.long() = rVal.long(); rsTp := Builtin.boolTp;
1841 ELSE i.ExprError(171);
1842 END;
1843 IF rsTp = Builtin.realTp THEN
1844 newX := mkRealLt(dFlt);
1845 ELSIF rsTp # Builtin.boolTp THEN (* ==> some int type *)
1846 newX := mkLeafVal(numLt, dVal);
1847 ELSIF dRes THEN
1848 newX := mkTrueX();
1849 ELSE
1850 newX := mkFalseX();
1851 END;
1852 ELSIF (i.lKid.kind = realLt) & (i.rKid.kind = realLt) THEN
1853 lFlt := i.lKid(LeafX).value.real(); rFlt := i.rKid(LeafX).value.real();
1854 CASE i.kind OF
1855 | plus : dFlt := lFlt + rFlt;
1856 | minus : dFlt := lFlt - rFlt;
1857 | mult : dFlt := lFlt * rFlt;
1858 | slash : dFlt := lFlt / rFlt;
1859 | greT : dRes := lFlt > rFlt; rsTp := Builtin.boolTp;
1860 | greEq : dRes := lFlt >= rFlt; rsTp := Builtin.boolTp;
1861 | notEq : dRes := lFlt # rFlt; rsTp := Builtin.boolTp;
1862 | lessEq : dRes := lFlt <= rFlt; rsTp := Builtin.boolTp;
1863 | lessT : dRes := lFlt < rFlt; rsTp := Builtin.boolTp;
1864 | equal : dRes := lFlt = rFlt; rsTp := Builtin.boolTp;
1865 ELSE i.ExprError(171);
1866 END;
1867 IF rsTp # Builtin.boolTp THEN
1868 newX := mkRealLt(dFlt);
1869 ELSIF dRes THEN
1870 newX := mkTrueX();
1871 ELSE
1872 newX := mkFalseX();
1873 END;
1874 (*
1875 * SHOULD FOLD IEEE INFINITIES HERE!
1876 *)
1877 ELSE
1878 CASE i.kind OF
1879 | plus, minus, mult, slash :
1880 (* skip *)
1881 | rem0op, div0op :
1882 IF rsTp.isRealType() THEN i.ExprError(45) END;
1883 | modOp, divOp :
1884 IF rsTp.isRealType() THEN
1885 i.ExprError(45);
1886 ELSIF (i.rKid.kind = numLt) THEN
1887 rLit := i.rKid(LeafX).value.long();
1888 IF isPowerOf2(rLit) THEN
1889 IF i.kind = modOp THEN
1890 i.SetKind(bitAnd);
1891 i.rKid := mkNumLt(rLit - 1);
1892 ELSE
1893 i.SetKind(ashInt);
1894 i.rKid := mkNumLt(-log2(rLit)); (* neg ==> right shift *)
1895 END;
1896 END;
1897 END;
1898 | greT, greEq, notEq, lessEq, lessT, equal :
1899 rsTp := Builtin.boolTp;
1900 ELSE i.ExprError(171);
1901 END;
1902 newX := i;
1903 END;
1904 newX.type := rsTp; RETURN newX;
1905 END numOp;
1906
1907 (* --------------------------- *)
1908
1909 PROCEDURE isTest(b : BinaryX) : D.Expr;
1910 VAR dstT : D.Type;
1911 BEGIN
1912 IF b.lKid.type = NIL THEN RETURN NIL END;
1913 dstT := getQualType(b.rKid);
1914 IF dstT = NIL THEN b.rKid.ExprError(5); RETURN NIL END;
1915 IF ~b.lKid.hasDynamicType() THEN b.lKid.ExprError(17); RETURN NIL END;
1916 IF ~b.lKid.type.isBaseOf(dstT) THEN b.ExprError(34); RETURN NIL END;
1917 b.type := Builtin.boolTp; RETURN b;
1918 END isTest;
1919
1920 (* --------------------------- *)
1921
1922 PROCEDURE inTest(b : BinaryX) : D.Expr;
1923 VAR sVal : SET;
1924 iVal : INTEGER;
1925 rslt : D.Expr;
1926 BEGIN
1927 IF ~b.lKid.isIntExpr() THEN b.lKid.ExprError(37); RETURN NIL END;
1928 IF ~b.rKid.isSetExpr() THEN b.rKid.ExprError(35); RETURN NIL END;
1929 rslt := b;
1930 IF (b.lKid.kind = strLt) & (b.rKid.kind = setLt) THEN
1931 iVal := b.lKid(LeafX).value.int();
1932 sVal := b.rKid(LeafX).value.set();
1933 IF iVal IN sVal THEN
1934 rslt := mkTrueX();
1935 ELSE
1936 rslt := mkFalseX();
1937 END;
1938 END;
1939 rslt.type := Builtin.boolTp; RETURN rslt;
1940 END inTest;
1941
1942 (* --------------------------- *)
1943
1944 PROCEDURE EqualOkCheck(node : BinaryX);
1945 VAR lTp,rTp : D.Type;
1946 BEGIN
1947 lTp := node.lKid.type;
1948 rTp := node.rKid.type;
1949 IF (lTp = NIL) OR (rTp = NIL) THEN RETURN END;
1950 (*
1951 * The permitted cases here are:
1952 * comparisons of Booleans
1953 * comparisons of pointers (maybe sanity checked?)
1954 * comparisons of procedures (maybe sanity checked?)
1955 *)
1956 IF (node.lKid.isBooleanExpr() & node.rKid.isBooleanExpr()) OR
1957 (node.lKid.isPointerExpr() & node.rKid.isPointerExpr()) OR
1958 (node.lKid.isProcExpr() & node.rKid.isProcExpr()) THEN
1959 node.type := Builtin.boolTp;
1960 ELSE
1961 D.RepTypesErrTok(57, node.lKid.type, node.rKid.type, node.token);
1962 END;
1963 END EqualOkCheck;
1964
1965 (* --------------------------- *)
1966
1967 PROCEDURE boolBinOp(i : BinaryX) : D.Expr;
1968 VAR rslt : D.Expr;
1969 BEGIN
1970 IF i.lKid.type # Builtin.boolTp THEN i.lKid.ExprError(36) END;
1971 IF i.rKid.type # Builtin.boolTp THEN i.rKid.ExprError(36) END;
1972 IF i.lKid.kind = tBool THEN
1973 IF i.kind = blOr THEN
1974 rslt := i.lKid; (* return the TRUE *)
1975 ELSE
1976 rslt := i.rKid; (* return the rhs-expr *)
1977 END;
1978 ELSIF i.lKid.kind = fBool THEN
1979 IF i.kind = blOr THEN
1980 rslt := i.rKid; (* return the rhs-expr *)
1981 ELSE
1982 rslt := i.lKid; (* return the FALSE *)
1983 END;
1984 ELSE
1985 rslt := i;
1986 rslt.type := Builtin.boolTp;
1987 END;
1988 RETURN rslt;
1989 END boolBinOp;
1990
1991 (* --------------------------- *)
1992
1993 BEGIN (* BinaryX exprAttr body *)
1994 rslt := NIL;
1995 kind := i.kind;
1996 (*
1997 * The following cases are fully attributed already
1998 * perhaps as a result of a call of checkCall()
1999 *)
2000 IF (kind = index) OR (kind = ashInt) OR
2001 (kind = lshInt) OR (kind = rotInt) OR
2002 (kind = lenOf) OR (kind = minOf) OR (kind = maxOf) THEN RETURN i END;
2003 (*
2004 * First, attribute the subtrees.
2005 *)
2006 IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
2007 i.lKid := i.lKid.exprAttr(); (* process subtree *)
2008 i.rKid := i.rKid.exprAttr(); (* process subtree *)
2009 IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
2010 (*
2011 * Deal with unique cases first... IN and IS, then OR and &
2012 *)
2013 IF kind = range THEN
2014 rslt := i;
2015 ELSIF kind = inOp THEN
2016 rslt := inTest(i);
2017 ELSIF kind = isOp THEN
2018 rslt := isTest(i);
2019 ELSIF (kind = blOr) OR
2020 (kind = blAnd) THEN
2021 rslt := boolBinOp(i);
2022 (*
2023 * Deal with set-valued expressions, including constant folding.
2024 *)
2025 ELSIF i.lKid.isSetExpr() THEN
2026 rslt := setOp(i);
2027 (*
2028 * Deal with numerical expressions, including constant folding.
2029 * Note that we test the right subtree, to avoid (num IN set) case.
2030 *)
2031 ELSIF i.rKid.isNumericExpr() THEN
2032 rslt := numOp(i);
2033 (*
2034 * Deal with string expressions, including constant folding.
2035 * Note that this must be done before dealing characters so
2036 * as to correctly deal with literal strings of length one.
2037 *)
2038 ELSIF (i.lKid.isString() OR i.lKid.isCharArray()) &
2039 (i.rKid.isString() OR i.rKid.isCharArray()) THEN
2040 rslt := strOp(i);
2041 (*
2042 * Deal with character expressions, including constant folding.
2043 *)
2044 ELSIF i.lKid.isCharExpr() & i.rKid.isCharExpr() THEN
2045 rslt := chrOp(i);
2046 (*
2047 * Now all the irregular cases.
2048 *)
2049 ELSIF (kind = equal) OR (kind = notEq) THEN
2050 EqualOkCheck(i);
2051 i.type := Builtin.boolTp;
2052 rslt := i;
2053 ELSE
2054 i.ExprError(171);
2055 END;
2056 RETURN rslt;
2057 END exprAttr;
2058
2059 (* ============================================================ *)
2060 (* Flow attribution for actual parameter lists *)
2061 (* ============================================================ *)
2062
2063 PROCEDURE (cXp : CallX)liveActuals(scp : D.Scope;
2064 set : V.VarSet) : V.VarSet,NEW;
2065 VAR idx : INTEGER;
2066 act : D.Expr;
2067 xKd : D.Expr;
2068 frm : I.ParId;
2069 pTp : T.Procedure;
2070 new : V.VarSet;
2071 BEGIN
2072 new := set.newCopy();
2073 xKd := cXp.kid;
2074 pTp := xKd.type(T.Procedure);
2075 FOR idx := 0 TO cXp.actuals.tide-1 DO
2076 act := cXp.actuals.a[idx];
2077 frm := pTp.formals.a[idx];
2078 IF frm.parMod # D.out THEN
2079 (*
2080 * We accumulate the effect of each evaluation, using
2081 * "set" as input in each case. This is conservative,
2082 * assuming parallel (but strict) evaluation.
2083 *)
2084 new := act.checkLive(scp, set).cup(new);
2085 ELSE
2086 new := act.assignLive(scp, new);
2087 END;
2088 END;
2089 (*
2090 * If locals are uplevel addressed we presume that they
2091 * might be initialized by any call of a nested procedure.
2092 *)
2093 IF scp IS I.Procs THEN
2094 WITH xKd : IdentX DO
2095 IF xKd.ident.dfScp = scp THEN scp.UplevelInitialize(new) END;
2096 | xKd : IdLeaf DO
2097 IF xKd.ident.dfScp = scp THEN scp.UplevelInitialize(new) END;
2098 | xKd : UnaryX DO
2099 ASSERT(xKd.kind = tCheck);
2100 END (* skip *)
2101 END;
2102 (* #### kjg, Sep-2001 *)
2103 RETURN new;
2104 END liveActuals;
2105
2106 (* -------------------------------------------- *)
2107
2108 PROCEDURE (x : CallX)liveStdProc(scp : D.Scope;
2109 set : V.VarSet) : V.VarSet,NEW;
2110 (** Compute the live-out set as a result of the call of this *)
2111 (* standard procedure. Standard functions are all inline. *)
2112 VAR funI : I.PrcId;
2113 funN : INTEGER;
2114 arg0 : D.Expr;
2115 tmpS : V.VarSet;
2116 indx : INTEGER;
2117 BEGIN
2118 funI := x.kid(IdLeaf).ident(I.PrcId);
2119 funN := funI.stdOrd;
2120 arg0 := x.actuals.a[0];
2121 (*
2122 * Now we check the per-case semantics.
2123 *)
2124 IF funN = Builtin.newP THEN
2125 (*
2126 * It is tempting, but incorrect to omit the newCopy()
2127 * and chain the values from arg to arg. However we do
2128 * not guarantee the order of evaluation (for native code).
2129 * Likewise, it is not quite correct to skip the "cup" with
2130 * tmpS := arg0.assignLive(scp, tmpS);
2131 * since one of the LEN evals might have a side-effect on
2132 * the base qualId of the first parameter.
2133 *)
2134 IF x.actuals.tide > 1 THEN
2135 tmpS := set.newCopy();
2136 FOR indx := 1 TO x.actuals.tide-1 DO
2137 tmpS := tmpS.cup(x.actuals.a[indx].checkLive(scp, set));
2138 END;
2139 tmpS := tmpS.cup(arg0.assignLive(scp, set));
2140 ELSE
2141 tmpS := arg0.assignLive(scp, set);
2142 END;
2143 ELSIF funN = Builtin.asrtP THEN
2144 tmpS := arg0.checkLive(scp, set); (* arg1 is a literal! *)
2145 ELSIF (funN = Builtin.haltP) OR (funN = Builtin.throwP) THEN
2146 tmpS := arg0.checkLive(scp, set); (* and discard *)
2147 tmpS := V.newUniv(set.cardinality());
2148 ELSIF funN = Builtin.getP THEN
2149 tmpS := arg0.checkLive(scp, set);
2150 tmpS := tmpS.cup(x.actuals.a[1].assignLive(scp, set));
2151 ELSIF funN = Builtin.putP THEN
2152 tmpS := arg0.checkLive(scp, set);
2153 tmpS := tmpS.cup(x.actuals.a[1].checkLive(scp, set));
2154 ELSE (* Builtin.incP, decP, inclP, exclP, cutP, apndP *)
2155 tmpS := arg0.assignLive(scp, set);
2156 IF x.actuals.tide = 2 THEN
2157 tmpS := tmpS.cup(x.actuals.a[1].checkLive(scp, set));
2158 END;
2159 END;
2160 RETURN tmpS;
2161 END liveStdProc;
2162
2163 (* ============================================================ *)
2164 (* Flow attribution for leaves: nothing to do for LeafX *)
2165 (* ============================================================ *)
2166
2167 PROCEDURE (x : IdLeaf)checkLive*(scp : D.Scope;
2168 lIn : V.VarSet) : V.VarSet;
2169 (* If the variable is local, check that is is live *)
2170 (* Assert: expression has been fully attributed. *)
2171 BEGIN
2172 IF (x.ident.kind # I.conId) &
2173 (x.ident.dfScp = scp) &
2174 ~x.ident.isIn(lIn) THEN
2175 IF x.isPointerExpr() THEN
2176 x.ExprError(316);
2177 ELSE
2178 x.ExprError(135);
2179 END;
2180 END;
2181 RETURN lIn;
2182 END checkLive;
2183
2184 (* -------------------------------------------- *)
2185
2186 PROCEDURE (x : SetExp)checkLive*(scp : D.Scope;
2187 lIn : V.VarSet) : V.VarSet;
2188 (* Assert: expression has been fully attributed. *)
2189 BEGIN
2190 (* Really: recurse over set elements *)
2191 RETURN lIn;
2192 END checkLive;
2193
2194 (* -------------------------------------------- *)
2195
2196 PROCEDURE (x : LeafX)BoolLive*(scp : D.Scope;
2197 set : V.VarSet;
2198 OUT tru,fal : V.VarSet);
2199 BEGIN
2200 IF x.kind = tBool THEN
2201 tru := set;
2202 fal := V.newUniv(set.cardinality());
2203 ELSIF x.kind = fBool THEN
2204 tru := V.newUniv(set.cardinality());
2205 fal := set;
2206 ELSE
2207 tru := x.checkLive(scp, set);
2208 fal := tru;
2209 END;
2210 END BoolLive;
2211
2212 (* ============================================================ *)
2213 (* Flow attribution for unaries: nothing to do for IdentX *)
2214 (* ============================================================ *)
2215
2216 PROCEDURE (x : UnaryX)BoolLive*(scp : D.Scope;
2217 set : V.VarSet;
2218 OUT tru,fal : V.VarSet);
2219 BEGIN
2220 IF x.kind = blNot THEN
2221 x.kid.BoolLive(scp, set, fal, tru);
2222 ELSE
2223 tru := x.checkLive(scp, set);
2224 fal := tru;
2225 END;
2226 END BoolLive;
2227
2228 (* -------------------------------------------- *)
2229
2230 PROCEDURE (x : UnaryX)checkLive*(scp : D.Scope;
2231 lIn : V.VarSet) : V.VarSet,EXTENSIBLE;
2232 (* Assert: expression has been fully attributed. *)
2233 BEGIN
2234 RETURN x.kid.checkLive(scp, lIn);
2235 END checkLive;
2236
2237 (* -------------------------------------------- *)
2238
2239 PROCEDURE (x : CallX)checkLive*(scp : D.Scope;
2240 lIn : V.VarSet) : V.VarSet;
2241 (* Assert: expression has been fully attributed. *)
2242 VAR tmpS : V.VarSet;
2243 BEGIN
2244 tmpS := x.kid.checkLive(scp, lIn);
2245 IF (x.kind = prCall) & x.kid.isStdProc() THEN
2246 RETURN x.liveStdProc(scp, tmpS);
2247 ELSE
2248 RETURN x.liveActuals(scp, tmpS);
2249 END;
2250 END checkLive;
2251
2252 (* ============================================================ *)
2253 (* Flow attribution for binary expressions *)
2254 (* ============================================================ *)
2255
2256 PROCEDURE (x : BinaryX)BoolLive*(scp : D.Scope;
2257 set : V.VarSet;
2258 OUT tru,fal : V.VarSet);
2259 (** If this is a short-circuit operator evaluate the two *)
2260 (* subtrees and combine. Otherwise return unconditional set. *)
2261 VAR lhT, lhF, rhT, rhF : V.VarSet;
2262 BEGIN
2263 IF x.kind = blOr THEN
2264 x.lKid.BoolLive(scp, set, lhT, lhF);
2265 x.rKid.BoolLive(scp, lhF, rhT, fal);
2266 tru := lhT.cap(rhT);
2267 ELSIF x.kind = blAnd THEN
2268 x.lKid.BoolLive(scp, set, lhT, lhF);
2269 x.rKid.BoolLive(scp, lhT, tru, rhF);
2270 fal := lhF.cap(rhF);
2271 ELSE
2272 tru := x.checkLive(scp, set);
2273 fal := tru;
2274 END;
2275 END BoolLive;
2276
2277 (* -------------------------------------------- *)
2278
2279 PROCEDURE (x : BinaryX)checkLive*(scp : D.Scope;
2280 lIn : V.VarSet) : V.VarSet;
2281 (* Assert: expression has been fully attributed. *)
2282 (** Compute the live-out set resulting from the evaluation of *)
2283 (* this expression, and check that any used occurrences of *)
2284 (* local variables are in the live set. Beware of the case *)
2285 (* where this is a Boolean expression with side effects! *)
2286 VAR fSet, tSet : V.VarSet;
2287 BEGIN
2288 IF (x.kind = blOr) OR (x.kind = blAnd) THEN
2289 x.lKid.BoolLive(scp, lIn, tSet, fSet);
2290 IF x.kind = blOr THEN
2291 (*
2292 * If this evaluation short circuits, then the result
2293 * is tSet. If the second factor is evaluated, the result
2294 * is obtained by passing fSet as input to the second
2295 * term evaluation. Thus the guaranteed output is the
2296 * intersection of tSet and x.rKid.checkLive(fSet).
2297 *)
2298 RETURN tSet.cap(x.rKid.checkLive(scp, fSet));
2299 ELSE (* x.kind = blAnd *)
2300 (*
2301 * If this evaluation short circuits, then the result
2302 * is fSet. If the second factor is evaluated, the result
2303 * is obtained by passing tSet as input to the second
2304 * factor evaluation. Thus the guaranteed output is the
2305 * intersection of fSet and x.rKid.checkLive(tSet).
2306 *)
2307 RETURN fSet.cap(x.rKid.checkLive(scp, tSet));
2308 END;
2309 ELSE
2310 (* TO DO : check that this is OK for all the inlined standard functions *)
2311 RETURN x.lKid.checkLive(scp, lIn).cup(x.rKid.checkLive(scp, lIn));
2312 END;
2313 END checkLive;
2314
2315 (* ============================================================ *)
2316 (* Assign flow attribution for qualified id expressions *)
2317 (* ============================================================ *)
2318
2319 PROCEDURE (p : IdLeaf)assignLive*(scpe : D.Scope;
2320 lvIn : V.VarSet) : V.VarSet;
2321 VAR tmpS : V.VarSet;
2322 BEGIN
2323 (* Invariant: input set lvIn is unchanged *)
2324 IF p.ident.dfScp = scpe THEN
2325 tmpS := lvIn.newCopy();
2326 tmpS.Incl(p.ident(I.AbVar).varOrd);
2327 RETURN tmpS;
2328 ELSE
2329 RETURN lvIn;
2330 END;
2331 END assignLive;
2332
2333 (* ============================================================ *)
2334 (* Predicates on Expr extensions *)
2335 (* ============================================================ *)
2336
2337 PROCEDURE (x : IdLeaf)hasDynamicType*() : BOOLEAN;
2338 BEGIN
2339 RETURN (x.ident # NIL) & x.ident.isDynamic();
2340 END hasDynamicType;
2341
2342 (* -------------------------------------------- *)
2343 (* -------------------------------------------- *)
2344
2345 PROCEDURE (x : IdLeaf)isWriteable*() : BOOLEAN;
2346 (* A qualident is writeable if the IdLeaf is writeable *)
2347 BEGIN
2348 RETURN x.ident.mutable();
2349 END isWriteable;
2350
2351 PROCEDURE (x : IdLeaf)CheckWriteable*();
2352 (* A qualident is writeable if the IdLeaf is writeable *)
2353 BEGIN
2354 x.ident.CheckMutable(x);
2355 END CheckWriteable;
2356
2357 (* -------------------------------------------- *)
2358
2359 PROCEDURE (x : UnaryX)isWriteable*() : BOOLEAN,EXTENSIBLE;
2360 (* A referenced object is always writeable. *)
2361 (* tCheck nodes are always NOT writeable. *)
2362 BEGIN RETURN x.kind = deref END isWriteable;
2363
2364 PROCEDURE (x : UnaryX)CheckWriteable*(),EXTENSIBLE;
2365 (* A referenced object is always writeable. *)
2366 (* tCheck nodes are always NOT writeable. *)
2367 BEGIN
2368 IF x.kind # deref THEN x.ExprError(103) END;
2369 END CheckWriteable;
2370
2371 (* -------------------------------------------- *)
2372
2373 PROCEDURE (x : IdentX)isWriteable*() : BOOLEAN;
2374 (* This case depends on the mutability of the record field, *
2375 * other cases of IdentX are not writeable at all. *)
2376 BEGIN
2377 RETURN (x.kind = selct) & x.ident.mutable() & x.kid.isWriteable();
2378 END isWriteable;
2379
2380 PROCEDURE (x : IdentX)CheckWriteable*();
2381 (* This case depends on the mutability of the record field, *
2382 * other cases of IdentX are not writeable at all. *)
2383 BEGIN
2384 IF x.kind = selct THEN
2385 x.ident.CheckMutable(x);
2386 x.kid.CheckWriteable();
2387 ELSE
2388 x.ExprError(103);
2389 END;
2390 END CheckWriteable;
2391
2392 (* -------------------------------------------- *)
2393
2394 PROCEDURE (x : BinaryX)isWriteable*() : BOOLEAN;
2395 (* The only possibly writeable case here is for array *
2396 * elements. These are writeable if the underlying array is *)
2397 BEGIN
2398 RETURN (x.kind = index) & x.lKid.isWriteable();
2399 END isWriteable;
2400
2401 PROCEDURE (x : BinaryX)CheckWriteable*();
2402 (* The only possibly writeable case here is for array *
2403 * elements. These are writeable if the underlying array is *)
2404 BEGIN
2405 IF x.kind # index THEN
2406 x.ExprError(103);
2407 ELSE
2408 x.lKid.CheckWriteable();
2409 END;
2410 END CheckWriteable;
2411
2412 (* -------------------------------------------- *)
2413 (* -------------------------------------------- *)
2414
2415 PROCEDURE (x : IdLeaf)isVarDesig*() : BOOLEAN;
2416 BEGIN
2417 RETURN x.ident IS I.AbVar; (* varId or parId *)
2418 END isVarDesig;
2419
2420 (* -------------------------------------------- *)
2421
2422 PROCEDURE (x : UnaryX)isVarDesig*() : BOOLEAN,EXTENSIBLE;
2423 BEGIN RETURN x.kind = deref END isVarDesig;
2424
2425 (* -------------------------------------------- *)
2426
2427 PROCEDURE (x : IdentX)isVarDesig*() : BOOLEAN;
2428 BEGIN
2429 RETURN x.kind = selct;
2430 END isVarDesig;
2431
2432 (* -------------------------------------------- *)
2433
2434 PROCEDURE (x : BinaryX)isVarDesig*() : BOOLEAN;
2435 BEGIN
2436 RETURN x.kind = index;
2437 END isVarDesig;
2438
2439 (* -------------------------------------------- *)
2440 (* -------------------------------------------- *)
2441
2442 PROCEDURE (x : IdLeaf)isProcLit*() : BOOLEAN;
2443 BEGIN
2444 (*
2445 * True if this is a concrete procedure
2446 *)
2447 RETURN (x.ident.kind = I.conPrc) OR
2448 (x.ident.kind = I.fwdPrc);
2449 END isProcLit;
2450
2451 (* -------------------------------------------- *)
2452
2453 PROCEDURE (x : IdentX)isProcLit*() : BOOLEAN;
2454 BEGIN
2455 (*
2456 * True if this is a concrete procedure
2457 *)
2458 RETURN (x.ident.kind = I.conMth) OR
2459 (x.ident.kind = I.fwdMth);
2460 END isProcLit;
2461
2462 (* -------------------------------------------- *)
2463 (* -------------------------------------------- *)
2464
2465 PROCEDURE (x : IdLeaf)isProcVar*() : BOOLEAN;
2466 BEGIN
2467 (*
2468 * True if this has procedure type, but is not a concrete procedure
2469 *)
2470 RETURN x.type.isProcType() &
2471 (x.ident.kind # I.conPrc) &
2472 (x.ident.kind # I.fwdPrc) &
2473 (x.ident.kind # I.ctorP);
2474 END isProcVar;
2475
2476 (* -------------------------------------------- *)
2477
2478 PROCEDURE (x : IdentX)isProcVar*() : BOOLEAN;
2479 BEGIN
2480 (*
2481 * True if this is a selct, and field has procedure type
2482 *)
2483 RETURN (x.kind = selct) &
2484 (x.ident IS I.FldId) &
2485 x.type.isProcType();
2486 END isProcVar;
2487
2488 (* -------------------------------------------- *)
2489
2490 PROCEDURE (x : UnaryX)isProcVar*() : BOOLEAN,EXTENSIBLE;
2491 BEGIN
2492 (*
2493 * This depends on the fact that x.kid will be
2494 * of System.Delegate type, and is being cast
2495 * to some subtype of Procedure or Event type.
2496 *)
2497 RETURN (x.kind = tCheck) & x.type.isProcType();
2498 END isProcVar;
2499
2500 (* -------------------------------------------- *)
2501
2502 PROCEDURE (x : BinaryX)isProcVar*() : BOOLEAN;
2503 BEGIN
2504 (*
2505 * True if this is an index, and element has procedure type
2506 *)
2507 RETURN (x.kind = index) & x.type.isProcType();
2508 END isProcVar;
2509
2510 (* -------------------------------------------- *)
2511
2512 PROCEDURE (x : LeafX)isNil*() : BOOLEAN;
2513 BEGIN RETURN x.kind = nilLt END isNil;
2514
2515 (* -------------------------------------------- *)
2516
2517 PROCEDURE (x : LeafX)isInf*() : BOOLEAN;
2518 BEGIN RETURN (x.kind = infLt) OR (x.kind = nInfLt) END isInf;
2519
2520 (* -------------------------------------------- *)
2521
2522 PROCEDURE (x : LeafX)isNumLit*() : BOOLEAN;
2523 BEGIN RETURN x.kind = numLt END isNumLit;
2524
2525 (* -------------------------------------------- *)
2526
2527 PROCEDURE (x : LeafX)isCharLit*() : BOOLEAN;
2528 (** A literal character, or a literal string of length = 1. *)
2529 BEGIN
2530 RETURN (x.kind = charLt)
2531 OR ((x.kind = strLt) & (x.value.len() = 1));
2532 END isCharLit;
2533
2534 (* -------------------------------------------- *)
2535
2536 PROCEDURE (x : LeafX)isStrLit*() : BOOLEAN;
2537 (* If this is a LeafX of string type, it must b a lit-string. *)
2538 BEGIN RETURN x.kind = strLt END isStrLit;
2539
2540 (* ==================================================================== *)
2541 (* Possible structures of procedure call expressions are: *)
2542 (* ==================================================================== *)
2543 (* o o *)
2544 (* / / *)
2545 (* [CallX] [CallX] *)
2546 (* / +--- actuals --> ... / +--- actuals --> ... *)
2547 (* / / *)
2548 (* [IdentX] [IdLeaf] *)
2549 (* / +--- ident ---> [PrcId] +--- ident ---> [PrcId] *)
2550 (* / *)
2551 (* kid expr *)
2552 (* *)
2553 (* ==================================================================== *)
2554 (* only the right hand side case can be a standard proc or function *)
2555 (* ==================================================================== *)
2556
2557 PROCEDURE (x : IdLeaf)isStdFunc*() : BOOLEAN;
2558 BEGIN
2559 RETURN (x.ident # NIL)
2560 & (x.ident.kind = I.conPrc)
2561 & (x.ident(I.PrcId).stdOrd # 0);
2562 END isStdFunc;
2563
2564 (* -------------------------------------------- *)
2565
2566 PROCEDURE (x : IdLeaf)isStdProc*() : BOOLEAN;
2567 BEGIN
2568 RETURN (x.ident # NIL)
2569 & (x.ident.kind = I.conPrc)
2570 & (x.ident(I.PrcId).stdOrd # 0);
2571 END isStdProc;
2572
2573 (* -------------------------------------------- *)
2574
2575 PROCEDURE (p : CallX)NoteCall*(s : D.Scope);
2576 BEGIN
2577 p.kid.NoteCall(s);
2578 END NoteCall;
2579
2580 (* -------------------------------------------- *)
2581
2582 PROCEDURE (p : IdLeaf)NoteCall*(s : D.Scope);
2583 VAR proc : I.PrcId;
2584 BEGIN
2585 IF (p.ident # NIL) &
2586 ((p.ident.kind = I.fwdPrc) OR
2587 (p.ident.kind = I.conPrc)) THEN
2588 proc := p.ident(I.PrcId);
2589 IF proc.stdOrd = 0 THEN INCL(proc.pAttr, I.called) END;
2590 END;
2591 END NoteCall;
2592
2593 (* -------------------------------------------- *)
2594
2595 PROCEDURE (p : IdentX)NoteCall*(s : D.Scope);
2596 VAR proc : I.MthId;
2597 BEGIN
2598 IF (p.ident # NIL) &
2599 ((p.ident.kind = I.fwdMth) OR
2600 (p.ident.kind = I.conMth)) THEN
2601 proc := p.ident(I.MthId);
2602 INCL(proc.pAttr, I.called);
2603 END;
2604 END NoteCall;
2605
2606 (* -------------------------------------------- *)
2607
2608 PROCEDURE (x : LeafX)inRangeOf*(dst : D.Type) : BOOLEAN;
2609 VAR lVal : LONGINT;
2610 cVal : CHAR;
2611 sLen : INTEGER;
2612 aLen : INTEGER;
2613 BEGIN
2614 IF x.kind = numLt THEN
2615 lVal := x.value.long();
2616 IF dst.kind = T.vecTp THEN RETURN TRUE;
2617 ELSIF dst.kind = T.arrTp THEN
2618 sLen := dst(T.Array).length;
2619 RETURN (lVal >= 0) & (* check open array later *)
2620 ((sLen = 0) OR (lVal < sLen)) (* otherwise check now *)
2621 ELSIF dst = Builtin.setTp THEN
2622 RETURN (lVal >= 0) & (lVal <= 31);
2623 ELSIF ~dst.isNumType() THEN
2624 RETURN FALSE;
2625 ELSE
2626 CASE dst(T.Base).tpOrd OF
2627 | T.uBytN : RETURN (lVal >= ORD(MIN(SHORTCHAR))) &
2628 (lVal <= ORD(MAX(SHORTCHAR)));
2629 | T.byteN : RETURN (lVal >= MIN(BYTE)) & (lVal <= MAX(BYTE));
2630 | T.sIntN : RETURN (lVal >= MIN(SHORTINT)) & (lVal <= MAX(SHORTINT));
2631 | T.intN : RETURN (lVal >= MIN(INTEGER)) & (lVal <= MAX(INTEGER));
2632 | T.lIntN : RETURN TRUE;
2633 ELSE RETURN FALSE;
2634 END
2635 END;
2636 (*
2637 * Changed for 1.2.3.4 to allow S1 to be compat with ARRAY OF CHAR (kjg)
2638 *
2639 * ELSIF x.isCharLit() THEN
2640 * IF ~dst.isCharType() THEN
2641 *)
2642 ELSIF dst.isCharType() THEN
2643 IF ~x.isCharLit() THEN
2644 RETURN FALSE;
2645 ELSE
2646 cVal := x.charValue();
2647 IF dst(T.Base).tpOrd = T.sChrN THEN
2648 RETURN (cVal >= MIN(SHORTCHAR)) & (cVal <= MAX(SHORTCHAR));
2649 ELSE
2650 RETURN TRUE;
2651 END;
2652 END;
2653 (*
2654 * ELSIF x.kind = strLt THEN
2655 * IF ~dst.isCharArrayType() THEN
2656 *)
2657 ELSIF dst.isCharArrayType() THEN
2658 IF x.kind # strLt THEN
2659 RETURN FALSE;
2660 ELSE
2661 aLen := dst(T.Array).length;
2662 sLen := x.value.len();
2663 RETURN (aLen = 0) OR (* lhs is open array, runtime test *)
2664 (aLen > sLen); (* string fits in fixed array OK *)
2665 END;
2666 ELSE
2667 RETURN FALSE;
2668 END;
2669 END inRangeOf;
2670
2671 (* ============================================================ *)
2672
2673 PROCEDURE (x : LeafX)charValue*() : CHAR,NEW;
2674 (** A literal character, or a literal string of length = 1. *)
2675 VAR chr : CHAR;
2676 BEGIN
2677 IF x.kind = charLt THEN
2678 chr := x.value.char();
2679 ELSE (* x.kind = strLt *)
2680 chr := x.value.chr0();
2681 END;
2682 RETURN chr;
2683 END charValue;
2684
2685 (* -------------------------------------------- *)
2686
2687 PROCEDURE convert(expr : D.Expr; dstT : D.Type) : D.Expr;
2688 (* Make permitted base-type coercions explicit in the AST *)
2689 VAR rslt : D.Expr;
2690 expT : D.Type;
2691 valu : INTEGER;
2692 BEGIN
2693 expT := expr.type;
2694 IF (expT = dstT) OR
2695 (dstT.kind # T.basTp) OR
2696 (dstT = Builtin.anyPtr) THEN
2697 RETURN expr;
2698 ELSIF (dstT = Builtin.charTp) & (expT = Builtin.strTp) THEN
2699 expr.type := dstT;
2700 RETURN expr;
2701 ELSIF (dstT = Builtin.sChrTp) & (expT = Builtin.strTp) THEN
2702 valu := ORD(expr(LeafX).value.chr0());
2703 IF (valu < 255) THEN
2704 expr.type := dstT;
2705 RETURN expr;
2706 ELSE
2707 expr.type := Builtin.charTp;
2708 END;
2709 END;
2710 IF dstT.includes(expr.type) THEN
2711 rslt := newIdentX(cvrtUp, dstT.idnt, expr);
2712 ELSE
2713 rslt := newIdentX(cvrtDn, dstT.idnt, expr);
2714 END;
2715 rslt.type := dstT;
2716 RETURN rslt;
2717 END convert;
2718
2719 (* ============================================================ *)
2720
2721 PROCEDURE FormalsVsActuals*(prcX : D.Expr; actSeq : D.ExprSeq);
2722 VAR prcT : T.Procedure;
2723 index : INTEGER;
2724 bound : INTEGER;
2725 frmMod : INTEGER;
2726 actual : D.Expr;
2727 formal : I.ParId;
2728 frmTyp : D.Type;
2729 actTyp : D.Type;
2730 frmSeq : I.ParSeq;
2731 fIsPtr : BOOLEAN;
2732
2733 (* ---------------------------- *)
2734
2735 PROCEDURE CheckCompatible(frm : D.Idnt; act : D.Expr);
2736 BEGIN
2737 IF frm.paramCompat(act) OR
2738 frm.type.arrayCompat(act.type) THEN (* is OK, skip *)
2739 ELSE
2740 D.RepTypesErrTok(21, act.type, frm.type, act.token);
2741 IF (act.type IS T.Opaque) &
2742 (act.type.idnt # NIL) &
2743 (act.type.idnt.dfScp # NIL) THEN
2744 S.SemError.RepSt1(175,
2745 D.getName.ChPtr(act.type.idnt.dfScp),
2746 act.token.lin, act.token.col);
2747 END;
2748 END;
2749 END CheckCompatible;
2750
2751 (* ---------------------------- *)
2752
2753 PROCEDURE CheckVarModes(mod : INTEGER; exp : D.Expr);
2754
2755 (* ---------------------------- *)
2756
2757 PROCEDURE hasReferenceType(t : D.Type) : BOOLEAN;
2758 BEGIN
2759 RETURN (t.kind = T.ptrTp) OR
2760 (t.kind = T.recTp) OR
2761 (t.kind = T.arrTp) OR
2762 (t.kind = T.namTp) OR
2763 (t = Builtin.strTp) OR
2764 (t = Builtin.anyPtr);
2765 END hasReferenceType;
2766
2767 (* ---------------------------- *)
2768
2769 PROCEDURE MarkAddrsd(id : D.Idnt);
2770 BEGIN
2771 WITH id : I.LocId DO INCL(id.locAtt, I.addrsd); ELSE END;
2772 END MarkAddrsd;
2773
2774 (* ---------------------------- *)
2775
2776 BEGIN (* Assert: mod is IN, OUT, or VAR *)
2777 IF mod = D.in THEN (* IN mode only *)
2778 (*
2779 * Not strictly correct according to the report, but an *
2780 * innocuous extension -- allow literal strings here. *
2781 *
2782 * IF (exp.type # Builtin.strTp) & ~exp.isVarDesig() THEN
2783 *)
2784 IF ~exp.isVarDesig() &
2785 (exp.type # NIL) & ~hasReferenceType(exp.type) THEN
2786 exp.ExprError(174);
2787 END;
2788 ELSE
2789 exp.CheckWriteable(); (* OUT and VAR modes *)
2790 WITH exp : IdLeaf DO MarkAddrsd(exp.ident) ELSE END;
2791 END;
2792 END CheckVarModes;
2793
2794 (* ---------------------------- *)
2795
2796 BEGIN
2797 prcT := prcX.type(T.Procedure);
2798 frmSeq := prcT.formals;
2799 bound := MIN(actSeq.tide, frmSeq.tide) - 1;
2800 FOR index := 0 TO bound DO
2801 formal := frmSeq.a[index];
2802 actual := actSeq.a[index];
2803
2804 (* compute attributes for the actual param expression *)
2805 IF actual # NIL THEN actual := actual.exprAttr() END;
2806 (* Now check the semantic rules for conformance *)
2807 IF (actual # NIL) &
2808 (formal # NIL) &
2809 (actual.type # NIL) &
2810 (formal.type # NIL) THEN
2811 frmTyp := formal.type;
2812 actTyp := actual.type;
2813
2814 IF frmTyp IS T.Procedure THEN
2815 formal.IdError(301);
2816 IF G.targetIsJVM() THEN formal.IdError(320);
2817 ELSIF (frmTyp # actTyp) &
2818 ~actual.isProcLit() THEN formal.IdError(191) END;
2819 END;
2820 IF frmTyp IS T.Opaque THEN
2821 formal.type := frmTyp.resolve(1);
2822 frmTyp := formal.type;
2823 END;
2824 frmMod := formal.parMode();
2825 fIsPtr := frmTyp.isPointerType();
2826 IF (actTyp.kind = T.ptrTp) &
2827 ~fIsPtr THEN actual := mkDeref(actual) END;
2828 CheckCompatible(formal, actual);
2829 IF frmMod # D.val THEN (* IN, OUT or VAR modes *)
2830 CheckVarModes(frmMod, actual);
2831 IF (frmMod = D.out) & (actTyp # frmTyp) & actTyp.isDynamicType() THEN
2832 D.RepTypesErrTok(306, actTyp, frmTyp, actual.token);
2833 END;
2834 ELSIF actTyp # frmTyp THEN
2835 actual := convert(actual, frmTyp);
2836 IF ~frmTyp.valCopyOK() THEN formal.IdError(153) END;
2837 END;
2838 actSeq.a[index] := actual;
2839 END;
2840 END;
2841 IF frmSeq.tide > actSeq.tide THEN
2842 IF actSeq.tide = 0 THEN
2843 prcX.ExprError(149);
2844 ELSE
2845 actSeq.a[actSeq.tide-1].ExprError(22);
2846 END;
2847 ELSIF actSeq.tide > frmSeq.tide THEN
2848 actual := actSeq.a[frmSeq.tide];
2849 IF actual # NIL THEN
2850 actSeq.a[frmSeq.tide].ExprError(23);
2851 ELSE
2852 prcX.ExprError(23);
2853 END;
2854 END;
2855 END FormalsVsActuals;
2856
2857 (* ============================================================ *)
2858
2859 PROCEDURE AttributePars*(actSeq : D.ExprSeq);
2860 VAR actual : D.Expr;
2861 index : INTEGER;
2862 BEGIN
2863 FOR index := 0 TO actSeq.tide-1 DO
2864 actual := actSeq.a[index];
2865 IF actual # NIL THEN actSeq.a[index] := actual.exprAttr(); END;
2866 END;
2867 END AttributePars;
2868
2869 (* ============================================================ *)
2870
2871 PROCEDURE MatchPars*(frmSeq : I.ParSeq; actSeq : D.ExprSeq) : BOOLEAN;
2872 VAR
2873 index : INTEGER;
2874 actual : D.Expr;
2875 formal : I.ParId;
2876 frmTyp : D.Type;
2877 actTyp : D.Type;
2878 fIsPtr : BOOLEAN;
2879
2880 BEGIN
2881 IF (frmSeq.tide # actSeq.tide) THEN RETURN FALSE; END;
2882 FOR index := 0 TO frmSeq.tide-1 DO
2883 formal := frmSeq.a[index];
2884 actual := actSeq.a[index];
2885 (* Now check the semantic rules for conformance *)
2886 IF (actual # NIL) &
2887 (formal # NIL) &
2888 (actual.type # NIL) &
2889 (formal.type # NIL) THEN
2890 IF ~(formal.paramCompat(actual) OR
2891 formal.type.arrayCompat(actual.type)) THEN
2892 RETURN FALSE;
2893 END;
2894 ELSE
2895 RETURN FALSE;
2896 END;
2897 END;
2898 RETURN TRUE;
2899 END MatchPars;
2900
2901 (* ============================================================ *)
2902
2903 PROCEDURE (p : BinaryX)enterGuard*(tmp : D.Idnt) : D.Idnt;
2904 VAR oldI : D.Idnt;
2905 junk : BOOLEAN;
2906 lHash : INTEGER;
2907 lQual : IdLeaf;
2908 rQual : IdLeaf;
2909 BEGIN
2910 IF (p.lKid = NIL) OR
2911 ~(p.lKid IS IdLeaf) OR
2912 (p.rKid = NIL) OR
2913 ~(p.rKid IS IdLeaf) THEN RETURN NIL END;
2914
2915 lQual := p.lKid(IdLeaf);
2916 rQual := p.rKid(IdLeaf);
2917 IF (lQual.ident = NIL) OR (rQual.ident = NIL) THEN RETURN NIL END;
2918 (*
2919 * We first determine if this is a local variable.
2920 * If it is, we must overwrite this in the local scope
2921 * with the temporary of the guard type.
2922 * If any case, we return the previous local.
2923 *)
2924 lHash := lQual.ident.hash;
2925 tmp.hash := lHash;
2926 tmp.type := rQual.ident.type;
2927 (*
2928 * It is an essential requirement of the host execution systems
2929 * that the runtime type of the guarded variable may not be changed
2930 * within the guarded region. In the case of pointer to record
2931 * types this is guaranteed by making the "tmp" copy immutable.
2932 * Note that making the pointer variable read-only does not prevent
2933 * the guarded region from mutating fields of the record.
2934 *
2935 * In case the the guarded variable is an extensible record type.
2936 * no action is required. Any attempt to perform an entire
2937 * assignment to the guarded variable will be a type-error.
2938 * Every assignment to the entire variable will be either -
2939 * Error 83 (Expression not assignment compatible with destination), OR
2940 * Error 143 (Cannot assign entire extensible or abstract record).
2941 *)
2942 IF ~tmp.type.isRecordType() THEN tmp.SetKind(I.conId) END; (* mark immutable *)
2943 oldI := tmp.dfScp.symTb.lookup(lHash);
2944 IF oldI = NIL THEN (* not local *)
2945 junk := tmp.dfScp.symTb.enter(lHash, tmp);
2946 ASSERT(junk);
2947 ELSE
2948 tmp.dfScp.symTb.Overwrite(lHash, tmp);
2949 END;
2950 RETURN oldI;
2951 END enterGuard;
2952
2953 PROCEDURE (p : BinaryX)ExitGuard*(sav : D.Idnt; tmp : D.Idnt);
2954 BEGIN
2955 IF tmp.type = NIL THEN RETURN END;
2956 IF sav = NIL THEN
2957 (* remove tmp from tmp.dfScp.symTb *)
2958 tmp.dfScp.symTb.RemoveLeaf(tmp.hash);
2959 ELSE
2960 (* overwrite with previous value *)
2961 tmp.dfScp.symTb.Overwrite(tmp.hash, sav);
2962 END;
2963 END ExitGuard;
2964
2965 (* ============================================================ *)
2966 (* Diagnostic methods *)
2967 (* ============================================================ *)
2968
2969 PROCEDURE Diag(i : INTEGER; e : D.Expr);
2970 BEGIN
2971 IF e = NIL THEN
2972 H.Indent(i); Console.WriteString("<nil>"); Console.WriteLn;
2973 ELSE
2974 e.Diagnose(i);
2975 END;
2976 END Diag;
2977
2978 (* ------------------------------- *)
2979
2980 PROCEDURE PType(t : D.Type);
2981 BEGIN
2982 IF t # NIL THEN
2983 Console.WriteString(t.name());
2984 ELSE
2985 Console.WriteString("<nil>");
2986 END;
2987 END PType;
2988
2989 (* -------------------------------------------- *)
2990
2991 PROCEDURE (s : LeafX)Diagnose*(i : INTEGER),EXTENSIBLE;
2992 VAR name : FileNames.NameString;
2993 BEGIN
2994 H.Indent(i);
2995 CASE s.kind OF
2996 | realLt : Console.WriteString("realLt ");
2997 RTS.RealToStr(s.value.real(), name);
2998 Console.WriteString(name$);
2999 | numLt : Console.WriteString("numLt ");
3000 Console.WriteInt(s.value.int(), 0);
3001 | charLt : Console.WriteString("charLt '");
3002 Console.Write(s.value.char());
3003 Console.Write("'");
3004 | strLt : Console.WriteString("strLt ");
3005 s.value.GetStr(name);
3006 Console.Write('"');
3007 Console.WriteString(name$);
3008 Console.WriteString('" LEN=');
3009 Console.WriteInt(s.value.len(),1);
3010 | infLt : Console.WriteString("INF "); PType(s.type);
3011 | nInfLt : Console.WriteString("NEG-INF "); PType(s.type);
3012 | nilLt : Console.WriteString("NIL "); PType(s.type);
3013 | tBool : Console.WriteString("TRUE BOOLEAN");
3014 | fBool : Console.WriteString("FALSE BOOLEAN");
3015 ELSE Console.WriteString("?leaf? ");
3016 END;
3017 Console.WriteLn;
3018 END Diagnose;
3019
3020 (* ------------------------------- *)
3021
3022 PROCEDURE (s : IdLeaf)Diagnose*(i : INTEGER);
3023 VAR name : FileNames.NameString;
3024 BEGIN
3025 H.Indent(i);
3026 D.getName.Of(s.ident, name);
3027 Console.WriteString(name);
3028 Console.Write(':');
3029 Console.Write(' ');
3030 PType(s.type);
3031 Console.WriteLn;
3032 END Diagnose;
3033
3034 (* ------------------------------- *)
3035
3036 PROCEDURE (s : SetExp)Diagnose*(i : INTEGER);
3037 VAR j : INTEGER;
3038 v : SET;
3039 ch : CHAR;
3040 BEGIN
3041 ch := 0X;
3042 H.Indent(i);
3043 Console.WriteString("setLt {");
3044 IF s.value # NIL THEN
3045 v := s.value.set();
3046 FOR j := 0 TO 31 DO
3047 IF j IN v THEN ch := '1' ELSE ch := '.' END;
3048 Console.Write(ch);
3049 END;
3050 END;
3051 Console.Write("}");
3052 IF s.kind = setLt THEN
3053 Console.WriteLn;
3054 ELSE
3055 Console.WriteString(" + "); Console.WriteLn;
3056 FOR j := 0 TO s.varSeq.tide - 1 DO
3057 Diag(i+4, s.varSeq.a[j]);
3058 END;
3059 END;
3060 END Diagnose;
3061
3062 (* ------------------------------- *)
3063
3064 PROCEDURE (s : UnaryX)Diagnose*(i : INTEGER),EXTENSIBLE;
3065 BEGIN
3066 H.Indent(i);
3067 CASE s.kind OF
3068 | deref : Console.WriteString("'^' ");
3069 | compl : Console.WriteString("compl ");
3070 | sprMrk : Console.WriteString("super ");
3071 | neg : Console.WriteString("neg ");
3072 | absVl : Console.WriteString("ABS ");
3073 | entVl : Console.WriteString("ENTIER ");
3074 | capCh : Console.WriteString("CAP ");
3075 | strLen : Console.WriteString("strLen ");
3076 | strChk : Console.WriteString("strChk ");
3077 | mkStr : Console.WriteString("$ ");
3078 | tCheck : Console.WriteString("tCheck ");
3079 IF s.type # NIL THEN Console.WriteString(s.type.name()) END;
3080 END;
3081 PType(s.type);
3082 Console.WriteLn;
3083 Diag(i+4, s.kid);
3084 END Diagnose;
3085
3086 (* ------------------------------- *)
3087
3088 PROCEDURE (s : IdentX)Diagnose*(i : INTEGER);
3089 VAR name : FileNames.NameString;
3090 BEGIN
3091 H.Indent(i);
3092 D.getName.Of(s.ident, name);
3093 IF s.kind = sprMrk THEN Console.WriteString("sprMrk " + name);
3094 ELSIF s.kind = cvrtUp THEN Console.WriteString("cvrtUp: " + name);
3095 ELSIF s.kind = cvrtDn THEN Console.WriteString("cvrtDn: " + name);
3096 ELSE Console.WriteString("selct: " + name);
3097 END;
3098 Console.Write(' ');
3099 PType(s.type);
3100 Console.WriteLn;
3101 Diag(i+4, s.kid);
3102 END Diagnose;
3103
3104 (* ------------------------------- *)
3105
3106 PROCEDURE (s : CallX)Diagnose*(i : INTEGER);
3107 BEGIN
3108 H.Indent(i);
3109 IF s.kind = fnCall THEN
3110 Console.WriteString("CallX(fn) "); PType(s.type);
3111 ELSE
3112 Console.WriteString("CallX(pr)");
3113 END;
3114 Console.WriteLn;
3115 Diag(i+4, s.kid);
3116 END Diagnose;
3117
3118 (* ------------------------------- *)
3119
3120 PROCEDURE (s : BinaryX)Diagnose*(i : INTEGER);
3121 BEGIN
3122 H.Indent(i);
3123 CASE s.kind OF
3124 | index : Console.WriteString("index ");
3125 | range : Console.WriteString("range ");
3126 | lenOf : Console.WriteString("lenOf ");
3127 | maxOf : Console.WriteString("maxOf ");
3128 | minOf : Console.WriteString("minOf ");
3129 | bitAnd : Console.WriteString("bitAND ");
3130 | bitOr : Console.WriteString("bitOR ");
3131 | bitXor : Console.WriteString("bitXOR ");
3132 | plus : Console.WriteString("'+' ");
3133 | minus : Console.WriteString("'-' ");
3134 | greT : Console.WriteString("'>' ");
3135 | greEq : Console.WriteString("'>=' ");
3136 | notEq : Console.WriteString("'#' ");
3137 | lessEq : Console.WriteString("'<=' ");
3138 | lessT : Console.WriteString("'<' ");
3139 | equal : Console.WriteString("'=' ");
3140 | isOp : Console.WriteString("IS ");
3141 | inOp : Console.WriteString("IN ");
3142 | mult : Console.WriteString("'*' ");
3143 | slash : Console.WriteString("'/' ");
3144 | modOp : Console.WriteString("MOD ");
3145 | divOp : Console.WriteString("DIV ");
3146 | rem0op : Console.WriteString("REM0 ");
3147 | div0op : Console.WriteString("DIV0 ");
3148 | blNot : Console.WriteString("'~' ");
3149 | blOr : Console.WriteString("OR ");
3150 | blAnd : Console.WriteString("'&' ");
3151 | strCat : Console.WriteString("strCat ");
3152 | ashInt : Console.WriteString("ASH ");
3153 | lshInt : Console.WriteString("LSH ");
3154 | rotInt : Console.WriteString("ROT ");
3155 END;
3156 PType(s.type);
3157 Console.WriteLn;
3158 Diag(i+4, s.lKid);
3159 Diag(i+4, s.rKid);
3160 END Diagnose;
3161
3162 (* ============================================================ *)
3163 BEGIN (* ====================================================== *)
3164 END ExprDesc. (* ============================================== *)
3165 (* ============================================================ *)
3166
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024