1 (* ==================================================================== *)
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. *)
7 (* ==================================================================== *)
26 (* ============================================================ *)
28 CONST (* expr-kinds *)
30 qualId
* = 0; numLt
* = 1; realLt
* = 2; charLt
* = 3; strLt
* = 4;
31 nilLt
* = 5; tBool
* = 6; fBool
* = 7; setLt
* = 8; setXp
* = 9;
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;
40 typOf
* = 30; infLt
* = 31; nInfLt
* = 32;
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;
54 (* ============================================================ *)
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 *)
62 * ----------------------------------------- *)
64 END; (* ------------------------------ *)
66 IdLeaf
* = POINTER TO RECORD (LeafX
)
67 ident
* : D
.Idnt
; (* qualified-idnt *)
70 SetExp
* = POINTER TO RECORD (LeafX
)
75 (* ============================================================ *)
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 *)
83 * ----------------------------------------- *)
85 END; (* ------------------------------ *)
87 IdentX
* = POINTER TO RECORD (UnaryX
)
88 ident
* : D
.Idnt
; (* field selction *)
91 CallX
* = POINTER TO RECORD (UnaryX
)
95 (* ============================================================ *)
98 BinaryX
* = POINTER TO RECORD (D
.Expr
)
99 (* ... inherited from Expr ... ------------- *
100 * kind- : INTEGER; (* tag for unions *)
101 * token
* : S
.Token
; (* exp mark token *)
103 * ----------------------------------------- *)
106 END; (* ------------------------------ *)
108 (* ============================================================ *)
110 PROCEDURE isPowerOf2(val
: LONGINT) : BOOLEAN;
111 VAR lo
, hi
: INTEGER;
116 lo
:= RTS
.loInt(val
);
117 hi
:= RTS
.hiInt(val
);
119 RETURN BITS(lo
) * BITS(-lo
) = BITS(lo
);
121 RETURN BITS(hi
) * BITS(-hi
) = BITS(hi
);
128 (* -------------------------------------------- *)
130 PROCEDURE coverType(a
,b
: D
.Type
) : D
.Type
;
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
);
140 (* -------------------------------------------- *)
142 PROCEDURE log2(val
: LONGINT) : INTEGER;
143 VAR lo
, hi
, nm
: INTEGER;
145 lo
:= RTS
.loInt(val
);
146 hi
:= RTS
.hiInt(val
);
149 IF ODD(lo
) THEN RETURN nm
ELSE lo
:= lo
DIV 2 END;
152 FOR nm
:= 32 TO 63 DO
153 IF ODD(hi
) THEN RETURN nm
ELSE hi
:= hi
DIV 2 END;
156 THROW("Bad log2 argument");
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 (* ============================================================ *)
168 PROCEDURE mkLeafVal
*(k
: INTEGER; v
: L
.Value
) : LeafX
;
171 NEW(n
); n
.token
:= S
.prevTok
;
172 n
.SetKind(k
); n
.value
:= v
; RETURN n
;
175 (* -------------------------------------------- *)
177 PROCEDURE mkNilX
*() : LeafX
;
181 n
.type
:= Builtin
.anyPtr
;
182 n
.token
:= S
.prevTok
;
183 n
.SetKind(nilLt
); RETURN n
;
186 (* -------------------------------------------- *)
188 PROCEDURE mkInfX
*() : LeafX
;
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.
199 n
.type
:= Builtin
.sReaTp
;
200 n
.token
:= S
.prevTok
;
201 n
.SetKind(infLt
); RETURN n
;
204 (* -------------------------------------------- *)
206 PROCEDURE mkNegInfX
*() : LeafX
;
210 n
.type
:= Builtin
.sReaTp
;
211 n
.token
:= S
.prevTok
;
212 n
.SetKind(nInfLt
); RETURN n
;
215 (* -------------------------------------------- *)
217 PROCEDURE mkTrueX
*() : LeafX
;
221 n
.type
:= Builtin
.boolTp
;
222 n
.token
:= S
.prevTok
;
223 n
.SetKind(tBool
); RETURN n
;
226 (* -------------------------------------------- *)
228 PROCEDURE mkFalseX
*() : LeafX
;
232 n
.type
:= Builtin
.boolTp
;
233 n
.token
:= S
.prevTok
;
234 n
.SetKind(fBool
); RETURN n
;
237 (* -------------------------------------------- *)
239 PROCEDURE mkIdLeaf
*(id
: D
.Idnt
) : IdLeaf
;
244 l
.token
:= S
.prevTok
;
245 l
.SetKind(qualId
); l
.ident
:= id
; RETURN l
;
248 (* -------------------------------------------- *)
250 PROCEDURE mkEmptySet
*() : SetExp
;
254 l
.type
:= Builtin
.setTp
;
255 l
.token
:= S
.prevTok
;
256 l
.SetKind(setXp
); RETURN l
;
259 (* -------------------------------------------- *)
261 PROCEDURE mkSetLt
*(s
: SET) : SetExp
;
265 l
.token
:= S
.prevTok
;
267 l
.type
:= Builtin
.setTp
;
268 l
.value
:= L
.newSetVal(s
); RETURN l
;
271 (* -------------------------------------------- *)
273 PROCEDURE mkCharLt
*(ch
: CHAR) : LeafX
;
277 l
.token
:= S
.prevTok
;
278 l
.type
:= Builtin
.charTp
;
280 l
.value
:= L
.newChrVal(ch
); RETURN l
;
283 (* -------------------------------------------- *)
285 PROCEDURE mkNumLt
*(nm
: LONGINT) : LeafX
;
289 l
.token
:= S
.prevTok
;
291 IF (nm
<= MAX(INTEGER)) & (nm
>= MIN(INTEGER)) THEN
292 l
.type
:= Builtin
.intTp
;
294 l
.type
:= Builtin
.lIntTp
;
296 l
.value
:= L
.newIntVal(nm
); RETURN l
;
299 (* -------------------------------------------- *)
301 PROCEDURE mkRealLt
*(rv
: REAL) : LeafX
;
305 l
.token
:= S
.prevTok
;
306 l
.type
:= Builtin
.realTp
;
308 l
.value
:= L
.newFltVal(rv
); RETURN l
;
311 (* -------------------------------------------- *)
313 PROCEDURE mkStrLt
*(IN sv
: ARRAY OF CHAR) : LeafX
;
317 l
.token
:= S
.prevTok
;
319 l
.type
:= Builtin
.strTp
;
320 l
.value
:= L
.newStrVal(sv
); RETURN l
;
323 (* -------------------------------------------- *)
325 PROCEDURE mkStrLenLt
*(str
: L
.CharOpen
; len
: INTEGER) : LeafX
;
329 l
.token
:= S
.prevTok
;
331 l
.type
:= Builtin
.strTp
;
332 l
.value
:= L
.newStrLenVal(str
, len
); RETURN l
;
335 (* -------------------------------------------- *)
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. *)
343 l
.token
:= S
.prevTok
;
345 l
.type
:= Builtin
.strTp
;
346 l
.value
:= L
.newBufVal(pos
+1,len
-2); RETURN l
;
349 (* -------------------------------------------- *)
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. *)
357 l
.token
:= S
.prevTok
;
359 l
.type
:= Builtin
.strTp
;
360 l
.value
:= L
.escapedString(pos
+2,len
-3); RETURN l
;
363 (* ============================================================ *)
364 (* UnaryX Constructor methods *)
365 (* ============================================================ *)
367 PROCEDURE newUnaryX
*(tag
: INTEGER; kid
: D
.Expr
) : UnaryX
;
370 NEW(u
); u
.token
:= S
.prevTok
;
371 u
.SetKind(tag
); u
.kid
:= kid
; RETURN u
;
374 (* -------------------------------------------- *)
376 PROCEDURE mkDeref
*(kid
: D
.Expr
) : D
.Expr
;
379 new
:= newUnaryX(deref
, kid
);
380 new
.token
:= kid
.token
;
381 new
.type
:= kid
.type(T
.Pointer
).boundTp
;
385 (* ---------------------------- *)
387 PROCEDURE newIdentX
*(tag
: INTEGER; id
: D
.Idnt
; kid
: D
.Expr
) : IdentX
;
390 NEW(u
); u
.token
:= S
.prevTok
;
391 u
.SetKind(tag
); u
.ident
:= id
; u
.kid
:= kid
; RETURN u
;
394 (* -------------------------------------------- *)
396 PROCEDURE newCallX
*(tag
: INTEGER; prm
: D
.ExprSeq
; kid
: D
.Expr
) : CallX
;
401 * NEW(u); u.token := S.prevTok;
405 NEW(u
); u
.token
:= kid
.token
;
406 u
.SetKind(tag
); u
.actuals
:= prm
; u
.kid
:= kid
; RETURN u
;
409 (* -------------------------------------------- *)
411 PROCEDURE newCallT
*(tag
: INTEGER; prm
: D
.ExprSeq
;
412 kid
: D
.Expr
; tok
: S
.Token
) : CallX
;
415 NEW(u
); u
.token
:= tok
;
416 u
.SetKind(tag
); u
.actuals
:= prm
; u
.kid
:= kid
; RETURN u
;
419 (* ============================================================ *)
420 (* BinaryX Constructor methods *)
421 (* ============================================================ *)
423 PROCEDURE newBinaryX
*(tag
: INTEGER; lSub
,rSub
: D
.Expr
) : BinaryX
;
426 NEW(b
); b
.token
:= S
.prevTok
;
427 b
.SetKind(tag
); b
.lKid
:= lSub
; b
.rKid
:= rSub
; RETURN b
;
430 (* -------------------------------------------- *)
432 PROCEDURE newBinaryT
*(k
: INTEGER; l
,r
: D
.Expr
; t
: S
.Token
) : BinaryX
;
435 NEW(b
); b
.token
:= t
;
436 b
.SetKind(k
); b
.lKid
:= l
; b
.rKid
:= r
; RETURN b
;
439 (* -------------------------------------------- *)
441 PROCEDURE maxOfType
*(t
: T
.Base
) : LeafX
;
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);
459 (* -------------------------------------------- *)
461 PROCEDURE minOfType
*(t
: T
.Base
) : LeafX
;
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 *)
472 * | T.sReaN : RETURN mkRealLt(MIN(SHORTREAL)); (* production version *)
473 * | T
.realN
: RETURN mkRealLt(MIN(REAL)); (* production version *)
476 T
.charN
: RETURN mkCharLt(0X
);
477 | T
.setN
: RETURN mkNumLt(0);
483 (* ============================================================ *)
485 PROCEDURE coerceUp
*(x
: D
.Expr
; t
: D
.Type
) : D
.Expr
;
487 * Fix to string arrays coerced to native strings: kjg April 2006
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
;
497 RETURN mkRealLt(x(LeafX
).value
.long());
500 x
.type
:= t
; RETURN x
;
502 RETURN convert(x
, t
);
506 (* ============================================================ *)
507 (* Various attribution methods *)
508 (* ============================================================ *)
510 PROCEDURE (i
: LeafX
)TypeErase
*() : D
.Expr
, EXTENSIBLE
;
511 (* If the type of the leaf is a compound, it must be erased *)
513 IF i
.type
.isCompoundType() THEN
514 Console
.WriteString("FOUND A COMPOUND LEAFX!");Console
.WriteLn
;
519 PROCEDURE (i
: IdLeaf
)TypeErase
*() : D
.Expr
;
524 PROCEDURE (i
: SetExp
)TypeErase
*() : D
.Expr
;
529 FOR index
:= 0 TO i
.varSeq
.tide
- 1 DO
530 exprN
:= i
.varSeq
.a
[index
];
532 exprN
:= exprN
.TypeErase();
538 PROCEDURE (i
: UnaryX
)TypeErase
*() : D
.Expr
,EXTENSIBLE
;
540 IF i
.kid
= NIL THEN RETURN NIL END;
541 i
.kid
:= i
.kid
.TypeErase();
542 IF i
.kid
= NIL THEN RETURN NIL END;
546 PROCEDURE (i
: IdentX
)TypeErase
*() : D
.Expr
;
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
554 RETURN i
; END TypeErase
;
556 PROCEDURE (i
: CallX
)TypeErase
*() : D
.Expr
;
561 FOR index
:= 0 TO i
.actuals
.tide
- 1 DO
562 exprN
:= i
.actuals
.a
[index
];
564 exprN
:= exprN
.TypeErase();
570 PROCEDURE (i
: BinaryX
)TypeErase
*() : D
.Expr
;
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;
580 (* -------------------------------------------- *)
582 PROCEDURE isRelop(op
: INTEGER) : BOOLEAN;
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
);
589 (* -------------------------------------------- *)
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. *)
597 IF ~
(exp
IS IdLeaf
) THEN RETURN NIL END;
599 IF ~
(leaf
.ident
IS I
.TypId
) THEN RETURN NIL END;
604 (* -------------------------------------------- *)
606 PROCEDURE CheckIsVariable
*(e
: D
.Expr
);
610 IF (e
= NIL) THEN RETURN; END;
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
);
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
));
618 isVar
:= e
.kind
= index
;
620 IF e
.kind
= tCheck
THEN
624 isVar
:= e
.kind
= deref
;
629 IF (~isVar
) THEN e
.ExprError(85); END;
632 (* -------------------------------------------- *)
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
;
642 (* -------------------------------------------- *)
644 PROCEDURE (i
: IdLeaf
)exprAttr
*() : D
.Expr
;
645 (* If this references a constant, then return literal *)
646 (* ----------------------------------------- *)
647 PROCEDURE constClone(i
: IdLeaf
) : D
.Expr
;
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 * ----------------------------------------- *)
657 conXp
:= i
.ident(I
.ConId
).conExp
;
658 WITH conXp
: SetExp
DO
659 clone
:= mkSetLt({});
660 clone
.value
:= conXp
.value
;
662 clone
:= mkLeafVal(conXp
.kind
, conXp
.value
);
663 clone
.type
:= conXp
.type
;
665 clone
.token
:= i
.token
;
668 (* --------------------------------- *)
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;
680 RETURN constClone(i
);
687 (* -------------------------------------------- *)
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 *)
697 (* ----------------------------------- *)
699 PROCEDURE isLitRange(exp
: BinaryX
) : BOOLEAN;
701 RETURN (exp
.lKid
# NIL) &
703 (exp
.lKid
.kind
= numLt
) &
704 (exp
.rKid
.kind
= numLt
);
707 (* ----------------------------------- *)
709 PROCEDURE mkSetFromRange(exp
: BinaryX
) : SET;
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;
720 (* ----------------------------------- *)
722 BEGIN (* body of (i : SetExp)exprAttr *)
725 FOR index
:= 0 TO i
.varSeq
.tide
- 1 DO
726 exprN
:= i
.varSeq
.a
[index
];
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
734 exprN
.ExprError(303);
736 ELSIF exprN
.kind
= range
THEN
737 rngXp
:= exprN(BinaryX
);
738 IF isLitRange(rngXp
) THEN (* const elem range *)
739 cPart
:= cPart
+ mkSetFromRange(rngXp
);
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
);
745 ELSE (* variable element(s) *)
746 IF ~exprN
.isIntExpr() THEN exprN
.ExprError(37) END;
747 i
.varSeq
.a
[write
] := exprN
; INC(write
);
751 IF write
# i
.varSeq
.tide
THEN (* expression changed *)
752 i
.value
:= L
.newSetVal(cPart
);
753 IF write
= 0 THEN (* set is all constant *)
756 i
.varSeq
.ResetTo(write
); (* truncate elem list *)
757 ELSIF write
= 0 THEN (* this is empty set *)
760 i
.type
:= Builtin
.setTp
;
764 (* -------------------------------------------- *)
766 PROCEDURE (i
: UnaryX
)exprAttr
*() : D
.Expr
,EXTENSIBLE
;
770 IF i
.kid
= NIL THEN RETURN NIL END;
771 i
.kid
:= i
.kid
.exprAttr();
772 IF i
.kid
= NIL THEN RETURN NIL END;
775 | neg
: (* Fold constants and mark sets *)
776 IF i
.kid
.kind
= setXp
THEN
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());
783 ELSIF i
.kid
.kind
= numLt
THEN
784 leaf
:= i
.kid(LeafX
);
785 leaf
.value
:= L
.newIntVal(-leaf
.value
.long());
787 ELSIF i
.kid
.kind
= realLt
THEN
788 leaf
:= i
.kid(LeafX
);
789 leaf
.value
:= L
.newFltVal(-leaf
.value
.real());
792 i
.type
:= i
.kid
.type
;
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
800 ELSIF i
.kid
.kind
= fBool
THEN
803 i
.type
:= Builtin
.boolTp
;
805 ELSE (* Nothing to do. Parser did type check already *)
806 (* mkStr, absVl, convert, capCh, entVl, strLen, lenOf, oddTst *)
812 (* -------------------------------------------- *)
814 PROCEDURE (i
: IdentX
)exprAttr
*() : D
.Expr
;
816 IF (i
.kind
= selct
) & (i
.ident
# NIL) & (i
.ident
IS I
.ConId
) THEN
817 RETURN i
.ident(I
.ConId
).conExp
.exprAttr();
819 ASSERT((i
.kind
= selct
) OR
820 (i
.kind
= cvrtUp
) OR (i
.kind
= cvrtDn
));
825 (* -------------------------------------------- *)
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
;
832 (* -------------------------------------------- *)
834 PROCEDURE checkCall
*(i
: CallX
) : D
.Expr
;
835 VAR prTp
: T
.Procedure
;
838 (* --------------------------- *)
840 PROCEDURE length(arg0
: D
.Expr
; arg1
: LeafX
) : D
.Expr
;
846 dimN
:= arg1
.value
.int();
847 IF dimN
< 0 THEN arg1
.ExprError(46); RETURN NIL END;
850 * Take care of LEN(typename) case ... kjg December 2004
852 WITH arg0
: IdLeaf
DO
853 IF arg0
.ident
IS I
.TypId
THEN arg0
.type
:= arg0
.ident
.type
END;
857 IF arg0
.type
.kind
= T
.ptrTp
THEN arg0
:= mkDeref(arg0
) END;
860 IF cTyp
.kind
= T
.vecTp
THEN
861 IF dimN
# 0 THEN arg1
.ExprError(231) END;
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
;
868 arg1
.ExprError(40); RETURN NIL;
872 IF cLen
= 0 THEN (* must compute at runtime *)
873 RETURN newBinaryX(lenOf
, arg0
, arg1
);
875 RETURN mkNumLt(cLen
);
879 (* --------------------------- *)
881 PROCEDURE stdFunction(i
: CallX
; act
: D
.ExprSeq
) : D
.Expr
;
882 (* Assert: prc holds a procedure ident descriptor of a standard Fn. *)
896 prc
:= i
.kid(IdLeaf
);
900 funI
:= prc
.ident(I
.PrcId
);
902 IF act
.tide
>= 1 THEN
904 IF arg0
# NIL THEN arg0
:= arg0
.exprAttr() END;
905 IF act
.tide
>= 2 THEN
907 IF arg1
# NIL THEN arg1
:= arg1
.exprAttr() END;
908 IF arg1
= NIL THEN RETURN NIL END;
910 IF arg0
= NIL THEN RETURN NIL END;
913 * Now we check the per-case semantics.
916 (* ---------------------------- *)
918 IF act
.tide
= 0 THEN prc
.ExprError(22);
919 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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;
926 ELSIF arg0
.kind
= realLt
THEN
927 rslt
:= mkRealLt(ABS(arg0(LeafX
).value
.real()));
929 rslt
:= newUnaryX(absVl
, arg0
);
931 rslt
.type
:= arg0
.type
;
936 (* ---------------------------- *)
937 (* Extended to LONGINT (1:01:2013) *)
938 (* ---------------------------- *)
940 IF act
.tide
< 2 THEN prc
.ExprError(22);
941 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
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()));
951 IF arg0
.type
= Builtin
.lIntTp
THEN
952 dstT
:= Builtin
.lIntTp
;
954 IF arg0
.type
# Builtin
.intTp
THEN
955 arg0
:= convert(arg0
, Builtin
.intTp
);
957 dstT
:= Builtin
.intTp
;
959 IF arg1
.type
# Builtin
.intTp
THEN
960 arg1
:= convert(arg1
, Builtin
.intTp
);
962 rslt
:= newBinaryX(ashInt
, arg0
, arg1
);
968 (* ---------------------------- *)
970 IF act
.tide
< 2 THEN prc
.ExprError(22);
971 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
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
;
979 IF arg0
.type
# Builtin
.intTp
THEN
980 arg0
:= convert(arg0
, Builtin
.intTp
);
982 dstT
:= Builtin
.intTp
;
984 IF arg1
.type
# Builtin
.intTp
THEN
985 arg1
:= convert(arg1
, Builtin
.intTp
);
987 rslt
:= newBinaryX(lshInt
, arg0
, arg1
);
990 (* ---------------------------- *)
992 IF act
.tide
< 2 THEN prc
.ExprError(22);
993 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
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
);
1001 rslt
:= newBinaryX(rotInt
, arg0
, arg1
);
1002 rslt
.type
:= arg0
.type
;
1004 (* ---------------------------- *)
1006 IF act
.tide
< 1 THEN prc
.ExprError(22);
1007 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
1010 IF rslt
.isIntExpr() THEN
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.
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
;
1028 (* Graft an unchecked conversion onto the *)
1029 (* root of the argument expression tree. *)
1030 rslt
:= convert(rslt
, Builtin
.setTp
);
1036 (* ---------------------------- *)
1038 IF act
.tide
= 0 THEN prc
.ExprError(22);
1039 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
1041 IF arg0
.isCharExpr() THEN
1042 IF arg0
.isCharLit() THEN
1043 rslt
:= mkCharLt(CAP(arg0(LeafX
).charValue()));
1045 rslt
:= newUnaryX(capCh
, arg0
);
1047 rslt
.type
:= Builtin
.charTp
;
1052 (* ---------------------------- *)
1054 IF act
.tide
= 0 THEN prc
.ExprError(22);
1055 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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
;
1067 rslt
:= convert(arg0
, Builtin
.charTp
);
1073 (* ---------------------------- *)
1075 IF act
.tide
= 0 THEN prc
.ExprError(22);
1076 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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
1084 ELSIF i
.inRangeOf(Builtin
.intTp
) THEN
1085 dstT
:= Builtin
.intTp
;
1089 rslt
:= newUnaryX(entVl
, arg0
);
1096 (* ---------------------------- *)
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));
1109 IF act
.tide
= 2 THEN
1111 IF arg1
.kind
= numLt
THEN
1112 rslt
:= length(arg0
, arg1(LeafX
));
1117 IF rslt
# NIL THEN rslt
.type
:= Builtin
.intTp
END;
1118 (* ---------------------------- *)
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
);
1126 rslt
.SetKind(typOf
);
1127 ELSIF arg0
.isVarDesig() THEN
1128 IF arg0
.type
.isDynamicType() THEN
1129 rslt
:= newUnaryX(getTp
, arg0
);
1132 IF dstT
.idnt
= NIL THEN (* Anonymous type *)
1133 dstT
.idnt
:= I
.newAnonId(dstT
.serial
);
1134 dstT
.idnt
.type
:= dstT
;
1136 rslt
:= mkIdLeaf(dstT
.idnt
);
1137 rslt
.SetKind(typOf
);
1139 ELSE arg0
.ExprError(85);
1141 IF rslt
# NIL THEN rslt
.type
:= G
.ntvTyp
END;
1142 (* ---------------------------- *)
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);
1151 IF rslt
# NIL THEN rslt
.type
:= Builtin
.intTp
END;
1152 (* ---------------------------- *)
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
));
1163 rslt
:= minOfType(dstT(T
.Base
));
1165 IF rslt
# NIL THEN rslt
.type
:= dstT
END;
1166 ELSE (* must be the MAX(exp1, exp2) case *)
1168 * Note that for literals, coverType is always >= int.
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());
1176 lVal
:= MIN(arg0(LeafX
).value
.long(),arg1(LeafX
).value
.long());
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());
1183 rVal
:= MIN(arg0(LeafX
).value
.real(),arg1(LeafX
).value
.real());
1185 rslt
:= mkRealLt(rVal
);
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
)
1192 rslt
:= newBinaryX(minOf
, arg0
, arg1
)
1195 IF rslt
# NIL THEN rslt
.type
:= dstT
END;
1197 (* ---------------------------- *)
1199 IF act
.tide
= 0 THEN prc
.ExprError(22);
1200 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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
1210 ELSE (* else leave to runtime*)
1211 rslt
:= newUnaryX(oddTst
, rslt
);
1213 rslt
.type
:= Builtin
.boolTp
;
1215 (* ---------------------------- *)
1217 IF act
.tide
= 0 THEN prc
.ExprError(22);
1218 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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
);
1230 rslt
.type
:= Builtin
.intTp
;
1232 (* ---------------------------- *)
1234 IF act
.tide
= 0 THEN prc
.ExprError(22);
1235 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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
);
1244 rslt
.ExprError(226);
1248 (* ---------------------------- *)
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
1256 rslt
:= newUnaryX(mkNStr
, arg0
);
1257 rslt
.type
:= G
.ntvStr
;
1258 (* ---------------------------- *)
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);
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
);
1270 ptrT
:= T
.newPtrTp();
1271 ptrT
.boundTp
:= typ0
;
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
);
1281 ptrT
:= T
.newPtrTp();
1282 IF typ0
.isStringType() THEN
1283 ptrT
.boundTp
:= Builtin
.chrArr
;
1285 arg0
.ExprError(140);
1290 (* ---------------------------- *)
1292 IF act
.tide
= 0 THEN prc
.ExprError(22);
1293 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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
;
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
;
1314 IF rslt
.kind
= numLt
THEN
1315 IF ~rslt
.inRangeOf(dstT
) THEN rslt
.ExprError(26) END;
1317 rslt
:= convert(rslt
, dstT
);
1321 (* ---------------------------- *)
1323 IF act
.tide
= 0 THEN prc
.ExprError(22);
1324 ELSIF act
.tide
> 1 THEN prc
.ExprError(23);
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
;
1334 rslt
:= convert(rslt
, dstT
);
1336 (* ---------------------------- *)
1339 (* ---------------------------- *)
1346 (* --------------------------- *)
1348 PROCEDURE StdProcedure(i
: CallX
; act
: D
.ExprSeq
);
1349 (* Assert: prc holds a procedure ident descriptor of a standard Pr. *)
1360 (* --------------------------- *)
1361 PROCEDURE CheckNonZero(arg
: D
.Expr
);
1363 IF arg(LeafX
).value
.int() <= 0 THEN arg
.ExprError(68) END;
1365 (* --------------------------- *)
1367 prc
:= i
.kid(IdLeaf
);
1370 funI
:= prc
.ident(I
.PrcId
);
1371 funN
:= funI
.stdOrd
;
1372 IF act
.tide
>= 1 THEN
1373 arg0
:= act
.a
[0].exprAttr();
1375 IF act
.tide
>= 2 THEN
1376 arg1
:= act
.a
[1].exprAttr();
1377 IF arg1
= NIL THEN RETURN END;
1380 IF arg0
= NIL THEN RETURN END;
1383 * Now we check the per-case semantics.
1386 (* ---------------------------- *)
1388 IF act
.tide
= 0 THEN prc
.ExprError(22);
1389 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
1391 IF arg0
.type
# Builtin
.boolTp
THEN
1394 IF (arg1
# NIL) & (arg1
.kind
# numLt
) THEN
1398 (* ---------------------------- *)
1401 IF act
.tide
= 0 THEN prc
.ExprError(22);
1402 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
1404 IF arg0
.isVarDesig() THEN
1405 arg0
.CheckWriteable();
1406 IF ~arg0
.isIntExpr() THEN arg0
.ExprError(37) END;
1411 D
.AppendExpr(act
, mkNumLt(1));
1412 ELSIF ~arg1
.isIntExpr() THEN
1416 (* ---------------------------- *)
1419 IF act
.tide
< 2 THEN prc
.ExprError(22);
1420 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
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;
1429 IF arg1
.isIntExpr() THEN
1430 IF (arg1
.kind
= numLt
) & (* Should be warning only? *)
1431 ~arg1
.inRangeOf(Builtin
.setTp
) THEN arg1
.ExprError(303) END;
1436 (* ---------------------------- *)
1438 IF act
.tide
= 0 THEN prc
.ExprError(22);
1439 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
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;
1445 (* ---------------------------- *)
1447 IF act
.tide
= 0 THEN prc
.ExprError(22);
1448 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
1450 IF arg0
.type
# Builtin
.intTp
THEN arg0
.ExprError(37) END;
1451 IF arg1
.type
.kind
# T
.basTp
THEN arg1
.ExprError(48) END;
1453 (* ---------------------------- *)
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;
1463 IF ~arg1
.isIntExpr() THEN arg1
.ExprError(37) END;
1464 (* ---------------------------- *)
1466 IF act
.tide
< 2 THEN prc
.ExprError(22);
1467 ELSIF act
.tide
> 2 THEN prc
.ExprError(23);
1468 ELSIF arg0
.isVarDesig() THEN
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;
1482 IF errN
# 83 THEN arg1
.ExprError(errN
);
1483 ELSE D
.RepTypesErrTok(83, argT
.elemTp
, arg1
.type
, arg1
.token
);
1487 arg0
.ExprError(229);
1492 (* ---------------------------- *)
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);
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;
1508 (* ---------------------------- *)
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);
1514 (* ---------------------------- *)
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);
1523 (* ---------------------------- *)
1525 IF act
.tide
= 0 THEN prc
.ExprError(22);
1526 ELSIF arg0
.type
# NIL THEN
1528 IF ~arg0
.isVarDesig() THEN
1531 arg0
.CheckWriteable();
1532 WITH argT
: T
.Base
DO
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
1539 ELSIF arg1
.kind
= numLt
THEN
1542 | argT
: T
.Pointer
DO
1543 bndT
:= argT
.boundTp
;
1544 IF act
.tide
= 1 THEN
1546 * Bound-type must be a record or a fixed
1547 * length, one-dimensional array type.
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;
1558 * This must be a possibly multi-dimensional array type.
1560 IF ~bndT
.isOpenArrType() THEN
1562 ELSIF ~arg1
.isIntExpr() THEN
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
1572 ELSIF ~arg1
.isIntExpr() THEN
1575 bndT
:= bndT(T
.Array
).elemTp
;
1577 act
.a
[argN
] := arg1
; (* update expression *)
1579 (* check if we need more length params *)
1580 IF bndT
.isOpenArrType() THEN arg1
.ExprError(100) END;
1585 END; (* with argT *)
1586 END; (* if isVarDesig() *)
1588 (* ---------------------------- *)
1594 (* --------------------------- *)
1596 BEGIN (* body of checkCall *)
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
1605 FormalsVsActuals(prXp
, i
.actuals
);
1606 IF prTp
.retType
# NIL THEN i
.ExprError(74) END;
1609 ELSIF i
.kind
= fnCall
THEN
1610 IF prXp
.isStdFunc() THEN
1611 RETURN stdFunction(i
, i
.actuals
);
1613 FormalsVsActuals(prXp
, i
.actuals
);
1614 IF prTp
.retType
= NIL THEN
1616 ELSIF prTp
.retType
IS T
.Opaque
THEN
1617 prTp
.retType
:= prTp
.retType
.elaboration();
1619 i
.type
:= prTp
.retType
;
1622 Console
.WriteString("unexpected callx"); Console
.WriteLn
; i
.Diagnose(0);
1627 (* -------------------------------------------- *)
1629 PROCEDURE CheckSuper
*(c
: CallX
; s
: D
.Scope
);
1630 VAR kid1
, kid2
: D
.Expr
;
1632 (* ------------------------------------------------- *
1633 * Precondition: c.kid.kind = sprMrk.
1634 * The only correct expression cases are
1637 * IdentX --- (kind = sprMrk)
1638 * IdLeaf --- (ident = s(MthId).rcvFrm)
1641 * IdentX --- (kind = sprMrk)
1642 * UnaryX --- (kind = deref)
1643 * IdLeaf --- (ident = s(MthId).rcvFrm)
1645 * ------------------------------------------------- *)
1647 kid1
.ExprError(300); (* A warning only ... *)
1648 WITH kid1
: IdentX
DO
1650 IF kid2
.kind
= deref
THEN kid2
:= kid2(UnaryX
).kid
END;
1651 WITH kid2
: IdLeaf
DO
1653 IF kid2
.ident
# s
.rcvFrm
THEN c
.ExprError(166) END;
1665 (* -------------------------------------------- *)
1667 PROCEDURE (i
: BinaryX
)exprAttr
*() : D
.Expr
;
1671 (* --------------------------- *)
1673 PROCEDURE chrOp(i
: BinaryX
) : D
.Expr
;
1679 IF i
.lKid
.isCharLit() & i
.rKid
.isCharLit() THEN
1680 ch1
:= i
.lKid(LeafX
).charValue();
1681 ch2
:= i
.rKid(LeafX
).charValue();
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;
1696 ELSIF ~
isRelop(i
.kind
) THEN
1699 i
.lKid
.type
:= Builtin
.charTp
;
1700 i
.rKid
.type
:= Builtin
.charTp
;
1702 rslt
.type
:= Builtin
.boolTp
; RETURN rslt
;
1705 (* --------------------------- *)
1707 PROCEDURE strOp(i
: BinaryX
) : 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();
1716 IF i
.kind
= plus
THEN
1718 rslt
:= mkLeafVal(strLt
, L
.concat(i
.lKid(LeafX
).value
,
1719 i
.rKid(LeafX
).value
));
1721 i
.SetKind(strCat
); (* can't assign via rslt, it is readonly! *)
1723 rslt
.type
:= Builtin
.strTp
;
1724 ELSIF isRelop(i
.kind
) THEN
1726 sRes
:= L
.strCmp(i
.lKid(LeafX
).value
, i
.rKid(LeafX
).value
);
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;
1740 (* ELSE nothing to do *)
1742 rslt
.type
:= Builtin
.boolTp
;
1744 i
.ExprError(171); RETURN NIL;
1749 (* --------------------------- *)
1751 PROCEDURE setOp(i
: BinaryX
) : D
.Expr
;
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();
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);
1776 IF rsTp
# Builtin
.boolTp
THEN
1777 newX
:= mkSetLt(dSet
);
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);
1796 newX
.type
:= rsTp
; RETURN newX
;
1799 (* --------------------------- *)
1801 PROCEDURE numOp(i
: BinaryX
) : D
.Expr
;
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
;
1814 rsTp
:= coverType(i
.lKid
.type
, i
.rKid
.type
);
1815 IF rsTp
= NIL THEN i
.ExprError(38); RETURN NIL 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;
1821 IF (i
.lKid
.kind
= numLt
) & (i
.rKid
.kind
= numLt
) THEN
1822 lVal
:= i
.lKid(LeafX
).value
;
1823 rVal
:= i
.rKid(LeafX
).value
;
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
);
1831 | rem0op
: dVal
:= L
.rem0V(lVal
, rVal
);
1832 | div0op
: dVal
:= L
.div0V(lVal
, rVal
);
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);
1843 IF rsTp
= Builtin
.realTp
THEN
1844 newX
:= mkRealLt(dFlt
);
1845 ELSIF rsTp
# Builtin
.boolTp
THEN (* ==> some int type *)
1846 newX
:= mkLeafVal(numLt
, dVal
);
1852 ELSIF (i
.lKid
.kind
= realLt
) & (i
.rKid
.kind
= realLt
) THEN
1853 lFlt
:= i
.lKid(LeafX
).value
.real(); rFlt
:= i
.rKid(LeafX
).value
.real();
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);
1867 IF rsTp
# Builtin
.boolTp
THEN
1868 newX
:= mkRealLt(dFlt
);
1875 * SHOULD FOLD IEEE INFINITIES HERE!
1879 | plus
, minus
, mult
, slash
:
1882 IF rsTp
.isRealType() THEN i
.ExprError(45) END;
1884 IF rsTp
.isRealType() THEN
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
1891 i
.rKid
:= mkNumLt(rLit
- 1);
1894 i
.rKid
:= mkNumLt(-log2(rLit
)); (* neg ==> right shift *)
1898 | greT
, greEq
, notEq
, lessEq
, lessT
, equal
:
1899 rsTp
:= Builtin
.boolTp
;
1900 ELSE i
.ExprError(171);
1904 newX
.type
:= rsTp
; RETURN newX
;
1907 (* --------------------------- *)
1909 PROCEDURE isTest(b
: BinaryX
) : D
.Expr
;
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
;
1920 (* --------------------------- *)
1922 PROCEDURE inTest(b
: BinaryX
) : D
.Expr
;
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;
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
1939 rslt
.type
:= Builtin
.boolTp
; RETURN rslt
;
1942 (* --------------------------- *)
1944 PROCEDURE EqualOkCheck(node
: BinaryX
);
1945 VAR lTp
,rTp
: D
.Type
;
1947 lTp
:= node
.lKid
.type
;
1948 rTp
:= node
.rKid
.type
;
1949 IF (lTp
= NIL) OR (rTp
= NIL) THEN RETURN END;
1951 * The permitted cases here are:
1952 * comparisons of Booleans
1953 * comparisons of pointers (maybe sanity checked?)
1954 * comparisons of procedures (maybe sanity checked?)
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
;
1961 D
.RepTypesErrTok(57, node
.lKid
.type
, node
.rKid
.type
, node
.token
);
1965 (* --------------------------- *)
1967 PROCEDURE boolBinOp(i
: BinaryX
) : D
.Expr
;
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 *)
1976 rslt
:= i
.rKid
; (* return the rhs-expr *)
1978 ELSIF i
.lKid
.kind
= fBool
THEN
1979 IF i
.kind
= blOr
THEN
1980 rslt
:= i
.rKid
; (* return the rhs-expr *)
1982 rslt
:= i
.lKid
; (* return the FALSE *)
1986 rslt
.type
:= Builtin
.boolTp
;
1991 (* --------------------------- *)
1993 BEGIN (* BinaryX exprAttr body *)
1997 * The following cases are fully attributed already
1998 * perhaps as a result of a call of checkCall()
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;
2004 * First, attribute the subtrees.
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;
2011 * Deal with unique cases first... IN and IS, then OR and &
2013 IF kind
= range
THEN
2015 ELSIF kind
= inOp
THEN
2017 ELSIF kind
= isOp
THEN
2019 ELSIF (kind
= blOr
) OR
2021 rslt
:= boolBinOp(i
);
2023 * Deal with set-valued expressions, including constant folding.
2025 ELSIF i
.lKid
.isSetExpr() THEN
2028 * Deal with numerical expressions, including constant folding.
2029 * Note that we test the right subtree, to avoid (num IN set) case.
2031 ELSIF i
.rKid
.isNumericExpr() THEN
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.
2038 ELSIF (i
.lKid
.isString() OR i
.lKid
.isCharArray()) &
2039 (i
.rKid
.isString() OR i
.rKid
.isCharArray()) THEN
2042 * Deal with character expressions, including constant folding.
2044 ELSIF i
.lKid
.isCharExpr() & i
.rKid
.isCharExpr() THEN
2047 * Now all the irregular cases.
2049 ELSIF (kind
= equal
) OR (kind
= notEq
) THEN
2051 i
.type
:= Builtin
.boolTp
;
2059 (* ============================================================ *)
2060 (* Flow attribution for actual parameter lists *)
2061 (* ============================================================ *)
2063 PROCEDURE (cXp
: CallX
)liveActuals(scp
: D
.Scope
;
2064 set
: V
.VarSet
) : V
.VarSet
,NEW;
2072 new
:= set
.newCopy();
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
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.
2084 new
:= act
.checkLive(scp
, set
).cup(new
);
2086 new
:= act
.assignLive(scp
, new
);
2090 * If locals are uplevel addressed we presume that they
2091 * might be initialized by any call of a nested procedure.
2093 IF scp
IS I
.Procs
THEN
2094 WITH xKd
: IdentX
DO
2095 IF xKd
.ident
.dfScp
= scp
THEN scp
.UplevelInitialize(new
) END;
2097 IF xKd
.ident
.dfScp
= scp
THEN scp
.UplevelInitialize(new
) END;
2099 ASSERT(xKd
.kind
= tCheck
);
2102 (* #### kjg, Sep-2001 *)
2106 (* -------------------------------------------- *)
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. *)
2118 funI
:= x
.kid(IdLeaf
).ident(I
.PrcId
);
2119 funN
:= funI
.stdOrd
;
2120 arg0
:= x
.actuals
.a
[0];
2122 * Now we check the per-case semantics.
2124 IF funN
= Builtin
.newP
THEN
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.
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
));
2139 tmpS
:= tmpS
.cup(arg0
.assignLive(scp
, set
));
2141 tmpS
:= arg0
.assignLive(scp
, set
);
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
));
2163 (* ============================================================ *)
2164 (* Flow attribution for leaves: nothing to do for LeafX *)
2165 (* ============================================================ *)
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. *)
2172 IF (x
.ident
.kind
# I
.conId
) &
2173 (x
.ident
.dfScp
= scp
) &
2174 ~x
.ident
.isIn(lIn
) THEN
2175 IF x
.isPointerExpr() THEN
2184 (* -------------------------------------------- *)
2186 PROCEDURE (x
: SetExp
)checkLive
*(scp
: D
.Scope
;
2187 lIn
: V
.VarSet
) : V
.VarSet
;
2188 (* Assert: expression has been fully attributed. *)
2190 (* Really: recurse over set elements *)
2194 (* -------------------------------------------- *)
2196 PROCEDURE (x
: LeafX
)BoolLive
*(scp
: D
.Scope
;
2198 OUT tru
,fal
: V
.VarSet
);
2200 IF x
.kind
= tBool
THEN
2202 fal
:= V
.newUniv(set
.cardinality());
2203 ELSIF x
.kind
= fBool
THEN
2204 tru
:= V
.newUniv(set
.cardinality());
2207 tru
:= x
.checkLive(scp
, set
);
2212 (* ============================================================ *)
2213 (* Flow attribution for unaries: nothing to do for IdentX *)
2214 (* ============================================================ *)
2216 PROCEDURE (x
: UnaryX
)BoolLive
*(scp
: D
.Scope
;
2218 OUT tru
,fal
: V
.VarSet
);
2220 IF x
.kind
= blNot
THEN
2221 x
.kid
.BoolLive(scp
, set
, fal
, tru
);
2223 tru
:= x
.checkLive(scp
, set
);
2228 (* -------------------------------------------- *)
2230 PROCEDURE (x
: UnaryX
)checkLive
*(scp
: D
.Scope
;
2231 lIn
: V
.VarSet
) : V
.VarSet
,EXTENSIBLE
;
2232 (* Assert: expression has been fully attributed. *)
2234 RETURN x
.kid
.checkLive(scp
, lIn
);
2237 (* -------------------------------------------- *)
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
;
2244 tmpS
:= x
.kid
.checkLive(scp
, lIn
);
2245 IF (x
.kind
= prCall
) & x
.kid
.isStdProc() THEN
2246 RETURN x
.liveStdProc(scp
, tmpS
);
2248 RETURN x
.liveActuals(scp
, tmpS
);
2252 (* ============================================================ *)
2253 (* Flow attribution for binary expressions *)
2254 (* ============================================================ *)
2256 PROCEDURE (x
: BinaryX
)BoolLive
*(scp
: D
.Scope
;
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
;
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
);
2272 tru
:= x
.checkLive(scp
, set
);
2277 (* -------------------------------------------- *)
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
;
2288 IF (x
.kind
= blOr
) OR (x
.kind
= blAnd
) THEN
2289 x
.lKid
.BoolLive(scp
, lIn
, tSet
, fSet
);
2290 IF x
.kind
= blOr
THEN
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).
2298 RETURN tSet
.cap(x
.rKid
.checkLive(scp
, fSet
));
2299 ELSE (* x.kind = blAnd *)
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).
2307 RETURN fSet
.cap(x
.rKid
.checkLive(scp
, tSet
));
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
));
2315 (* ============================================================ *)
2316 (* Assign flow attribution for qualified id expressions *)
2317 (* ============================================================ *)
2319 PROCEDURE (p
: IdLeaf
)assignLive
*(scpe
: D
.Scope
;
2320 lvIn
: V
.VarSet
) : V
.VarSet
;
2321 VAR tmpS
: V
.VarSet
;
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
);
2333 (* ============================================================ *)
2334 (* Predicates on Expr extensions *)
2335 (* ============================================================ *)
2337 PROCEDURE (x
: IdLeaf
)hasDynamicType
*() : BOOLEAN;
2339 RETURN (x
.ident
# NIL) & x
.ident
.isDynamic();
2342 (* -------------------------------------------- *)
2343 (* -------------------------------------------- *)
2345 PROCEDURE (x
: IdLeaf
)isWriteable
*() : BOOLEAN;
2346 (* A qualident is writeable if the IdLeaf is writeable *)
2348 RETURN x
.ident
.mutable();
2351 PROCEDURE (x
: IdLeaf
)CheckWriteable
*();
2352 (* A qualident is writeable if the IdLeaf is writeable *)
2354 x
.ident
.CheckMutable(x
);
2357 (* -------------------------------------------- *)
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
;
2364 PROCEDURE (x
: UnaryX
)CheckWriteable
*(),EXTENSIBLE
;
2365 (* A referenced object is always writeable. *)
2366 (* tCheck nodes are always NOT writeable. *)
2368 IF x
.kind
# deref
THEN x
.ExprError(103) END;
2371 (* -------------------------------------------- *)
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. *)
2377 RETURN (x
.kind
= selct
) & x
.ident
.mutable() & x
.kid
.isWriteable();
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. *)
2384 IF x
.kind
= selct
THEN
2385 x
.ident
.CheckMutable(x
);
2386 x
.kid
.CheckWriteable();
2392 (* -------------------------------------------- *)
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 *)
2398 RETURN (x
.kind
= index
) & x
.lKid
.isWriteable();
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 *)
2405 IF x
.kind
# index
THEN
2408 x
.lKid
.CheckWriteable();
2412 (* -------------------------------------------- *)
2413 (* -------------------------------------------- *)
2415 PROCEDURE (x
: IdLeaf
)isVarDesig
*() : BOOLEAN;
2417 RETURN x
.ident
IS I
.AbVar
; (* varId or parId *)
2420 (* -------------------------------------------- *)
2422 PROCEDURE (x
: UnaryX
)isVarDesig
*() : BOOLEAN,EXTENSIBLE
;
2423 BEGIN RETURN x
.kind
= deref
END isVarDesig
;
2425 (* -------------------------------------------- *)
2427 PROCEDURE (x
: IdentX
)isVarDesig
*() : BOOLEAN;
2429 RETURN x
.kind
= selct
;
2432 (* -------------------------------------------- *)
2434 PROCEDURE (x
: BinaryX
)isVarDesig
*() : BOOLEAN;
2436 RETURN x
.kind
= index
;
2439 (* -------------------------------------------- *)
2440 (* -------------------------------------------- *)
2442 PROCEDURE (x
: IdLeaf
)isProcLit
*() : BOOLEAN;
2445 * True if this is a concrete procedure
2447 RETURN (x
.ident
.kind
= I
.conPrc
) OR
2448 (x
.ident
.kind
= I
.fwdPrc
);
2451 (* -------------------------------------------- *)
2453 PROCEDURE (x
: IdentX
)isProcLit
*() : BOOLEAN;
2456 * True if this is a concrete procedure
2458 RETURN (x
.ident
.kind
= I
.conMth
) OR
2459 (x
.ident
.kind
= I
.fwdMth
);
2462 (* -------------------------------------------- *)
2463 (* -------------------------------------------- *)
2465 PROCEDURE (x
: IdLeaf
)isProcVar
*() : BOOLEAN;
2468 * True if this has procedure type, but is not a concrete procedure
2470 RETURN x
.type
.isProcType() &
2471 (x
.ident
.kind
# I
.conPrc
) &
2472 (x
.ident
.kind
# I
.fwdPrc
) &
2473 (x
.ident
.kind
# I
.ctorP
);
2476 (* -------------------------------------------- *)
2478 PROCEDURE (x
: IdentX
)isProcVar
*() : BOOLEAN;
2481 * True if this is a selct, and field has procedure type
2483 RETURN (x
.kind
= selct
) &
2484 (x
.ident
IS I
.FldId
) &
2485 x
.type
.isProcType();
2488 (* -------------------------------------------- *)
2490 PROCEDURE (x
: UnaryX
)isProcVar
*() : BOOLEAN,EXTENSIBLE
;
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.
2497 RETURN (x
.kind
= tCheck
) & x
.type
.isProcType();
2500 (* -------------------------------------------- *)
2502 PROCEDURE (x
: BinaryX
)isProcVar
*() : BOOLEAN;
2505 * True if this is an index, and element has procedure type
2507 RETURN (x
.kind
= index
) & x
.type
.isProcType();
2510 (* -------------------------------------------- *)
2512 PROCEDURE (x
: LeafX
)isNil
*() : BOOLEAN;
2513 BEGIN RETURN x
.kind
= nilLt
END isNil
;
2515 (* -------------------------------------------- *)
2517 PROCEDURE (x
: LeafX
)isInf
*() : BOOLEAN;
2518 BEGIN RETURN (x
.kind
= infLt
) OR (x
.kind
= nInfLt
) END isInf
;
2520 (* -------------------------------------------- *)
2522 PROCEDURE (x
: LeafX
)isNumLit
*() : BOOLEAN;
2523 BEGIN RETURN x
.kind
= numLt
END isNumLit
;
2525 (* -------------------------------------------- *)
2527 PROCEDURE (x
: LeafX
)isCharLit
*() : BOOLEAN;
2528 (** A literal character, or a literal string of length = 1. *)
2530 RETURN (x
.kind
= charLt
)
2531 OR ((x
.kind
= strLt
) & (x
.value
.len() = 1));
2534 (* -------------------------------------------- *)
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
;
2540 (* ==================================================================== *)
2541 (* Possible structures of procedure call expressions are: *)
2542 (* ==================================================================== *)
2545 (* [CallX] [CallX] *)
2546 (* / +--- actuals --> ... / +--- actuals --> ... *)
2548 (* [IdentX] [IdLeaf] *)
2549 (* / +--- ident ---> [PrcId] +--- ident ---> [PrcId] *)
2553 (* ==================================================================== *)
2554 (* only the right hand side case can be a standard proc or function *)
2555 (* ==================================================================== *)
2557 PROCEDURE (x
: IdLeaf
)isStdFunc
*() : BOOLEAN;
2559 RETURN (x
.ident
# NIL)
2560 & (x
.ident
.kind
= I
.conPrc
)
2561 & (x
.ident(I
.PrcId
).stdOrd
# 0);
2564 (* -------------------------------------------- *)
2566 PROCEDURE (x
: IdLeaf
)isStdProc
*() : BOOLEAN;
2568 RETURN (x
.ident
# NIL)
2569 & (x
.ident
.kind
= I
.conPrc
)
2570 & (x
.ident(I
.PrcId
).stdOrd
# 0);
2573 (* -------------------------------------------- *)
2575 PROCEDURE (p
: CallX
)NoteCall
*(s
: D
.Scope
);
2580 (* -------------------------------------------- *)
2582 PROCEDURE (p
: IdLeaf
)NoteCall
*(s
: D
.Scope
);
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;
2593 (* -------------------------------------------- *)
2595 PROCEDURE (p
: IdentX
)NoteCall
*(s
: D
.Scope
);
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
);
2606 (* -------------------------------------------- *)
2608 PROCEDURE (x
: LeafX
)inRangeOf
*(dst
: D
.Type
) : BOOLEAN;
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
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
;
2637 * Changed for 1.2.3.4 to allow S1 to be compat with ARRAY OF CHAR (kjg)
2639 * ELSIF x.isCharLit() THEN
2640 * IF ~dst.isCharType() THEN
2642 ELSIF dst
.isCharType() THEN
2643 IF ~x
.isCharLit() THEN
2646 cVal
:= x
.charValue();
2647 IF dst(T
.Base
).tpOrd
= T
.sChrN
THEN
2648 RETURN (cVal
>= MIN(SHORTCHAR
)) & (cVal
<= MAX(SHORTCHAR
));
2654 * ELSIF x.kind = strLt THEN
2655 * IF ~dst.isCharArrayType() THEN
2657 ELSIF dst
.isCharArrayType() THEN
2658 IF x
.kind
# strLt
THEN
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 *)
2671 (* ============================================================ *)
2673 PROCEDURE (x
: LeafX
)charValue
*() : CHAR,NEW;
2674 (** A literal character, or a literal string of length = 1. *)
2677 IF x
.kind
= charLt
THEN
2678 chr
:= x
.value
.char();
2679 ELSE (* x.kind = strLt *)
2680 chr
:= x
.value
.chr0();
2685 (* -------------------------------------------- *)
2687 PROCEDURE convert(expr
: D
.Expr
; dstT
: D
.Type
) : D
.Expr
;
2688 (* Make permitted base-type coercions explicit in the AST *)
2695 (dstT
.kind
# T
.basTp
) OR
2696 (dstT
= Builtin
.anyPtr
) THEN
2698 ELSIF (dstT
= Builtin
.charTp
) & (expT
= Builtin
.strTp
) THEN
2701 ELSIF (dstT
= Builtin
.sChrTp
) & (expT
= Builtin
.strTp
) THEN
2702 valu
:= ORD(expr(LeafX
).value
.chr0());
2703 IF (valu
< 255) THEN
2707 expr
.type
:= Builtin
.charTp
;
2710 IF dstT
.includes(expr
.type
) THEN
2711 rslt
:= newIdentX(cvrtUp
, dstT
.idnt
, expr
);
2713 rslt
:= newIdentX(cvrtDn
, dstT
.idnt
, expr
);
2719 (* ============================================================ *)
2721 PROCEDURE FormalsVsActuals
*(prcX
: D
.Expr
; actSeq
: D
.ExprSeq
);
2722 VAR prcT
: T
.Procedure
;
2733 (* ---------------------------- *)
2735 PROCEDURE CheckCompatible(frm
: D
.Idnt
; act
: D
.Expr
);
2737 IF frm
.paramCompat(act
) OR
2738 frm
.type
.arrayCompat(act
.type
) THEN (* is OK, skip *)
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
);
2749 END CheckCompatible
;
2751 (* ---------------------------- *)
2753 PROCEDURE CheckVarModes(mod
: INTEGER; exp
: D
.Expr
);
2755 (* ---------------------------- *)
2757 PROCEDURE hasReferenceType(t
: D
.Type
) : BOOLEAN;
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
;
2767 (* ---------------------------- *)
2769 PROCEDURE MarkAddrsd(id
: D
.Idnt
);
2771 WITH id
: I
.LocId
DO INCL(id
.locAtt
, I
.addrsd
); ELSE END;
2774 (* ---------------------------- *)
2776 BEGIN (* Assert: mod is IN, OUT, or VAR *)
2777 IF mod
= D
.in
THEN (* IN mode only *)
2779 * Not strictly correct according to the report, but an *
2780 * innocuous extension -- allow literal strings here. *
2782 * IF (exp.type # Builtin.strTp) & ~exp.isVarDesig() THEN
2784 IF ~exp
.isVarDesig() &
2785 (exp
.type
# NIL) & ~
hasReferenceType(exp
.type
) THEN
2789 exp
.CheckWriteable(); (* OUT and VAR modes *)
2790 WITH exp
: IdLeaf
DO MarkAddrsd(exp
.ident
) ELSE END;
2794 (* ---------------------------- *)
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
];
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 *)
2809 (actual
.type
# NIL) &
2810 (formal
.type
# NIL) THEN
2811 frmTyp
:= formal
.type
;
2812 actTyp
:= actual
.type
;
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;
2820 IF frmTyp
IS T
.Opaque
THEN
2821 formal
.type
:= frmTyp
.resolve(1);
2822 frmTyp
:= formal
.type
;
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
);
2834 ELSIF actTyp
# frmTyp
THEN
2835 actual
:= convert(actual
, frmTyp
);
2836 IF ~frmTyp
.valCopyOK() THEN formal
.IdError(153) END;
2838 actSeq
.a
[index
] := actual
;
2841 IF frmSeq
.tide
> actSeq
.tide
THEN
2842 IF actSeq
.tide
= 0 THEN
2843 prcX
.ExprError(149);
2845 actSeq
.a
[actSeq
.tide
-1].ExprError(22);
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);
2855 END FormalsVsActuals
;
2857 (* ============================================================ *)
2859 PROCEDURE AttributePars
*(actSeq
: D
.ExprSeq
);
2860 VAR actual
: D
.Expr
;
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;
2869 (* ============================================================ *)
2871 PROCEDURE MatchPars
*(frmSeq
: I
.ParSeq
; actSeq
: D
.ExprSeq
) : BOOLEAN;
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 *)
2888 (actual
.type
# NIL) &
2889 (formal
.type
# NIL) THEN
2890 IF ~
(formal
.paramCompat(actual
) OR
2891 formal
.type
.arrayCompat(actual
.type
)) THEN
2901 (* ============================================================ *)
2903 PROCEDURE (p
: BinaryX
)enterGuard
*(tmp
: D
.Idnt
) : D
.Idnt
;
2910 IF (p
.lKid
= NIL) OR
2911 ~
(p
.lKid
IS IdLeaf
) OR
2913 ~
(p
.rKid
IS IdLeaf
) THEN RETURN NIL END;
2915 lQual
:= p
.lKid(IdLeaf
);
2916 rQual
:= p
.rKid(IdLeaf
);
2917 IF (lQual
.ident
= NIL) OR (rQual
.ident
= NIL) THEN RETURN NIL END;
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.
2924 lHash
:= lQual
.ident
.hash
;
2926 tmp
.type
:= rQual
.ident
.type
;
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.
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).
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
);
2948 tmp
.dfScp
.symTb
.Overwrite(lHash
, tmp
);
2953 PROCEDURE (p
: BinaryX
)ExitGuard
*(sav
: D
.Idnt
; tmp
: D
.Idnt
);
2955 IF tmp
.type
= NIL THEN RETURN END;
2957 (* remove tmp from tmp.dfScp.symTb *)
2958 tmp
.dfScp
.symTb
.RemoveLeaf(tmp
.hash
);
2960 (* overwrite with previous value *)
2961 tmp
.dfScp
.symTb
.Overwrite(tmp
.hash
, sav
);
2965 (* ============================================================ *)
2966 (* Diagnostic methods *)
2967 (* ============================================================ *)
2969 PROCEDURE Diag(i
: INTEGER; e
: D
.Expr
);
2972 H
.Indent(i
); Console
.WriteString("<nil>"); Console
.WriteLn
;
2978 (* ------------------------------- *)
2980 PROCEDURE PType(t
: D
.Type
);
2983 Console
.WriteString(t
.name());
2985 Console
.WriteString("<nil>");
2989 (* -------------------------------------------- *)
2991 PROCEDURE (s
: LeafX
)Diagnose
*(i
: INTEGER),EXTENSIBLE
;
2992 VAR name
: FileNames
.NameString
;
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());
3004 | strLt
: Console
.WriteString("strLt ");
3005 s
.value
.GetStr(name
);
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? ");
3020 (* ------------------------------- *)
3022 PROCEDURE (s
: IdLeaf
)Diagnose
*(i
: INTEGER);
3023 VAR name
: FileNames
.NameString
;
3026 D
.getName
.Of(s
.ident
, name
);
3027 Console
.WriteString(name
);
3034 (* ------------------------------- *)
3036 PROCEDURE (s
: SetExp
)Diagnose
*(i
: INTEGER);
3043 Console
.WriteString("setLt {");
3044 IF s
.value
# NIL THEN
3047 IF j
IN v
THEN ch
:= '
1'
ELSE ch
:= '
.'
END;
3052 IF s
.kind
= setLt
THEN
3055 Console
.WriteString(" + "); Console
.WriteLn
;
3056 FOR j
:= 0 TO s
.varSeq
.tide
- 1 DO
3057 Diag(i
+4, s
.varSeq
.a
[j
]);
3062 (* ------------------------------- *)
3064 PROCEDURE (s
: UnaryX
)Diagnose
*(i
: INTEGER),EXTENSIBLE
;
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;
3086 (* ------------------------------- *)
3088 PROCEDURE (s
: IdentX
)Diagnose
*(i
: INTEGER);
3089 VAR name
: FileNames
.NameString
;
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
);
3104 (* ------------------------------- *)
3106 PROCEDURE (s
: CallX
)Diagnose
*(i
: INTEGER);
3109 IF s
.kind
= fnCall
THEN
3110 Console
.WriteString("CallX(fn) "); PType(s
.type
);
3112 Console
.WriteString("CallX(pr)");
3118 (* ------------------------------- *)
3120 PROCEDURE (s
: BinaryX
)Diagnose
*(i
: INTEGER);
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 ");
3162 (* ============================================================ *)
3163 BEGIN (* ====================================================== *)
3164 END ExprDesc
. (* ============================================== *)
3165 (* ============================================================ *)