1 (* ==================================================================== *)
3 (* Symbol Module for the Gardens Point Component Pascal Compiler. *)
4 (* Implements the abstract base classes for all descriptor types. *)
5 (* Copyright (c) John Gough 1999, 2000. *)
7 (* ==================================================================== *)
23 (* ============================================================ *)
25 CONST (* mode-kinds *)
26 prvMode
* = 0; pubMode
* = 1; rdoMode
* = 2; protect
* = 3;
28 CONST (* param-modes *)
29 val
* = 0; in
* = 1; out
* = 2; var
* = 3; notPar
* = 4;
31 CONST (* force-kinds *)
32 noEmit
* = 0; partEmit
* = 1; forced
* = 2;
38 tOffset
* = 16; (* backward compatibility with JavaVersion *)
40 (* ============================================================ *)
41 (* Foreign attributes for modules, procedures and classes *)
42 (* ============================================================ *)
44 CONST (* module and type attributes for xAttr *)
45 mMsk
* = { 0 .. 7}; main
* = 0; weak
* = 1; need
* = 2;
46 fixd
* = 3; rtsMd
* = 4; anon
* = 5;
47 clsTp
* = 6; frnMd
* = 7;
48 rMsk
* = { 8 .. 15}; noNew
* = 8; asgnd
* = 9; noCpy
* = 10;
49 spshl
* = 11; xCtor
* = 12;
50 fMsk
* = {16 .. 23}; isFn
* = 16; extFn
* = 17; fnInf
* = 18;
51 dMsk
* = {24 .. 31}; cMain
* = 24; wMain
* = 25; sta
* = 26;
53 (* ============================================================ *)
55 TYPE NameStr
* = ARRAY 64 OF CHAR;
57 (* ============================================================ *)
60 Idnt
* = POINTER TO ABSTRACT
RECORD (RTS
.NativeObject
)
61 kind
- : INTEGER; (* tag for unions *)
62 token
* : S
.Token
; (* scanner token *)
63 type
* : Type
; (* typ-desc | NIL *)
64 hash
* : INTEGER; (* hash bucket no *)
65 vMod
- : INTEGER; (* visibility tag *)
66 dfScp
* : Scope
; (* defining scope *)
67 tgXtn
* : ANYPTR
; (* target stuff *)
68 namStr
- : RTS
.NativeString
;
69 END; (* For fields: record-decl scope *)
72 tide
-, high
: INTEGER;
73 a
- : POINTER TO ARRAY OF Idnt
;
76 Scope
* = POINTER TO ABSTRACT
RECORD (Idnt
)
77 symTb
* : SymbolTable
; (* symbol scope *)
81 scopeNm
* : L
.CharOpen (* external name *)
85 tide
-, high
: INTEGER;
86 a
- : POINTER TO ARRAY OF Scope
;
89 (* ============================================================ *)
92 Type
* = POINTER TO ABSTRACT
RECORD
93 idnt
* : Idnt
; (* Id of typename *)
94 kind
- : INTEGER; (* tag for unions *)
95 serial
- : INTEGER; (* type serial-nm *)
96 force
* : INTEGER; (* force sym-emit *)
97 xName
* : L
.CharOpen
; (* full ext name *)
98 dump
*,depth
* : INTEGER; (* scratch loc'ns *)
99 tgXtn
* : ANYPTR
; (* target stuff *)
103 tide
-, high
: INTEGER;
104 a
- : POINTER TO ARRAY OF Type
;
107 (* ============================================================ *)
110 Stmt
* = POINTER TO ABSTRACT
RECORD
111 kind
- : INTEGER; (* tag for unions *)
112 token
* : S
.Token
; (* stmt first tok *)
116 tide
-, high
: INTEGER;
117 a
- : POINTER TO ARRAY OF Stmt
;
120 (* ============================================================ *)
123 Expr
* = POINTER TO ABSTRACT
RECORD
124 kind
- : INTEGER; (* tag for unions *)
125 token
* : S
.Token
; (* exp marker tok *)
126 tSpan
* : S
.Span
; (* start expr tok *)
131 tide
-, high
: INTEGER;
132 a
- : POINTER TO ARRAY OF Expr
;
135 (* ============================================================ *)
137 TYPE (* Symbol tables are implemented by a binary tree *)
138 SymInfo
= POINTER TO RECORD (* private stuff *)
139 key
: INTEGER; (* hash key value *)
140 val
: Idnt
; (* id-desc. value *)
141 lOp
: SymInfo
; (* left child *)
142 rOp
: SymInfo
; (* right child *)
145 SymbolTable
* = RECORD
149 (* ============================================================ *)
150 (* SymForAll is the base type of a visitor type. *)
151 (* Instances of extensions of SymForAll type are passed to *)
152 (* SymbolTables using *)
153 (* symTab.Apply(sfa : SymForAll); *)
154 (* This recurses over the table, applying sfa.Op(id) to each *)
155 (* Idnt descriptor in the scope. *)
156 (* ============================================================ *)
159 SymForAll
* = POINTER TO ABSTRACT
RECORD END;
161 SymTabDump
* = POINTER TO RECORD (SymForAll
)
165 NameDump
* = POINTER TO RECORD (SymForAll
)
166 tide
, high
: INTEGER;
170 (* ============================================================ *)
173 SccTable
* = POINTER TO RECORD
174 symTab
* : SymbolTable
;
179 (* ============================================================ *)
182 NameFetch
* = POINTER TO RECORD END;
183 (** This type exports two methods only: *)
184 (* (g : NameFetch)Of*(i : Idnt; OUT s : ARRAY OF CHAR); *)
185 (* (g : NameFetch)ChPtr*(id : Idnt) : L.CharOpen; *)
187 (* ============================================================ *)
189 VAR modStr
- : ARRAY 4 OF ARRAY 5 OF CHAR;
190 modMrk
- : ARRAY 5 OF CHAR;
191 anonMrk
- : ARRAY 3 OF CHAR;
193 getName
* : NameFetch
;
194 next
: INTEGER; (* private: next serial number. *)
196 (* ============================================================ *)
198 PROCEDURE SetTargetIsNET
*(p
: BOOLEAN);
201 IF p
THEN anonMrk
:= "@T" ELSE anonMrk
:= "$T" END;
204 (* ============================================================ *)
205 (* Abstract attribution methods *)
206 (* ============================================================ *)
208 PROCEDURE (i
: Expr
)exprAttr
*() : Expr
,NEW,ABSTRACT
;
209 PROCEDURE (s
: Stmt
)StmtAttr
*(t
: Scope
),NEW,ABSTRACT
;
210 PROCEDURE (s
: Stmt
)flowAttr
*(t
: Scope
; i
: V
.VarSet
):V
.VarSet
,NEW,ABSTRACT
;
212 (* ============================================================ *)
213 (* Abstract type erase methods *)
214 (* ============================================================ *)
216 PROCEDURE (s
: Stmt
)TypeErase
*(t
: Scope
), NEW, ABSTRACT
;
217 PROCEDURE (s
: Expr
)TypeErase
*() : Expr
, NEW, ABSTRACT
;
218 PROCEDURE (i
: Type
)TypeErase
*() : Type
, NEW, ABSTRACT
;
220 (* ============================================================ *)
221 (* Abstract diagnostic methods *)
222 (* ============================================================ *)
224 PROCEDURE (t
: Idnt
)Diagnose
*(i
: INTEGER),NEW,ABSTRACT
;
225 PROCEDURE (t
: Type
)Diagnose
*(i
: INTEGER),NEW,ABSTRACT
;
226 PROCEDURE (t
: Expr
)Diagnose
*(i
: INTEGER),NEW,ABSTRACT
;
227 PROCEDURE (t
: Stmt
)Diagnose
*(i
: INTEGER),NEW,ABSTRACT
;
228 PROCEDURE (t
: Type
)name
*() : L
.CharOpen
,NEW,ABSTRACT
;
230 PROCEDURE (t
: Idnt
)SetNameFromString
*(nam
: L
.CharOpen
),NEW;
232 t
.namStr
:= MKSTR(nam^
);
233 END SetNameFromString
;
235 PROCEDURE (t
: Idnt
)SetNameFromHash
*(hash
: INTEGER),NEW;
237 t
.namStr
:= MKSTR(NameHash
.charOpenOfHash(hash
)^
);
240 (* ============================================================ *)
241 (* This diagnostic method is placed here to use when GPCP-CLR *)
242 (* itself is being debugged. If ToString is present then *)
243 (* > gpcp /target=jvm Symbol.cp fails with error 105 :- *)
244 (* "This method is not a redefinition, you must use NEW" *)
245 (* ============================================================ *
246 PROCEDURE (t : Idnt)ToString*() : RTS.NativeString;
248 IF t.namStr # NIL THEN RETURN t.namStr;
249 ELSE RETURN MKSTR(NameHash.charOpenOfHash(t.hash)^);
252 * ============================================================ *)
253 (* ============================================================ *)
254 (* This diagnostic method is placed here to use when GPCP-JVM *)
255 (* itself is being debugged. If toString is present then *)
256 (* > gpcp /target=net Symbol.cp fails with error 105 :- *)
257 (* "This method is not a redefinition, you must use NEW" *)
258 (* ============================================================ *
259 PROCEDURE (t : Idnt)toString*() : RTS.NativeString;
261 IF t.namStr # NIL THEN RETURN t.namStr;
262 ELSE RETURN MKSTR(NameHash.charOpenOfHash(t.hash)^);
265 * ============================================================ *)
266 (* ============================================================ *)
269 (* ============================================================ *)
270 (* Base Class text-span method *)
271 (* ============================================================ *)
273 PROCEDURE (s
: Stmt
)Span
*() : S
.Span
,NEW,EXTENSIBLE
;
275 RETURN S
.mkSpanT(s
.token
);
278 (* ============================================================ *)
279 (* Base predicates on Idnt extensions *)
280 (* If the predicate needs a different implementation for each *)
281 (* of the direct subclasses, then it is ABSTRACT, otherwise it *)
282 (* should be implemented here with a default return value. *)
283 (* ============================================================ *)
285 PROCEDURE (s
: Idnt
)isImport
*() : BOOLEAN,NEW,EXTENSIBLE
;
286 BEGIN RETURN FALSE
END isImport
;
288 (* -------------------------------------------- *)
290 PROCEDURE (s
: Idnt
)isImported
*() : BOOLEAN,NEW,EXTENSIBLE
;
292 RETURN (s
.dfScp
# NIL) & s
.dfScp
.isImport();
295 (* -------------------------------------------- *)
297 PROCEDURE (s
: Type
)isImportedType
*() : BOOLEAN,NEW,EXTENSIBLE
;
299 RETURN (s
.idnt
# NIL) &
300 (s
.idnt
.dfScp
# NIL) &
301 s
.idnt
.dfScp
.isImport();
304 (* -------------------------------------------- *)
305 PROCEDURE^
(xp
: Expr
)ExprError
*(n
: INTEGER),NEW;
307 PROCEDURE (s
: Idnt
)mutable
*() : BOOLEAN,NEW,EXTENSIBLE
;
308 BEGIN RETURN FALSE
END mutable
;
310 PROCEDURE (s
: Idnt
)CheckMutable
*(x
: Expr
),NEW,EXTENSIBLE
;
311 BEGIN x
.ExprError(181) END CheckMutable
;
313 (* -------------------------------------------- *)
315 PROCEDURE (s
: Idnt
)isStatic
*() : BOOLEAN,NEW,EXTENSIBLE
;
316 BEGIN RETURN FALSE
END isStatic
;
318 (* -------------------------------------------- *)
320 PROCEDURE (s
: Idnt
)isLocalVar
*() : BOOLEAN,NEW,EXTENSIBLE
;
321 BEGIN RETURN FALSE
END isLocalVar
;
323 (* -------------------------------------------- *)
325 PROCEDURE (s
: Idnt
)isWeak
*() : BOOLEAN,NEW,EXTENSIBLE
;
326 BEGIN RETURN FALSE
END isWeak
;
328 (* -------------------------------------------- *)
330 PROCEDURE (s
: Idnt
)isDynamic
*() : BOOLEAN,NEW,EXTENSIBLE
;
331 BEGIN RETURN FALSE
END isDynamic
;
333 (* -------------------------------------------- *)
335 PROCEDURE (s
: Idnt
)isAbstract
*() : BOOLEAN,NEW,EXTENSIBLE
;
336 BEGIN RETURN FALSE
END isAbstract
;
338 (* -------------------------------------------- *)
340 PROCEDURE (s
: Idnt
)isEmpty
*() : BOOLEAN,NEW,EXTENSIBLE
;
341 BEGIN RETURN FALSE
END isEmpty
;
343 (* -------------------------------------------- *)
345 PROCEDURE (i
: Idnt
)parMode
*() : INTEGER,NEW,EXTENSIBLE
;
346 BEGIN RETURN notPar
END parMode
;
348 (* -------------------------------------------- *)
350 PROCEDURE (s : Idnt)isRcv*() : BOOLEAN,NEW,EXTENSIBLE;
351 BEGIN RETURN FALSE END isRcv;
353 (* -------------------------------------------- *)
355 PROCEDURE (s : Idnt)isAssignProc*() : BOOLEAN,NEW,EXTENSIBLE;
356 BEGIN RETURN FALSE END isAssignProc;
358 (* ============================================================ *)
359 (* Base predicates on Type extensions *)
360 (* ============================================================ *)
362 PROCEDURE (l
: Type
)equalOpenOrVector
*(r
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
363 BEGIN RETURN FALSE
END equalOpenOrVector
;
365 (* -------------------------------------------- *)
367 PROCEDURE (l
: Type
)procMatch
*(r
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
368 BEGIN RETURN FALSE
END procMatch
;
370 (* -------------------------------------------- *)
372 PROCEDURE (l
: Type
)namesMatch
*(r
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
373 BEGIN RETURN FALSE
END namesMatch
;
375 (* -------------------------------------------- *)
377 PROCEDURE (l
: Type
)sigsMatch
*(r
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
378 BEGIN RETURN FALSE
END sigsMatch
;
380 (* -------------------------------------------- *)
382 PROCEDURE (l
: Type
)equalPointers
*(r
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
383 BEGIN RETURN FALSE
END equalPointers
;
385 (* -------------------------------------------- *)
387 PROCEDURE (i
: Type
)isAnonType
*() : BOOLEAN,NEW;
388 BEGIN RETURN (i
.idnt
= NIL) OR (i
.idnt
.dfScp
= NIL) END isAnonType
;
390 (* -------------------------------------------- *)
392 PROCEDURE (i
: Type
)isBaseType
*() : BOOLEAN,NEW,EXTENSIBLE
;
393 BEGIN RETURN FALSE
END isBaseType
;
395 (* -------------------------------------------- *)
397 PROCEDURE (i
: Type
)isIntType
*() : BOOLEAN,NEW,EXTENSIBLE
;
398 BEGIN RETURN FALSE
END isIntType
;
400 (* -------------------------------------------- *)
402 PROCEDURE (s
: Idnt
)isIn
*(set
: V
.VarSet
) : BOOLEAN,NEW,EXTENSIBLE
;
403 BEGIN RETURN TRUE
END isIn
;
405 (* -------------------------------------------- *)
407 PROCEDURE (i
: Type
)isNumType
*() : BOOLEAN,NEW,EXTENSIBLE
;
408 BEGIN RETURN FALSE
END isNumType
;
410 (* -------------------------------------------- *)
412 PROCEDURE (i
: Type
)isScalarType
*() : BOOLEAN,NEW,EXTENSIBLE
;
413 BEGIN RETURN TRUE
END isScalarType
; (* all except arrays, records *)
415 (* -------------------------------------------- *)
417 PROCEDURE (i
: Type
)isSetType
*() : BOOLEAN,NEW,EXTENSIBLE
;
418 BEGIN RETURN FALSE
END isSetType
;
420 (* -------------------------------------------- *)
422 PROCEDURE (i
: Type
)isRealType
*() : BOOLEAN,NEW,EXTENSIBLE
;
423 BEGIN RETURN FALSE
END isRealType
;
425 (* -------------------------------------------- *)
427 PROCEDURE (i
: Type
)isCharType
*() : BOOLEAN,NEW,EXTENSIBLE
;
428 BEGIN RETURN FALSE
END isCharType
;
430 (* -------------------------------------------- *)
432 PROCEDURE (i
: Type
)isBooleanType
*() : BOOLEAN,NEW,EXTENSIBLE
;
433 BEGIN RETURN FALSE
END isBooleanType
;
435 (* -------------------------------------------- *)
437 PROCEDURE (i
: Type
)isStringType
*() : BOOLEAN,NEW,EXTENSIBLE
;
438 BEGIN RETURN FALSE
END isStringType
;
440 (* -------------------------------------------- *)
442 PROCEDURE (i
: Type
)nativeCompat
*() : BOOLEAN,NEW,EXTENSIBLE
;
443 BEGIN RETURN FALSE
END nativeCompat
;
445 (* -------------------------------------------- *)
447 PROCEDURE (i
: Type
)isCharArrayType
*() : BOOLEAN,NEW,EXTENSIBLE
;
448 BEGIN RETURN FALSE
END isCharArrayType
;
450 (* -------------------------------------------- *)
452 PROCEDURE (s
: Type
)isRefSurrogate
*() : BOOLEAN,NEW,EXTENSIBLE
;
453 BEGIN RETURN FALSE
END isRefSurrogate
;
455 (* -------------------------------------------- *)
457 PROCEDURE (i
: Type
)isPointerType
*() : BOOLEAN,NEW,EXTENSIBLE
;
458 BEGIN RETURN FALSE
END isPointerType
;
460 (* -------------------------------------------- *)
462 PROCEDURE (i
: Type
)isRecordType
*() : BOOLEAN,NEW,EXTENSIBLE
;
463 BEGIN RETURN FALSE
END isRecordType
;
465 (* -------------------------------------------- *)
467 PROCEDURE (i
: Type
)isProcType
*() : BOOLEAN,NEW,EXTENSIBLE
;
468 BEGIN RETURN FALSE
END isProcType
;
470 (* -------------------------------------------- *)
472 PROCEDURE (i
: Type
)isProperProcType
*() : BOOLEAN,NEW,EXTENSIBLE
;
473 BEGIN RETURN FALSE
END isProperProcType
;
475 (* -------------------------------------------- *)
477 PROCEDURE (i
: Type
)isDynamicType
*() : BOOLEAN,NEW,EXTENSIBLE
;
478 BEGIN RETURN FALSE
END isDynamicType
;
480 (* -------------------------------------------- *)
482 PROCEDURE (i
: Type
)isAbsRecType
*() : BOOLEAN,NEW,EXTENSIBLE
;
483 BEGIN RETURN FALSE
END isAbsRecType
;
485 (* -------------------------------------------- *)
487 PROCEDURE (i
: Type
)isLimRecType
*() : BOOLEAN,NEW,EXTENSIBLE
;
488 BEGIN RETURN FALSE
END isLimRecType
;
490 (* -------------------------------------------- *)
492 PROCEDURE (i
: Type
)isExtnRecType
*() : BOOLEAN,NEW,EXTENSIBLE
;
493 BEGIN RETURN FALSE
END isExtnRecType
;
495 (* -------------------------------------------- *)
497 PROCEDURE (i
: Type
)isOpenArrType
*() : BOOLEAN,NEW,EXTENSIBLE
;
498 BEGIN RETURN FALSE
END isOpenArrType
;
500 PROCEDURE (i
: Type
)isVectorType
*() : BOOLEAN,NEW,EXTENSIBLE
;
501 BEGIN RETURN FALSE
END isVectorType
;
503 (* -------------------------------------------- *)
505 PROCEDURE (i
: Type
)needsInit
*() : BOOLEAN,NEW,EXTENSIBLE
;
506 BEGIN RETURN TRUE
END needsInit
;
508 (* -------------------------------------------- *)
510 PROCEDURE (i
: Type
)isForeign
*() : BOOLEAN,NEW,EXTENSIBLE
;
511 BEGIN RETURN FALSE
END isForeign
;
513 (* -------------------------------------------- *)
515 PROCEDURE (i
: Type
)valCopyOK
*() : BOOLEAN,NEW,EXTENSIBLE
;
516 BEGIN RETURN TRUE
END valCopyOK
;
518 (* -------------------------------------------- *)
520 PROCEDURE (i
: Type
)isInterfaceType
*() : BOOLEAN,NEW,EXTENSIBLE
;
521 BEGIN RETURN FALSE
END isInterfaceType
;
523 (* -------------------------------------------- *)
525 PROCEDURE (i
: Type
)isEventType
*() : BOOLEAN,NEW,EXTENSIBLE
;
526 BEGIN RETURN FALSE
END isEventType
;
528 (* -------------------------------------------- *)
530 PROCEDURE (i
: Type
)isCompoundType
*() : BOOLEAN,NEW,EXTENSIBLE
;
531 (* Returns TRUE if the type is a compound type *)
532 BEGIN RETURN FALSE
END isCompoundType
;
534 (* -------------------------------------------- *)
536 PROCEDURE (i
: Type
)ImplementationType
*() : Type
,NEW,EXTENSIBLE
;
537 (* Returns the type that this type will be implemented
538 * as. Usually this is just an identity function, but
539 * for types that can be erased, it may be a different
541 BEGIN RETURN i
END ImplementationType
;
543 (* -------------------------------------------- *)
545 PROCEDURE (i
: Type
)implements
*(x
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
546 BEGIN RETURN FALSE
END implements
;
548 (* -------------------------------------------- *)
550 PROCEDURE (i
: Type
)implementsAll
*(x
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
551 (* Returns true iff i is a type that implements all of the
552 * interfaces of x. x and i must be types that are capable of
553 * implementing interfaces (a record or pointer) *)
554 BEGIN RETURN FALSE
END implementsAll
;
556 (* -------------------------------------------- *)
558 PROCEDURE (b
: Type
)isBaseOf
*(x
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
559 BEGIN RETURN FALSE
END isBaseOf
;
561 (* -------------------------------------------- *)
563 PROCEDURE (i
: Type
)isLongType
*() : BOOLEAN,NEW,EXTENSIBLE
;
564 BEGIN RETURN FALSE
END isLongType
;
566 (* -------------------------------------------- *)
568 PROCEDURE (i
: Type
)isNativeObj
*() : BOOLEAN,NEW,EXTENSIBLE
;
569 BEGIN RETURN FALSE
END isNativeObj
;
571 (* -------------------------------------------- *)
573 PROCEDURE (i
: Type
)isNativeStr
*() : BOOLEAN,NEW,EXTENSIBLE
;
574 BEGIN RETURN FALSE
END isNativeStr
;
576 (* -------------------------------------------- *)
578 PROCEDURE (i
: Type
)isNativeExc
*() : BOOLEAN,NEW,EXTENSIBLE
;
579 BEGIN RETURN FALSE
END isNativeExc
;
581 (* -------------------------------------------- *)
583 PROCEDURE (b
: Type
)includes
*(x
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
584 BEGIN RETURN FALSE
END includes
;
586 (* -------------------------------------------- *)
588 PROCEDURE (i
: Type
)boundRecTp
*() : Type
,NEW,EXTENSIBLE
;
589 BEGIN RETURN NIL END boundRecTp
;
591 (* -------------------------------------------- *)
593 PROCEDURE (i
: Type
)superType
*() : Type
,NEW,EXTENSIBLE
;
594 BEGIN RETURN NIL END superType
;
596 (* -------------------------------------------- *)
598 PROCEDURE (i
: Type
)elaboration
*() : Type
,NEW,EXTENSIBLE
;
599 BEGIN RETURN i
END elaboration
;
601 (* -------------------------------------------- *)
603 PROCEDURE (i
: Type
)inheritedFeature
*(m
: Idnt
) : Idnt
,NEW,EXTENSIBLE
;
606 END inheritedFeature
;
608 (* -------------------------------------------- *)
610 PROCEDURE (i
: Type
)returnType
*() : Type
,NEW,EXTENSIBLE
;
611 BEGIN RETURN NIL END returnType
;
613 (* -------------------------------------------- *)
615 PROCEDURE (recT
: Type
)AppendCtor
*(prcI
: Idnt
),NEW,EMPTY
;
616 PROCEDURE (oldT
: Type
)CheckCovariance
*(newI
: Idnt
),NEW,EMPTY
;
617 PROCEDURE (mthT
: Type
)CheckEmptyOK
*(),NEW,EMPTY
;
618 PROCEDURE (theT
: Type
)ConditionalMark
*(),NEW,ABSTRACT
;
619 PROCEDURE (theT
: Type
)UnconditionalMark
*(),NEW,ABSTRACT
;
620 PROCEDURE (prcT
: Type
)OutCheck
*(s
: V
.VarSet
),NEW,EMPTY
;
621 PROCEDURE (s
: Scope
)LiveInitialize
*(i
: V
.VarSet
),NEW,EMPTY
;
622 PROCEDURE (s
: Scope
)UplevelInitialize
*(i
: V
.VarSet
),NEW,EMPTY
;
623 PROCEDURE (o
: Idnt
)OverloadFix
*(),NEW,EMPTY
;
625 (* -------------------------------------------- *)
627 PROCEDURE (i
: Type
)resolve
*(d
: INTEGER) : Type
,NEW,ABSTRACT
;
628 PROCEDURE (i
: Type
)TypeFix
*(IN a
: TypeSeq
),NEW,ABSTRACT
;
629 PROCEDURE (i
: Type
)InsertMethod
*(m
: Idnt
),NEW,EMPTY
;
630 PROCEDURE (i
: Type
)SccTab
*(t
: SccTable
),NEW,ABSTRACT
;
632 (* ============================================================ *)
633 (* Base predicates on Expr extensions *)
634 (* ============================================================ *)
636 PROCEDURE (i
: Expr
)isNil
*() : BOOLEAN,NEW,EXTENSIBLE
;
637 BEGIN RETURN FALSE
END isNil
;
639 (* -------------------------------------------- *)
640 PROCEDURE (i
: Expr
)isInf
*() : BOOLEAN,NEW,EXTENSIBLE
;
641 BEGIN RETURN FALSE
END isInf
;
643 (* -------------------------------------------- *)
645 PROCEDURE (x
: Expr
)isWriteable
*() : BOOLEAN,NEW,EXTENSIBLE
;
646 BEGIN RETURN FALSE
END isWriteable
;
648 PROCEDURE (x
: Expr
)CheckWriteable
*(),NEW,EXTENSIBLE
;
649 BEGIN x
.ExprError(103) END CheckWriteable
;
651 (* -------------------------------------------- *)
653 PROCEDURE (x
: Expr
)isVarDesig
*() : BOOLEAN,NEW,EXTENSIBLE
;
654 BEGIN RETURN FALSE
END isVarDesig
;
656 (* -------------------------------------------- *)
658 PROCEDURE (x
: Expr
)isProcVar
*() : BOOLEAN,NEW,EXTENSIBLE
;
659 BEGIN RETURN FALSE
END isProcVar
;
661 (* -------------------------------------------- *)
663 PROCEDURE (x
: Expr
)isJavaInit
*() : BOOLEAN,NEW,EXTENSIBLE
;
664 BEGIN RETURN FALSE
END isJavaInit
;
666 (* -------------------------------------------- *)
668 PROCEDURE (x
: Expr
)isSetExpr
*() : BOOLEAN,NEW;
669 BEGIN RETURN (x
.type
# NIL) & (x
.type
.isSetType()) END isSetExpr
;
671 (* -------------------------------------------- *)
673 PROCEDURE (x
: Expr
)isBooleanExpr
*() : BOOLEAN,NEW;
674 BEGIN RETURN (x
.type
# NIL) & (x
.type
.isBooleanType()) END isBooleanExpr
;
676 (* -------------------------------------------- *)
678 PROCEDURE (x
: Expr
)isCharArray
*() : BOOLEAN,NEW;
679 BEGIN RETURN (x
.type
# NIL) & (x
.type
.isCharArrayType()) END isCharArray
;
681 (* -------------------------------------------- *)
683 PROCEDURE (x
: Expr
)isCharLit
*() : BOOLEAN,NEW,EXTENSIBLE
;
684 (** A literal character, or a literal string of length = 1. *)
685 BEGIN RETURN FALSE
END isCharLit
;
687 (* -------------------------------------------- *)
689 PROCEDURE (x
: Expr
)isCharExpr
*() : BOOLEAN,NEW;
691 RETURN x
.isCharLit() OR
692 (x
.type
# NIL) & (x
.type
.isCharType());
695 (* -------------------------------------------- *)
697 PROCEDURE (x
: Expr
)isString
*() : BOOLEAN,NEW;
698 (** A literal string or the result of a string concatenation. *)
699 BEGIN RETURN (x
.type
# NIL) & (x
.type
.isStringType()) END isString
;
701 (* -------------------------------------------- *)
703 PROCEDURE (x
: Expr
)isNumLit
*() : BOOLEAN,NEW,EXTENSIBLE
;
704 (** Any literal integer. *)
705 BEGIN RETURN FALSE
END isNumLit
;
707 (* -------------------------------------------- *)
709 PROCEDURE (x
: Expr
)isStrLit
*() : BOOLEAN,NEW,EXTENSIBLE
;
710 (** Any literal string. *)
711 BEGIN RETURN FALSE
END isStrLit
;
713 (* -------------------------------------------- *)
715 PROCEDURE (x
: Expr
)isProcLit
*() : BOOLEAN,NEW,EXTENSIBLE
;
716 (** Any literal procedure. *)
717 BEGIN RETURN FALSE
END isProcLit
;
719 (* -------------------------------------------- *)
721 PROCEDURE (x
: Expr
)isPointerExpr
*() : BOOLEAN,NEW;
722 BEGIN RETURN (x
.type
# NIL) & x
.type
.isPointerType() END isPointerExpr
;
724 PROCEDURE (x
: Expr
)isVectorExpr
*() : BOOLEAN,NEW;
725 BEGIN RETURN (x
.type
# NIL) & x
.type
.isVectorType() END isVectorExpr
;
727 (* -------------------------------------------- *)
729 PROCEDURE (x
: Expr
)isProcExpr
*() : BOOLEAN,NEW;
730 BEGIN RETURN (x
.type
# NIL) & x
.type
.isProcType() END isProcExpr
;
732 (* -------------------------------------------- *)
734 PROCEDURE (x
: Expr
)isIntExpr
*() : BOOLEAN,NEW;
735 BEGIN RETURN (x
.type
# NIL) & x
.type
.isIntType() END isIntExpr
;
737 (* -------------------------------------------- *)
739 PROCEDURE (x
: Expr
)isRealExpr
*() : BOOLEAN,NEW;
740 BEGIN RETURN (x
.type
# NIL) & x
.type
.isRealType() END isRealExpr
;
742 (* -------------------------------------------- *)
744 PROCEDURE (x
: Expr
)isNumericExpr
*() : BOOLEAN,NEW;
745 BEGIN RETURN (x
.type
# NIL) & x
.type
.isNumType() END isNumericExpr
;
747 (* -------------------------------------------- *)
749 PROCEDURE (x
: Expr
)isStdFunc
*() : BOOLEAN,NEW,EXTENSIBLE
;
750 BEGIN RETURN FALSE
END isStdFunc
;
752 (* -------------------------------------------- *)
754 PROCEDURE (x
: Expr
)hasDynamicType
*() : BOOLEAN,NEW,EXTENSIBLE
;
755 (* overridden for IdLeaf extension of LeafX expression type *)
757 RETURN (x
.type
# NIL) & x
.type
.isDynamicType();
760 (* -------------------------------------------- *)
762 PROCEDURE (x
: Expr
)isStdProc
*() : BOOLEAN,NEW,EXTENSIBLE
;
763 BEGIN RETURN FALSE
END isStdProc
;
765 (* -------------------------------------------- *)
767 PROCEDURE (x
: Expr
)inRangeOf
*(t
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
768 (* If t is an ordinal type, return x in range, or for array *
769 * type t return x is within the index range. *)
770 BEGIN RETURN FALSE
END inRangeOf
;
772 (* ============================================================ *)
774 PROCEDURE RepTypesError
*(n
: INTEGER; lT
,rT
: Type
; ln
,cl
: INTEGER);
776 S
.SemError
.RepSt2(n
, lT
.name(), rT
.name(), ln
, cl
);
779 PROCEDURE RepTypesErrTok
*(n
: INTEGER; lT
,rT
: Type
; tk
: S
.Token
);
781 S
.SemError
.RepSt2(n
, lT
.name(), rT
.name(), tk
.lin
, tk
.col
);
784 (* ============================================================ *)
785 (* Various Type Compatability tests. *)
786 (* ============================================================ *)
788 PROCEDURE (lhT
: Type
)equalType
*(rhT
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
791 OR lhT
.equalPointers(rhT
)
792 OR lhT
.equalOpenOrVector(rhT
)
793 OR lhT
.procMatch(rhT
);
796 (* -------------------------------------------- *)
798 PROCEDURE (lhT
: Type
)assignCompat
*(x
: Expr
) : BOOLEAN,NEW;
801 IF (x
= NIL) OR (x
.type
= NIL) THEN RETURN TRUE
; END;
804 (* Compound type compatibility. *)
805 IF lhT
.isCompoundType() THEN
806 IF ~lhT
.isBaseOf(rhT
) THEN RETURN FALSE
END;
807 IF (rhT
.isExtnRecType()) THEN RETURN TRUE
END;
808 (* rhT is not extensible. It must support all of lhT's interfaces
810 RETURN rhT
.implementsAll(lhT
);
813 IF lhT
.equalType(rhT
) & ~lhT
.isExtnRecType() & ~lhT
.isOpenArrType() THEN
815 IF lhT
.includes(rhT
) THEN
817 IF lhT
.isPointerType() & lhT
.isBaseOf(rhT
) THEN
820 RETURN lhT
.isPointerType() OR lhT
.isProcType() END;
821 IF x
.isNumLit() & lhT
.isIntType() OR
822 x
.isCharLit() & lhT
.isCharType() OR
823 x
.isStrLit() & lhT
.isCharArrayType() THEN
824 RETURN x
.inRangeOf(lhT
) END;
826 RETURN lhT
.nativeCompat() OR lhT
.isCharArrayType() END;
827 IF lhT
.isInterfaceType() THEN
828 RETURN rhT
.implements(lhT
) END;
832 (* -------------------------------------------- *)
834 PROCEDURE (formal
: Idnt
)paramCompat
*(actual
: Expr
) : BOOLEAN,NEW;
838 IF (actual
= NIL) OR (actual
.type
= NIL) OR (formal
.type
= NIL) THEN
841 acType
:= actual
.type
;
842 fmType
:= formal
.type
;
845 IF fmType
.equalType(acType
) THEN RETURN TRUE
;
847 CASE formal
.parMode() OF
848 | val
: RETURN fmType
.assignCompat(actual
);
849 | out
: RETURN fmType
.isPointerType() & acType
.isBaseOf(fmType
);
850 | var
: RETURN fmType
.isExtnRecType() & fmType
.isBaseOf(acType
);
851 | in
: RETURN fmType
.isExtnRecType() & fmType
.isBaseOf(acType
) OR
852 fmType
.isPointerType() & fmType
.assignCompat(actual
);
853 (* Special case: CP-strings ok with IN-mode NativeString/Object *)
859 (* -------------------------------------------- *)
861 PROCEDURE (lhT
: Type
)arrayCompat
*(rhT
: Type
) : BOOLEAN,NEW,EXTENSIBLE
;
863 RETURN lhT
.equalType(rhT
); (* unless it is an array *)
866 (* ============================================================ *)
867 (* Various Appends, for the abstract types. *)
868 (* ============================================================ *)
870 PROCEDURE InitIdSeq
*(VAR seq
: IdSeq
; capacity
: INTEGER);
872 NEW(seq
.a
, capacity
); seq
.tide
:= 0; seq
.high
:= capacity
-1;
875 (* ---------------------------------- *)
877 PROCEDURE ResetIdSeq
*(VAR seq
: IdSeq
);
880 IF seq
.a
= NIL THEN InitIdSeq(seq
, 2) END;
883 (* ---------------------------------- *)
885 PROCEDURE (VAR seq
: IdSeq
)ResetTo
*(newTide
: INTEGER),NEW;
887 ASSERT(newTide
<= seq
.tide
);
891 (* ---------------------------------- *)
893 PROCEDURE AppendIdnt
*(VAR seq
: IdSeq
; elem
: Idnt
);
894 VAR temp
: POINTER TO ARRAY OF Idnt
;
899 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
901 seq
.high
:= seq
.high
* 2 + 1;
902 NEW(seq
.a
, seq
.high
+1);
903 FOR i
:= 0 TO seq
.tide
-1 DO seq
.a
[i
] := temp
[i
] END;
905 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
908 (* -------------------------------------------- *)
910 PROCEDURE InitTypeSeq
*(VAR seq
: TypeSeq
; capacity
: INTEGER);
912 NEW(seq
.a
, capacity
); seq
.tide
:= 0; seq
.high
:= capacity
-1;
915 PROCEDURE ResetTypeSeq
*(VAR seq
: TypeSeq
);
918 IF seq
.a
= NIL THEN InitTypeSeq(seq
, 2) END;
921 PROCEDURE AppendType
*(VAR seq
: TypeSeq
; elem
: Type
);
922 VAR temp
: POINTER TO ARRAY OF Type
;
927 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
929 seq
.high
:= seq
.high
* 2 + 1;
930 NEW(seq
.a
, (seq
.high
+1));
931 FOR i
:= 0 TO seq
.tide
-1 DO seq
.a
[i
] := temp
[i
] END;
933 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
936 (* -------------------------------------------- *)
938 PROCEDURE InitScpSeq
*(VAR seq
: ScpSeq
; capacity
: INTEGER);
940 NEW(seq
.a
, capacity
); seq
.tide
:= 0; seq
.high
:= capacity
-1;
943 PROCEDURE ResetScpSeq
*(VAR seq
: ScpSeq
);
946 IF seq
.a
= NIL THEN InitScpSeq(seq
, 2) END;
949 PROCEDURE AppendScope
*(VAR seq
: ScpSeq
; elem
: Scope
);
950 VAR temp
: POINTER TO ARRAY OF Scope
;
955 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
957 seq
.high
:= seq
.high
* 2 + 1;
958 NEW(seq
.a
, (seq
.high
+1));
959 FOR i
:= 0 TO seq
.tide
-1 DO seq
.a
[i
] := temp
[i
] END;
961 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
964 (* ============================================================ *)
966 PROCEDURE InitExprSeq
*(VAR seq
: ExprSeq
; capacity
: INTEGER);
968 NEW(seq
.a
, capacity
); seq
.tide
:= 0; seq
.high
:= capacity
-1;
971 (* ---------------------------------- *)
973 PROCEDURE ResetExprSeq
*(VAR seq
: ExprSeq
);
976 IF seq
.a
= NIL THEN InitExprSeq(seq
, 2) END;
979 (* ---------------------------------- *)
981 PROCEDURE (VAR seq
: ExprSeq
)ResetTo
*(newTide
: INTEGER),NEW;
983 ASSERT(newTide
<= seq
.tide
);
987 (* ---------------------------------- *)
989 PROCEDURE AppendExpr
*(VAR seq
: ExprSeq
; elem
: Expr
);
990 VAR temp
: POINTER TO ARRAY OF Expr
;
995 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
997 seq
.high
:= seq
.high
* 2 + 1;
998 NEW(seq
.a
, (seq
.high
+1));
999 FOR i
:= 0 TO seq
.tide
-1 DO seq
.a
[i
] := temp
[i
] END;
1001 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
1004 (* -------------------------------------------- *)
1006 PROCEDURE InitStmtSeq
*(VAR seq
: StmtSeq
; capacity
: INTEGER);
1008 NEW(seq
.a
, capacity
); seq
.tide
:= 0; seq
.high
:= capacity
-1;
1011 PROCEDURE AppendStmt
*(VAR seq
: StmtSeq
; elem
: Stmt
);
1012 VAR temp
: POINTER TO ARRAY OF Stmt
;
1016 InitStmtSeq(seq
, 2);
1017 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
1019 seq
.high
:= seq
.high
* 2 + 1;
1020 NEW(seq
.a
, (seq
.high
+1));
1021 FOR i
:= 0 TO seq
.tide
-1 DO seq
.a
[i
] := temp
[i
] END;
1023 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
1026 (* ============================================================ *)
1028 PROCEDURE (p
: Expr
)NoteCall
*(s
: Scope
),NEW,EMPTY
;
1030 (* ============================================================ *)
1032 PROCEDURE (p
: Expr
)enterGuard
*(tmp
: Idnt
) : Idnt
,NEW,EXTENSIBLE
;
1033 BEGIN RETURN NIL END enterGuard
;
1035 (* -------------------------------------------- *)
1037 PROCEDURE (p
: Expr
)ExitGuard
*(sav
: Idnt
; tmp
: Idnt
),NEW,EXTENSIBLE
;
1038 BEGIN END ExitGuard
;
1040 (* -------------------------------------------- *)
1042 PROCEDURE (p
: Expr
)checkLive
*(s
: Scope
;
1043 l
: V
.VarSet
) : V
.VarSet
,NEW,EXTENSIBLE
;
1044 BEGIN RETURN l
END checkLive
;
1046 (* -------------------------------------------- *)
1048 PROCEDURE (p
: Expr
)assignLive
*(s
: Scope
;
1049 l
: V
.VarSet
) : V
.VarSet
,NEW,EXTENSIBLE
;
1050 BEGIN RETURN p
.checkLive(s
,l
) END assignLive
;
1052 (* -------------------------------------------- *)
1054 PROCEDURE (p
: Expr
)BoolLive
*(scpe
: Scope
;
1056 OUT tSet
: V
.VarSet
;
1057 OUT fSet
: V
.VarSet
),NEW,EXTENSIBLE
;
1059 tSet
:= p
.checkLive(scpe
, lvIn
);
1063 (* ============================================================ *)
1064 (* Set methods for the read-only fields *)
1065 (* ============================================================ *)
1067 PROCEDURE (s
: Idnt
)SetMode
*(m
: INTEGER),NEW;
1068 BEGIN s
.vMod
:= m
END SetMode
;
1070 (* -------------------------------------------- *)
1072 PROCEDURE (s
: Idnt
)SetKind
*(m
: INTEGER),NEW;
1073 BEGIN s
.kind
:= m
END SetKind
;
1075 (* -------------------------------------------- *)
1077 PROCEDURE (s
: Type
)SetKind
*(m
: INTEGER),NEW;
1078 (** set the "kind" field AND allocate a serial#. *)
1081 IF m
# standard
THEN s
.serial
:= next
; INC(next
) END;
1084 (* -------------------------------------------- *)
1086 PROCEDURE (s
: Expr
)SetKind
*(m
: INTEGER),NEW;
1087 BEGIN s
.kind
:= m
END SetKind
;
1089 (* -------------------------------------------- *)
1091 PROCEDURE (s
: Stmt
)SetKind
*(m
: INTEGER),NEW;
1092 BEGIN s
.kind
:= m
END SetKind
;
1094 (* ============================================================ *)
1095 (* Abstract method of the SymForAll visitor base type *)
1096 (* ============================================================ *)
1098 PROCEDURE (s
: SymForAll
)Op
*(id
: Idnt
),NEW,ABSTRACT
;
1100 (* ============================================================ *)
1101 (* Name-fetch methods for type-name diagnostic strings *)
1102 (* ============================================================ *)
1104 PROCEDURE (g
: NameFetch
)Of
*(id
: Idnt
; OUT s
: ARRAY OF CHAR),NEW;
1105 VAR chO
: L
.CharOpen
;
1107 chO
:= NameHash
.charOpenOfHash(id
.hash
);
1108 IF chO
= NIL THEN s
:= "<NIL>" ELSE GPText
.Assign(chO^
,s
) END;
1111 (* -------------------------------------------- *)
1113 PROCEDURE (g
: NameFetch
)ChPtr
*(id
: Idnt
) : L
.CharOpen
,NEW;
1115 RETURN NameHash
.charOpenOfHash(id
.hash
);
1118 PROCEDURE (g
: NameFetch
)NtStr
*(id
: Idnt
) : RTS
.NativeString
,NEW;
1120 IF g
.ChPtr(id
) = NIL THEN RETURN NIL;
1121 ELSE RETURN MKSTR(g
.ChPtr(id
)^
);
1125 (* ============================================================ *)
1126 (* Private methods of the symbol-table info-blocks *)
1127 (* ============================================================ *)
1129 PROCEDURE mkSymInfo(h
: INTEGER; d
: Idnt
) : SymInfo
;
1132 NEW(rtrn
); rtrn
.key
:= h
; rtrn
.val
:= d
; RETURN rtrn
;
1135 (* -------------------------------------------- *)
1137 PROCEDURE (i
: SymInfo
)enter(h
: INTEGER; d
: Idnt
) : BOOLEAN,NEW;
1140 IF i
.lOp
= NIL THEN i
.lOp
:= mkSymInfo(h
,d
); RETURN TRUE
;
1141 ELSE RETURN i
.lOp
.enter(h
,d
);
1143 ELSIF h
> i
.key
THEN
1144 IF i
.rOp
= NIL THEN i
.rOp
:= mkSymInfo(h
,d
); RETURN TRUE
;
1145 ELSE RETURN i
.rOp
.enter(h
,d
);
1147 ELSE (* h must equal i.key *) RETURN FALSE
;
1151 (* -------------------------------------------- *)
1153 PROCEDURE (i
: SymInfo
)rmLeaf(h
: INTEGER) : SymInfo
,NEW;
1155 IF h
< i
.key
THEN i
.lOp
:= i
.lOp
.rmLeaf(h
);
1156 ELSIF h
> i
.key
THEN i
.rOp
:= i
.rOp
.rmLeaf(h
);
1157 ELSE (* h must equal i.key *) RETURN NIL;
1162 (* -------------------------------------------- *)
1164 PROCEDURE (i
: SymInfo
)write(h
: INTEGER; d
: Idnt
) : SymInfo
,NEW;
1167 rtrn
:= i
; (* default: return self *)
1168 IF h
< i
.key
THEN i
.lOp
:= i
.lOp
.write(h
,d
);
1169 ELSIF h
> i
.key
THEN i
.rOp
:= i
.rOp
.write(h
,d
);
1175 (* -------------------------------------------- *)
1177 PROCEDURE (i
: SymInfo
)lookup(h
: INTEGER) : Idnt
,NEW;
1180 IF i
.lOp
= NIL THEN RETURN NIL ELSE RETURN i
.lOp
.lookup(h
) END;
1181 ELSIF h
> i
.key
THEN
1182 IF i
.rOp
= NIL THEN RETURN NIL ELSE RETURN i
.rOp
.lookup(h
) END;
1183 ELSE (* h must equal i.key *)
1188 (* -------------------------------------------- *)
1190 PROCEDURE (i
: SymInfo
)Apply(s
: SymForAll
),NEW;
1192 s
.Op(i
.val
); (* Apply Op() to this node *)
1193 IF i
.lOp
# NIL THEN i
.lOp
.Apply(s
) END; (* Recurse to left subtree *)
1194 IF i
.rOp
# NIL THEN i
.rOp
.Apply(s
) END; (* Recurse to right subtree *)
1197 (* ============================================================ *)
1198 (* Public methods of the symbol-table type *)
1199 (* ============================================================ *)
1201 PROCEDURE (IN s
: SymbolTable
)isEmpty
*() : BOOLEAN,NEW;
1202 BEGIN RETURN s
.root
= NIL END isEmpty
;
1204 (* -------------------------------------------- *)
1206 PROCEDURE (VAR s
: SymbolTable
)enter
*(hsh
: INTEGER; id
: Idnt
) : BOOLEAN,NEW;
1207 (* Enter value in SymbolTable; Return value signals successful insertion. *)
1209 IF s
.root
= NIL THEN
1210 s
.root
:= mkSymInfo(hsh
,id
); RETURN TRUE
;
1212 RETURN s
.root
.enter(hsh
,id
);
1216 (* -------------------------------------------- *)
1218 PROCEDURE (VAR s
: SymbolTable
)Overwrite
*(hsh
: INTEGER; id
: Idnt
),NEW;
1219 (* Overwrite value in SymbolTable; value must be present. *)
1221 s
.root
:= s
.root
.write(hsh
,id
);
1224 (* -------------------------------------------- *)
1226 PROCEDURE (VAR s
: SymbolTable
)RemoveLeaf
*(hsh
: INTEGER),NEW;
1227 (* Remove value in SymbolTable; value must be a leaf. *)
1229 s
.root
:= s
.root
.rmLeaf(hsh
);
1232 (* -------------------------------------------- *)
1234 PROCEDURE (IN s
: SymbolTable
)lookup
*(h
: INTEGER) : Idnt
,NEW;
1235 (* Find value in symbol table, else return NIL. *)
1237 IF s
.root
= NIL THEN RETURN NIL ELSE RETURN s
.root
.lookup(h
) END;
1240 (* -------------------------------------------- *)
1242 PROCEDURE (IN tab
: SymbolTable
)Apply
*(sfa
: SymForAll
),NEW;
1243 (* Apply sfa.Op() to each entry in the symbol table. *)
1245 IF tab
.root
# NIL THEN tab
.root
.Apply(sfa
) END;
1248 (* ============================================================ *)
1249 (* Public static methods on symbol-tables *)
1250 (* ============================================================ *)
1252 PROCEDURE refused
*(id
: Idnt
; scp
: Scope
) : BOOLEAN;
1256 fail
:= ~scp
.symTb
.enter(id
.hash
, id
);
1258 clash
:= scp
.symTb
.lookup(id
.hash
);
1259 IF clash
.isImport() & clash
.isWeak() THEN
1260 scp
.symTb
.Overwrite(id
.hash
, id
); fail
:= FALSE
;
1266 (* -------------------------------------------- *)
1268 PROCEDURE bindLocal
*(hash
: INTEGER; scp
: Scope
) : Idnt
;
1270 RETURN scp
.symTb
.lookup(hash
);
1273 (* -------------------------------------------- *)
1275 PROCEDURE bind
*(hash
: INTEGER; scp
: Scope
) : Idnt
;
1278 resId
:= scp
.symTb
.lookup(hash
);
1281 WHILE (resId
= NIL) & (scp
# NIL) DO
1282 resId
:= scp
.symTb
.lookup(hash
);
1289 (* -------------------------------------------- *)
1291 PROCEDURE maxMode
*(i
,j
: INTEGER) : INTEGER;
1293 IF (i
= pubMode
) OR (j
= pubMode
) THEN RETURN pubMode
;
1294 ELSIF (i
= rdoMode
) OR (j
= rdoMode
) THEN RETURN rdoMode
;
1295 ELSE RETURN prvMode
;
1299 (* ============================================================ *)
1300 (* Various diagnostic methods *)
1301 (* ============================================================ *)
1303 PROCEDURE (IN tab
: SymbolTable
)Dump
*(i
: INTEGER),NEW;
1304 VAR sfa
: SymTabDump
;
1307 Console
.WriteString("+-------- Symtab dump ---------"); Console
.WriteLn
;
1312 Console
.WriteString("+-------- dump ended ----------"); Console
.WriteLn
;
1315 (* -------------------------------------------- *)
1317 PROCEDURE (id
: Idnt
)IdError
*(n
: INTEGER),NEW;
1320 IF id
.token
# NIL THEN l
:= id
.token
.lin
; c
:= id
.token
.col
;
1321 ELSE l
:= S
.line
; c
:= S
.col
;
1323 S
.SemError
.Report(n
, l
, c
);
1326 (* -------------------------------------------- *)
1328 PROCEDURE (id
: Idnt
)IdErrorStr
*(n
: INTEGER;
1329 IN s
: ARRAY OF CHAR),NEW;
1332 IF id
.token
# NIL THEN l
:= id
.token
.lin
; c
:= id
.token
.col
;
1333 ELSE l
:= S
.line
; c
:= S
.col
;
1335 S
.SemError
.RepSt1(n
,s
,l
,c
);
1338 (* -------------------------------------------- *)
1340 PROCEDURE (ty
: Type
)TypeError
*(n
: INTEGER),NEW,EXTENSIBLE
;
1343 IF (ty
.idnt
# NIL) & (ty
.idnt
.token
# NIL) THEN
1344 l
:= ty
.idnt
.token
.lin
; c
:= ty
.idnt
.token
.col
;
1345 ELSE l
:= S
.line
; c
:= S
.col
;
1347 S
.SemError
.Report(n
,l
,c
);
1350 (* -------------------------------------------- *)
1352 PROCEDURE (ty
: Type
)TypeErrStr
*(n
: INTEGER;
1353 IN s
: ARRAY OF CHAR),NEW,EXTENSIBLE
;
1356 IF (ty
.idnt
# NIL) & (ty
.idnt
.token
# NIL) THEN
1357 l
:= ty
.idnt
.token
.lin
; c
:= ty
.idnt
.token
.col
;
1358 ELSE l
:= S
.line
; c
:= S
.col
;
1360 S
.SemError
.RepSt1(n
,s
,l
,c
);
1363 (* -------------------------------------------- *)
1365 PROCEDURE (xp
: Expr
)ExprError
*(n
: INTEGER),NEW;
1368 IF xp
.token
# NIL THEN l
:= xp
.token
.lin
; c
:= xp
.token
.col
;
1369 ELSE l
:= S
.line
; c
:= S
.col
;
1371 S
.SemError
.Report(n
,l
,c
);
1374 (* -------------------------------------------- *)
1376 PROCEDURE (st
: Stmt
)StmtError
*(n
: INTEGER),NEW;
1379 IF st
.token
# NIL THEN l
:= st
.token
.lin
; c
:= st
.token
.col
;
1380 ELSE l
:= S
.line
; c
:= S
.col
;
1382 S
.SemError
.Report(n
,l
,c
);
1385 (* -------------------------------------------- *)
1387 PROCEDURE (id
: Idnt
)name
*() : L
.CharOpen
, NEW;
1389 RETURN NameHash
.charOpenOfHash(id
.hash
);
1392 PROCEDURE (t
: Idnt
)WriteName
*(),NEW;
1393 VAR name
: FileNames
.NameString
;
1395 getName
.Of(t
, name
);
1396 Console
.WriteString(name$
);
1399 (* -------------------------------------------- *)
1401 PROCEDURE DoXName
*(i
: INTEGER; s
: L
.CharOpen
);
1404 Console
.WriteString("name = ");
1405 IF s
# NIL THEN Console
.WriteString(s
) ELSE
1406 Console
.WriteString("<nil>") END;
1410 (* -------------------------------------------- *)
1412 PROCEDURE (t
: Idnt
)SuperDiag
*(i
: INTEGER),NEW;
1416 (* H.Class("Idnt",t,i); *)
1417 H
.Indent(i
); Console
.WriteString("Idnt: name = ");
1418 Console
.WriteString(getName
.ChPtr(t
));
1419 Console
.Write(modMrk
[t
.vMod
]);
1420 Console
.WriteString(" (");
1421 IF t
.type
= NIL THEN
1422 Console
.WriteString("no type");
1424 dump
:= t
.type
.dump
;
1425 Console
.WriteString(t
.type
.name());
1428 Console
.WriteString(") t$");
1429 Console
.WriteInt(dump
, 1);
1433 Console
.Write("#"); Console
.WriteInt(t
.hash
,1);
1437 (* -------------------------------------------- *)
1439 PROCEDURE (t
: Type
)SuperDiag
*(i
: INTEGER),NEW;
1441 (* H.Class("Type",t,i); *)
1442 H
.Indent(i
); Console
.WriteString("Type: ");
1443 Console
.WriteString(t
.name());
1445 Console
.WriteString(" t$");
1446 Console
.WriteInt(t
.dump
, 1);
1449 Console
.WriteString(" s#");
1450 Console
.WriteInt(t
.serial
, 1);
1454 (* -------------------------------------------- *)
1456 PROCEDURE (t
: Expr
)SuperDiag
*(i
: INTEGER),NEW;
1458 H
.Class("Expr",t
,i
);
1461 (* -------------------------------------------- *)
1463 PROCEDURE (t
: Stmt
)SuperDiag
*(i
: INTEGER),NEW;
1465 H
.Class("Stmt",t
,i
);
1466 IF t
.token
# NIL THEN
1468 Console
.WriteString("(lin:col ");
1469 Console
.WriteInt(t
.token
.lin
, 1); Console
.Write(":");
1470 Console
.WriteInt(t
.token
.col
, 1); Console
.Write(")");
1475 (* -------------------------------------------- *)
1477 PROCEDURE (s
: SymTabDump
)Op
*(id
: Idnt
);
1479 id
.Diagnose(s
.indent
);
1482 (* -------------------------------------------- *)
1484 PROCEDURE (s
: Type
)DiagFormalType
*(i
: INTEGER),NEW,EMPTY
;
1486 (* -------------------------------------------- *)
1488 PROCEDURE (x
: Expr
)DiagSrcLoc
*(),NEW;
1490 IF x
.token
# NIL THEN
1491 Console
.WriteString("Expr at ");
1492 Console
.WriteInt(x
.token
.lin
,1);
1494 Console
.WriteInt(x
.token
.col
,1);
1496 Console
.WriteString("no src token");
1501 (* -------------------------------------------- *)
1503 PROCEDURE newNameDump() : NameDump
;
1504 VAR dump
: NameDump
;
1513 (* --------------------------- *)
1515 PROCEDURE (sfa
: NameDump
)Op
*(id
: Idnt
);
1516 VAR name
: L
.CharOpen
;
1522 name
:= NameHash
.charOpenOfHash(id
.hash
);
1524 * IF sfa.tide + LEN(name) >= sfa.tide THEN OOPS!
1526 IF sfa
.tide
+ LEN(name
) >= sfa
.high
THEN
1528 newH
:= sfa
.high
+ 3 * LEN(name
);
1530 FOR indx
:= 0 TO sfa
.tide
- 1 DO
1531 sfa
.a
[indx
] := temp
[indx
];
1535 IF sfa
.tide
> 0 THEN
1536 sfa
.a
[sfa
.tide
-1] := ",";
1537 sfa
.a
[sfa
.tide
] := " ";
1543 sfa
.a
[sfa
.tide
] := char
;
1549 (* --------------------------- *)
1551 PROCEDURE dumpList
*(s
: SymbolTable
) : L
.CharOpen
;
1554 sfa
:= newNameDump();
1559 (* ============================================================ *)
1560 BEGIN (* ====================================================== *)
1564 modStr
[in
] := "IN ";
1565 modStr
[out
] := "OUT ";
1566 modStr
[var
] := "VAR ";
1567 END Symbols
. (* ============================================== *)
1568 (* ============================================================ *)