gpcp/Symbols.cp

   1 (* ==================================================================== *)
   2 (*                                                                      *)
   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.                                *)
   6 (*                                                                      *)
   7 (* ==================================================================== *)
   8
   9 MODULE Symbols;
  10
  11   IMPORT
  12         RTS,
  13         GPCPcopyright,
  14         GPText,
  15         Console,
  16         FileNames,
  17         NameHash,
  18         L := LitValue,
  19         V := VarSets,
  20         S := CPascalS,
  21         H := DiagHelper;
  22
  23 (* ============================================================ *)
  24
  25   CONST (* mode-kinds *)
  26     prvMode* = 0; pubMode* = 1; rdoMode* = 2; protect* = 3;
  27
  28   CONST (* param-modes *)
  29     val* = 0; in* = 1; out* = 2; var* = 3; notPar* = 4;
  30
  31   CONST (* force-kinds *)
  32     noEmit* = 0; partEmit* = 1; forced* = 2;
  33
  34   CONST
  35     standard* = 0;
  36
  37   CONST
  38     tOffset*  = 16; (* backward compatibility with JavaVersion *)
  39
  40 (* ============================================================ *)
  41 (*    Foreign attributes for modules, procedures and classes  *)
  42 (* ============================================================ *)
  43
  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;
  52
  53 (* ============================================================ *)
  54
  55   TYPE NameStr* = ARRAY 64 OF CHAR;
  56
  57 (* ============================================================ *)
  58
  59   TYPE
  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 *)
  70
  71     IdSeq*  = RECORD
  72                 tide-, high : INTEGER;
  73                 a- : POINTER TO ARRAY OF Idnt;
  74               END;
  75
  76     Scope*  = POINTER TO ABSTRACT RECORD (Idnt)
  77                 symTb*   : SymbolTable; (* symbol scope   *)
  78                 endDecl* : BOOLEAN;
  79                 ovfChk*  : BOOLEAN;
  80                 locals*  : IdSeq;
  81                 scopeNm* : L.CharOpen   (* external name  *)
  82               END;
  83
  84     ScpSeq*  = RECORD
  85                 tide-, high : INTEGER;
  86                 a- : POINTER TO ARRAY OF Scope;
  87               END;
  88
  89 (* ============================================================ *)
  90
  91   TYPE
  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   *)
 100               END;
 101
 102     TypeSeq*  = RECORD
 103                   tide-, high : INTEGER;
 104                   a- : POINTER TO ARRAY OF Type;
 105                 END;
 106
 107 (* ============================================================ *)
 108
 109   TYPE
 110     Stmt*   = POINTER TO ABSTRACT RECORD
 111                 kind-  : INTEGER; (* tag for unions *)
 112                 token* : S.Token; (* stmt first tok *)
 113               END;
 114
 115     StmtSeq*  = RECORD
 116                   tide-, high : INTEGER;
 117                   a- : POINTER TO ARRAY OF Stmt;
 118                 END;
 119
 120 (* ============================================================ *)
 121
 122   TYPE
 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 *)
 127                 type*  : Type;
 128               END;
 129
 130     ExprSeq*  = RECORD
 131                   tide-, high : INTEGER;
 132                   a- : POINTER TO ARRAY OF Expr;
 133                 END;
 134
 135 (* ============================================================ *)
 136
 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    *)
 143               END;
 144
 145     SymbolTable* = RECORD
 146                      root : SymInfo;
 147                    END;
 148
 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 (* ============================================================ *)
 157
 158   TYPE
 159     SymForAll*  = POINTER TO ABSTRACT RECORD END;
 160
 161     SymTabDump* = POINTER TO RECORD (SymForAll)
 162                     indent : INTEGER;
 163                   END;
 164
 165     NameDump*   = POINTER TO RECORD (SymForAll)
 166                     tide, high : INTEGER;
 167                     a : L.CharOpen;
 168                   END;
 169
 170 (* ============================================================ *)
 171
 172   TYPE
 173     SccTable*  = POINTER TO RECORD
 174                    symTab*  : SymbolTable;
 175                    target*  : Type;
 176                    reached* : BOOLEAN;
 177                  END;
 178
 179 (* ============================================================ *)
 180
 181   TYPE
 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;   *)
 186
 187 (* ============================================================ *)
 188
 189   VAR modStr-  : ARRAY 4 OF ARRAY 5 OF CHAR;
 190       modMrk-  : ARRAY 5 OF CHAR;
 191       anonMrk- : ARRAY 3 OF CHAR;
 192       trgtNET- : BOOLEAN;
 193       getName* : NameFetch;
 194       next     : INTEGER; (* private: next serial number. *)
 195
 196 (* ============================================================ *)
 197
 198   PROCEDURE SetTargetIsNET*(p : BOOLEAN);
 199   BEGIN
 200     trgtNET := p;
 201     IF p THEN anonMrk := "@T" ELSE anonMrk := "$T" END;
 202   END SetTargetIsNET;
 203
 204 (* ============================================================ *)
 205 (*             Abstract attribution methods                     *)
 206 (* ============================================================ *)
 207
 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;
 211
 212 (* ============================================================ *)
 213 (*             Abstract type erase methods                      *)
 214 (* ============================================================ *)
 215
 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;
 219
 220 (* ============================================================ *)
 221 (*             Abstract diagnostic methods                      *)
 222 (* ============================================================ *)
 223
 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;
 229
 230   PROCEDURE (t : Idnt)SetNameFromString*(nam : L.CharOpen),NEW;
 231   BEGIN
 232     t.namStr := MKSTR(nam^);
 233   END SetNameFromString;
 234
 235   PROCEDURE (t : Idnt)SetNameFromHash*(hash : INTEGER),NEW;
 236   BEGIN
 237     t.namStr := MKSTR(NameHash.charOpenOfHash(hash)^);
 238   END SetNameFromHash;
 239
 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;
 247   BEGIN
 248     IF t.namStr # NIL THEN RETURN t.namStr;
 249         ELSE RETURN MKSTR(NameHash.charOpenOfHash(t.hash)^);
 250         END;
 251   END ToString;
 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;
 260   BEGIN
 261     IF t.namStr # NIL THEN RETURN t.namStr;
 262         ELSE RETURN MKSTR(NameHash.charOpenOfHash(t.hash)^);
 263         END;
 264   END toString;
 265  * ============================================================ *)
 266 (* ============================================================ *)
 267
 268
 269 (* ============================================================ *)
 270 (*             Base Class text-span method                      *)
 271 (* ============================================================ *)
 272
 273   PROCEDURE (s : Stmt)Span*() : S.Span,NEW,EXTENSIBLE;
 274   BEGIN
 275     RETURN S.mkSpanT(s.token);
 276   END Span;
 277
 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 (* ============================================================ *)
 284
 285   PROCEDURE (s : Idnt)isImport*() : BOOLEAN,NEW,EXTENSIBLE;
 286   BEGIN RETURN FALSE END isImport;
 287
 288 (* -------------------------------------------- *)
 289
 290   PROCEDURE (s : Idnt)isImported*() : BOOLEAN,NEW,EXTENSIBLE;
 291   BEGIN
 292     RETURN (s.dfScp # NIL) & s.dfScp.isImport();
 293   END isImported;
 294
 295 (* -------------------------------------------- *)
 296
 297   PROCEDURE (s : Type)isImportedType*() : BOOLEAN,NEW,EXTENSIBLE;
 298   BEGIN
 299     RETURN (s.idnt # NIL) &
 300      (s.idnt.dfScp # NIL) &
 301       s.idnt.dfScp.isImport();
 302   END isImportedType;
 303
 304 (* -------------------------------------------- *)
 305   PROCEDURE^ (xp : Expr)ExprError*(n : INTEGER),NEW;
 306
 307   PROCEDURE (s : Idnt)mutable*() : BOOLEAN,NEW,EXTENSIBLE;
 308   BEGIN RETURN FALSE END mutable;
 309
 310   PROCEDURE (s : Idnt)CheckMutable*(x : Expr),NEW,EXTENSIBLE;
 311   BEGIN x.ExprError(181) END CheckMutable;
 312
 313 (* -------------------------------------------- *)
 314
 315   PROCEDURE (s : Idnt)isStatic*() : BOOLEAN,NEW,EXTENSIBLE;
 316   BEGIN RETURN FALSE END isStatic;
 317
 318 (* -------------------------------------------- *)
 319
 320   PROCEDURE (s : Idnt)isLocalVar*() : BOOLEAN,NEW,EXTENSIBLE;
 321   BEGIN RETURN FALSE END isLocalVar;
 322
 323 (* -------------------------------------------- *)
 324
 325   PROCEDURE (s : Idnt)isWeak*() : BOOLEAN,NEW,EXTENSIBLE;
 326   BEGIN RETURN FALSE END isWeak;
 327
 328 (* -------------------------------------------- *)
 329
 330   PROCEDURE (s : Idnt)isDynamic*() : BOOLEAN,NEW,EXTENSIBLE;
 331   BEGIN RETURN FALSE END isDynamic;
 332
 333 (* -------------------------------------------- *)
 334
 335   PROCEDURE (s : Idnt)isAbstract*() : BOOLEAN,NEW,EXTENSIBLE;
 336   BEGIN RETURN FALSE END isAbstract;
 337
 338 (* -------------------------------------------- *)
 339
 340   PROCEDURE (s : Idnt)isEmpty*() : BOOLEAN,NEW,EXTENSIBLE;
 341   BEGIN RETURN FALSE END isEmpty;
 342
 343 (* -------------------------------------------- *)
 344
 345   PROCEDURE (i : Idnt)parMode*() : INTEGER,NEW,EXTENSIBLE;
 346   BEGIN RETURN notPar END parMode;
 347
 348 (* -------------------------------------------- *)
 349 (* ????
 350   PROCEDURE (s : Idnt)isRcv*() : BOOLEAN,NEW,EXTENSIBLE;
 351   BEGIN RETURN FALSE END isRcv;
 352  *)
 353 (* -------------------------------------------- *)
 354 (* ????
 355   PROCEDURE (s : Idnt)isAssignProc*() : BOOLEAN,NEW,EXTENSIBLE;
 356   BEGIN RETURN FALSE END isAssignProc;
 357  *)
 358 (* ============================================================ *)
 359 (*    Base predicates on Type extensions                        *)
 360 (* ============================================================ *)
 361
 362   PROCEDURE (l : Type)equalOpenOrVector*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
 363   BEGIN RETURN FALSE END equalOpenOrVector;
 364
 365 (* -------------------------------------------- *)
 366
 367   PROCEDURE (l : Type)procMatch*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
 368   BEGIN RETURN FALSE END procMatch;
 369
 370 (* -------------------------------------------- *)
 371
 372   PROCEDURE (l : Type)namesMatch*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
 373   BEGIN RETURN FALSE END namesMatch;
 374
 375 (* -------------------------------------------- *)
 376
 377   PROCEDURE (l : Type)sigsMatch*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
 378   BEGIN RETURN FALSE END sigsMatch;
 379
 380 (* -------------------------------------------- *)
 381
 382   PROCEDURE (l : Type)equalPointers*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
 383   BEGIN RETURN FALSE END equalPointers;
 384
 385 (* -------------------------------------------- *)
 386
 387   PROCEDURE (i : Type)isAnonType*() : BOOLEAN,NEW;
 388   BEGIN RETURN (i.idnt = NIL) OR (i.idnt.dfScp = NIL) END isAnonType;
 389
 390 (* -------------------------------------------- *)
 391
 392   PROCEDURE (i : Type)isBaseType*() : BOOLEAN,NEW,EXTENSIBLE;
 393   BEGIN RETURN FALSE END isBaseType;
 394
 395 (* -------------------------------------------- *)
 396
 397   PROCEDURE (i : Type)isIntType*() : BOOLEAN,NEW,EXTENSIBLE;
 398   BEGIN RETURN FALSE END isIntType;
 399
 400 (* -------------------------------------------- *)
 401
 402   PROCEDURE (s : Idnt)isIn*(set : V.VarSet) : BOOLEAN,NEW,EXTENSIBLE;
 403   BEGIN RETURN TRUE END isIn;
 404
 405 (* -------------------------------------------- *)
 406
 407   PROCEDURE (i : Type)isNumType*() : BOOLEAN,NEW,EXTENSIBLE;
 408   BEGIN RETURN FALSE END isNumType;
 409
 410 (* -------------------------------------------- *)
 411
 412   PROCEDURE (i : Type)isScalarType*() : BOOLEAN,NEW,EXTENSIBLE;
 413   BEGIN RETURN TRUE END isScalarType; (* all except arrays, records *)
 414
 415 (* -------------------------------------------- *)
 416
 417   PROCEDURE (i : Type)isSetType*() : BOOLEAN,NEW,EXTENSIBLE;
 418   BEGIN RETURN FALSE END isSetType;
 419
 420 (* -------------------------------------------- *)
 421
 422   PROCEDURE (i : Type)isRealType*() : BOOLEAN,NEW,EXTENSIBLE;
 423   BEGIN RETURN FALSE END isRealType;
 424
 425 (* -------------------------------------------- *)
 426
 427   PROCEDURE (i : Type)isCharType*() : BOOLEAN,NEW,EXTENSIBLE;
 428   BEGIN RETURN FALSE END isCharType;
 429
 430 (* -------------------------------------------- *)
 431
 432   PROCEDURE (i : Type)isBooleanType*() : BOOLEAN,NEW,EXTENSIBLE;
 433   BEGIN RETURN FALSE END isBooleanType;
 434
 435 (* -------------------------------------------- *)
 436
 437   PROCEDURE (i : Type)isStringType*() : BOOLEAN,NEW,EXTENSIBLE;
 438   BEGIN RETURN FALSE END isStringType;
 439
 440 (* -------------------------------------------- *)
 441
 442   PROCEDURE (i : Type)nativeCompat*() : BOOLEAN,NEW,EXTENSIBLE;
 443   BEGIN RETURN FALSE END nativeCompat;
 444
 445 (* -------------------------------------------- *)
 446
 447   PROCEDURE (i : Type)isCharArrayType*() : BOOLEAN,NEW,EXTENSIBLE;
 448   BEGIN RETURN FALSE END isCharArrayType;
 449
 450 (* -------------------------------------------- *)
 451
 452   PROCEDURE (s : Type)isRefSurrogate*() : BOOLEAN,NEW,EXTENSIBLE;
 453   BEGIN RETURN FALSE END isRefSurrogate;
 454
 455 (* -------------------------------------------- *)
 456
 457   PROCEDURE (i : Type)isPointerType*() : BOOLEAN,NEW,EXTENSIBLE;
 458   BEGIN RETURN FALSE END isPointerType;
 459
 460 (* -------------------------------------------- *)
 461
 462   PROCEDURE (i : Type)isRecordType*() : BOOLEAN,NEW,EXTENSIBLE;
 463   BEGIN RETURN FALSE END isRecordType;
 464
 465 (* -------------------------------------------- *)
 466
 467   PROCEDURE (i : Type)isProcType*() : BOOLEAN,NEW,EXTENSIBLE;
 468   BEGIN RETURN FALSE END isProcType;
 469
 470 (* -------------------------------------------- *)
 471
 472   PROCEDURE (i : Type)isProperProcType*() : BOOLEAN,NEW,EXTENSIBLE;
 473   BEGIN RETURN FALSE END isProperProcType;
 474
 475 (* -------------------------------------------- *)
 476
 477   PROCEDURE (i : Type)isDynamicType*() : BOOLEAN,NEW,EXTENSIBLE;
 478   BEGIN RETURN FALSE END isDynamicType;
 479
 480 (* -------------------------------------------- *)
 481
 482   PROCEDURE (i : Type)isAbsRecType*() : BOOLEAN,NEW,EXTENSIBLE;
 483   BEGIN RETURN FALSE END isAbsRecType;
 484
 485 (* -------------------------------------------- *)
 486
 487   PROCEDURE (i : Type)isLimRecType*() : BOOLEAN,NEW,EXTENSIBLE;
 488   BEGIN RETURN FALSE END isLimRecType;
 489
 490 (* -------------------------------------------- *)
 491
 492   PROCEDURE (i : Type)isExtnRecType*() : BOOLEAN,NEW,EXTENSIBLE;
 493   BEGIN RETURN FALSE END isExtnRecType;
 494
 495 (* -------------------------------------------- *)
 496
 497   PROCEDURE (i : Type)isOpenArrType*() : BOOLEAN,NEW,EXTENSIBLE;
 498   BEGIN RETURN FALSE END isOpenArrType;
 499
 500   PROCEDURE (i : Type)isVectorType*() : BOOLEAN,NEW,EXTENSIBLE;
 501   BEGIN RETURN FALSE END isVectorType;
 502
 503 (* -------------------------------------------- *)
 504
 505   PROCEDURE (i : Type)needsInit*() : BOOLEAN,NEW,EXTENSIBLE;
 506   BEGIN RETURN TRUE END needsInit;
 507
 508 (* -------------------------------------------- *)
 509
 510   PROCEDURE (i : Type)isForeign*() : BOOLEAN,NEW,EXTENSIBLE;
 511   BEGIN RETURN FALSE END isForeign;
 512
 513 (* -------------------------------------------- *)
 514
 515   PROCEDURE (i : Type)valCopyOK*() : BOOLEAN,NEW,EXTENSIBLE;
 516   BEGIN RETURN TRUE END valCopyOK;
 517
 518 (* -------------------------------------------- *)
 519
 520   PROCEDURE (i : Type)isInterfaceType*() : BOOLEAN,NEW,EXTENSIBLE;
 521   BEGIN RETURN FALSE END isInterfaceType;
 522
 523 (* -------------------------------------------- *)
 524
 525   PROCEDURE (i : Type)isEventType*() : BOOLEAN,NEW,EXTENSIBLE;
 526   BEGIN RETURN FALSE END isEventType;
 527
 528 (* -------------------------------------------- *)
 529
 530   PROCEDURE (i : Type)isCompoundType*() : BOOLEAN,NEW,EXTENSIBLE;
 531   (* Returns TRUE if the type is a compound type *)
 532   BEGIN RETURN FALSE END isCompoundType;
 533
 534 (* -------------------------------------------- *)
 535
 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
 540    * type. *)
 541   BEGIN RETURN i END ImplementationType;
 542
 543 (* -------------------------------------------- *)
 544
 545   PROCEDURE (i : Type)implements*(x : Type) : BOOLEAN,NEW,EXTENSIBLE;
 546   BEGIN RETURN FALSE END implements;
 547
 548 (* -------------------------------------------- *)
 549
 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;
 555
 556 (* -------------------------------------------- *)
 557
 558   PROCEDURE (b : Type)isBaseOf*(x : Type) : BOOLEAN,NEW,EXTENSIBLE;
 559   BEGIN RETURN FALSE END isBaseOf;
 560
 561 (* -------------------------------------------- *)
 562
 563   PROCEDURE (i : Type)isLongType*() : BOOLEAN,NEW,EXTENSIBLE;
 564   BEGIN RETURN FALSE END isLongType;
 565
 566 (* -------------------------------------------- *)
 567
 568   PROCEDURE (i : Type)isNativeObj*() : BOOLEAN,NEW,EXTENSIBLE;
 569   BEGIN RETURN FALSE END isNativeObj;
 570
 571 (* -------------------------------------------- *)
 572
 573   PROCEDURE (i : Type)isNativeStr*() : BOOLEAN,NEW,EXTENSIBLE;
 574   BEGIN RETURN FALSE END isNativeStr;
 575
 576 (* -------------------------------------------- *)
 577
 578   PROCEDURE (i : Type)isNativeExc*() : BOOLEAN,NEW,EXTENSIBLE;
 579   BEGIN RETURN FALSE END isNativeExc;
 580
 581 (* -------------------------------------------- *)
 582
 583   PROCEDURE (b : Type)includes*(x : Type) : BOOLEAN,NEW,EXTENSIBLE;
 584   BEGIN RETURN FALSE END includes;
 585
 586 (* -------------------------------------------- *)
 587
 588   PROCEDURE (i : Type)boundRecTp*() : Type,NEW,EXTENSIBLE;
 589   BEGIN RETURN NIL END boundRecTp;
 590
 591 (* -------------------------------------------- *)
 592
 593   PROCEDURE (i : Type)superType*() : Type,NEW,EXTENSIBLE;
 594   BEGIN RETURN NIL END superType;
 595
 596 (* -------------------------------------------- *)
 597
 598   PROCEDURE (i : Type)elaboration*() : Type,NEW,EXTENSIBLE;
 599   BEGIN RETURN i END elaboration;
 600
 601 (* -------------------------------------------- *)
 602
 603   PROCEDURE (i : Type)inheritedFeature*(m : Idnt) : Idnt,NEW,EXTENSIBLE;
 604   BEGIN
 605     RETURN NIL;
 606   END inheritedFeature;
 607
 608 (* -------------------------------------------- *)
 609
 610   PROCEDURE (i : Type)returnType*() : Type,NEW,EXTENSIBLE;
 611   BEGIN RETURN NIL END returnType;
 612
 613 (* -------------------------------------------- *)
 614
 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;
 624
 625 (* -------------------------------------------- *)
 626
 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;
 631
 632 (* ============================================================ *)
 633 (*    Base predicates on Expr extensions                        *)
 634 (* ============================================================ *)
 635
 636   PROCEDURE (i : Expr)isNil*() : BOOLEAN,NEW,EXTENSIBLE;
 637   BEGIN RETURN FALSE END isNil;
 638
 639 (* -------------------------------------------- *)
 640   PROCEDURE (i : Expr)isInf*() : BOOLEAN,NEW,EXTENSIBLE;
 641   BEGIN RETURN FALSE END isInf;
 642
 643 (* -------------------------------------------- *)
 644
 645   PROCEDURE (x : Expr)isWriteable*() : BOOLEAN,NEW,EXTENSIBLE;
 646   BEGIN RETURN FALSE END isWriteable;
 647
 648   PROCEDURE (x : Expr)CheckWriteable*(),NEW,EXTENSIBLE;
 649   BEGIN x.ExprError(103) END CheckWriteable;
 650
 651 (* -------------------------------------------- *)
 652
 653   PROCEDURE (x : Expr)isVarDesig*() : BOOLEAN,NEW,EXTENSIBLE;
 654   BEGIN RETURN FALSE END isVarDesig;
 655
 656 (* -------------------------------------------- *)
 657
 658   PROCEDURE (x : Expr)isProcVar*() : BOOLEAN,NEW,EXTENSIBLE;
 659   BEGIN RETURN FALSE END isProcVar;
 660
 661 (* -------------------------------------------- *)
 662
 663   PROCEDURE (x : Expr)isJavaInit*() : BOOLEAN,NEW,EXTENSIBLE;
 664   BEGIN RETURN FALSE END isJavaInit;
 665
 666 (* -------------------------------------------- *)
 667
 668   PROCEDURE (x : Expr)isSetExpr*() : BOOLEAN,NEW;
 669   BEGIN RETURN (x.type # NIL) & (x.type.isSetType()) END isSetExpr;
 670
 671 (* -------------------------------------------- *)
 672
 673   PROCEDURE (x : Expr)isBooleanExpr*() : BOOLEAN,NEW;
 674   BEGIN RETURN (x.type # NIL) & (x.type.isBooleanType()) END isBooleanExpr;
 675
 676 (* -------------------------------------------- *)
 677
 678   PROCEDURE (x : Expr)isCharArray*() : BOOLEAN,NEW;
 679   BEGIN RETURN (x.type # NIL) & (x.type.isCharArrayType()) END isCharArray;
 680
 681 (* -------------------------------------------- *)
 682
 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;
 686
 687 (* -------------------------------------------- *)
 688
 689   PROCEDURE (x : Expr)isCharExpr*() : BOOLEAN,NEW;
 690   BEGIN
 691     RETURN x.isCharLit() OR
 692     (x.type # NIL) & (x.type.isCharType());
 693   END isCharExpr;
 694
 695 (* -------------------------------------------- *)
 696
 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;
 700
 701 (* -------------------------------------------- *)
 702
 703   PROCEDURE (x : Expr)isNumLit*() : BOOLEAN,NEW,EXTENSIBLE;
 704   (** Any literal integer. *)
 705   BEGIN RETURN FALSE END isNumLit;
 706
 707 (* -------------------------------------------- *)
 708
 709   PROCEDURE (x : Expr)isStrLit*() : BOOLEAN,NEW,EXTENSIBLE;
 710   (** Any literal string. *)
 711   BEGIN RETURN FALSE END isStrLit;
 712
 713 (* -------------------------------------------- *)
 714
 715   PROCEDURE (x : Expr)isProcLit*() : BOOLEAN,NEW,EXTENSIBLE;
 716   (** Any literal procedure. *)
 717   BEGIN RETURN FALSE END isProcLit;
 718
 719 (* -------------------------------------------- *)
 720
 721   PROCEDURE (x : Expr)isPointerExpr*() : BOOLEAN,NEW;
 722   BEGIN RETURN (x.type # NIL) & x.type.isPointerType() END isPointerExpr;
 723
 724   PROCEDURE (x : Expr)isVectorExpr*() : BOOLEAN,NEW;
 725   BEGIN RETURN (x.type # NIL) & x.type.isVectorType() END isVectorExpr;
 726
 727 (* -------------------------------------------- *)
 728
 729   PROCEDURE (x : Expr)isProcExpr*() : BOOLEAN,NEW;
 730   BEGIN RETURN (x.type # NIL) & x.type.isProcType() END isProcExpr;
 731
 732 (* -------------------------------------------- *)
 733
 734   PROCEDURE (x : Expr)isIntExpr*() : BOOLEAN,NEW;
 735   BEGIN RETURN (x.type # NIL) & x.type.isIntType() END isIntExpr;
 736
 737 (* -------------------------------------------- *)
 738
 739   PROCEDURE (x : Expr)isRealExpr*() : BOOLEAN,NEW;
 740   BEGIN RETURN (x.type # NIL) & x.type.isRealType() END isRealExpr;
 741
 742 (* -------------------------------------------- *)
 743
 744   PROCEDURE (x : Expr)isNumericExpr*() : BOOLEAN,NEW;
 745   BEGIN RETURN (x.type # NIL) & x.type.isNumType() END isNumericExpr;
 746
 747 (* -------------------------------------------- *)
 748
 749   PROCEDURE (x : Expr)isStdFunc*() : BOOLEAN,NEW,EXTENSIBLE;
 750   BEGIN RETURN FALSE END isStdFunc;
 751
 752 (* -------------------------------------------- *)
 753
 754   PROCEDURE (x : Expr)hasDynamicType*() : BOOLEAN,NEW,EXTENSIBLE;
 755   (* overridden for IdLeaf extension of LeafX expression type *)
 756   BEGIN
 757     RETURN (x.type # NIL) & x.type.isDynamicType();
 758   END hasDynamicType;
 759
 760 (* -------------------------------------------- *)
 761
 762   PROCEDURE (x : Expr)isStdProc*() : BOOLEAN,NEW,EXTENSIBLE;
 763   BEGIN RETURN FALSE END isStdProc;
 764
 765 (* -------------------------------------------- *)
 766
 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;
 771
 772 (* ============================================================ *)
 773
 774   PROCEDURE RepTypesError*(n : INTEGER; lT,rT : Type; ln,cl : INTEGER);
 775   BEGIN
 776     S.SemError.RepSt2(n, lT.name(), rT.name(), ln, cl);
 777   END RepTypesError;
 778
 779   PROCEDURE RepTypesErrTok*(n : INTEGER; lT,rT : Type; tk : S.Token);
 780   BEGIN
 781     S.SemError.RepSt2(n, lT.name(), rT.name(), tk.lin, tk.col);
 782   END RepTypesErrTok;
 783
 784 (* ============================================================ *)
 785 (*    Various Type Compatability tests.                         *)
 786 (* ============================================================ *)
 787
 788   PROCEDURE (lhT : Type)equalType*(rhT : Type) : BOOLEAN,NEW,EXTENSIBLE;
 789   BEGIN
 790     RETURN (lhT = rhT)
 791         OR lhT.equalPointers(rhT)
 792         OR lhT.equalOpenOrVector(rhT)
 793         OR lhT.procMatch(rhT);
 794   END equalType;
 795
 796 (* -------------------------------------------- *)
 797
 798   PROCEDURE (lhT : Type)assignCompat*(x : Expr) : BOOLEAN,NEW;
 799     VAR rhT : Type;
 800   BEGIN
 801     IF (x = NIL) OR (x.type = NIL) THEN RETURN TRUE; END;
 802     rhT := x.type;
 803
 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
 809        * statically *)
 810       RETURN rhT.implementsAll(lhT);
 811     END;
 812
 813     IF lhT.equalType(rhT) & ~lhT.isExtnRecType() & ~lhT.isOpenArrType() THEN
 814         RETURN TRUE END;
 815     IF lhT.includes(rhT) THEN
 816         RETURN TRUE END;
 817     IF lhT.isPointerType() & lhT.isBaseOf(rhT) THEN
 818         RETURN TRUE END;
 819     IF x.isNil() 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;
 825     IF x.isString() THEN
 826         RETURN  lhT.nativeCompat() OR lhT.isCharArrayType() END;
 827     IF lhT.isInterfaceType() THEN
 828         RETURN  rhT.implements(lhT) END;
 829     RETURN FALSE;
 830   END assignCompat;
 831
 832 (* -------------------------------------------- *)
 833
 834   PROCEDURE (formal : Idnt)paramCompat*(actual : Expr) : BOOLEAN,NEW;
 835     VAR acType : Type;
 836         fmType : Type;
 837   BEGIN
 838     IF (actual = NIL) OR (actual.type = NIL) OR (formal.type = NIL) THEN
 839       RETURN TRUE;
 840     ELSE
 841       acType := actual.type;
 842       fmType := formal.type;
 843     END;
 844
 845     IF fmType.equalType(acType) THEN RETURN TRUE;
 846     ELSE
 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 *)
 854       ELSE RETURN FALSE;
 855       END;
 856     END;
 857   END paramCompat;
 858
 859 (* -------------------------------------------- *)
 860
 861   PROCEDURE (lhT : Type)arrayCompat*(rhT : Type) : BOOLEAN,NEW,EXTENSIBLE;
 862   BEGIN
 863     RETURN lhT.equalType(rhT);  (* unless it is an array *)
 864   END arrayCompat;
 865
 866 (* ============================================================ *)
 867 (*        Various Appends, for the abstract types.              *)
 868 (* ============================================================ *)
 869
 870   PROCEDURE InitIdSeq*(VAR seq : IdSeq; capacity : INTEGER);
 871   BEGIN
 872     NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
 873   END InitIdSeq;
 874
 875   (* ---------------------------------- *)
 876
 877   PROCEDURE ResetIdSeq*(VAR seq : IdSeq);
 878   BEGIN
 879     seq.tide := 0;
 880     IF seq.a = NIL THEN InitIdSeq(seq, 2) END;
 881   END ResetIdSeq;
 882
 883   (* ---------------------------------- *)
 884
 885   PROCEDURE (VAR seq : IdSeq)ResetTo*(newTide : INTEGER),NEW;
 886   BEGIN
 887     ASSERT(newTide <= seq.tide);
 888     seq.tide := newTide;
 889   END ResetTo;
 890
 891   (* ---------------------------------- *)
 892
 893   PROCEDURE AppendIdnt*(VAR seq : IdSeq; elem : Idnt);
 894     VAR temp : POINTER TO ARRAY OF Idnt;
 895         i    : INTEGER;
 896   BEGIN
 897     IF seq.a = NIL THEN
 898       InitIdSeq(seq, 2);
 899     ELSIF seq.tide > seq.high THEN (* must expand *)
 900       temp := seq.a;
 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;
 904     END;
 905     seq.a[seq.tide] := elem; INC(seq.tide);
 906   END AppendIdnt;
 907
 908 (* -------------------------------------------- *)
 909
 910   PROCEDURE InitTypeSeq*(VAR seq : TypeSeq; capacity : INTEGER);
 911   BEGIN
 912     NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
 913   END InitTypeSeq;
 914
 915   PROCEDURE ResetTypeSeq*(VAR seq : TypeSeq);
 916   BEGIN
 917     seq.tide := 0;
 918     IF seq.a = NIL THEN InitTypeSeq(seq, 2) END;
 919   END ResetTypeSeq;
 920
 921   PROCEDURE AppendType*(VAR seq : TypeSeq; elem : Type);
 922     VAR temp : POINTER TO ARRAY OF Type;
 923         i    : INTEGER;
 924   BEGIN
 925     IF seq.a = NIL THEN
 926       InitTypeSeq(seq, 2);
 927     ELSIF seq.tide > seq.high THEN (* must expand *)
 928       temp := seq.a;
 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;
 932     END;
 933     seq.a[seq.tide] := elem; INC(seq.tide);
 934   END AppendType;
 935
 936 (* -------------------------------------------- *)
 937
 938   PROCEDURE InitScpSeq*(VAR seq : ScpSeq; capacity : INTEGER);
 939   BEGIN
 940     NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
 941   END InitScpSeq;
 942
 943   PROCEDURE ResetScpSeq*(VAR seq : ScpSeq);
 944   BEGIN
 945     seq.tide := 0;
 946     IF seq.a = NIL THEN InitScpSeq(seq, 2) END;
 947   END ResetScpSeq;
 948
 949   PROCEDURE AppendScope*(VAR seq : ScpSeq; elem : Scope);
 950     VAR temp : POINTER TO ARRAY OF Scope;
 951         i    : INTEGER;
 952   BEGIN
 953     IF seq.a = NIL THEN
 954       InitScpSeq(seq, 2);
 955     ELSIF seq.tide > seq.high THEN (* must expand *)
 956       temp := seq.a;
 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;
 960     END;
 961     seq.a[seq.tide] := elem; INC(seq.tide);
 962   END AppendScope;
 963
 964 (* ============================================================ *)
 965
 966   PROCEDURE InitExprSeq*(VAR seq : ExprSeq; capacity : INTEGER);
 967   BEGIN
 968     NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
 969   END InitExprSeq;
 970
 971   (* ---------------------------------- *)
 972
 973   PROCEDURE ResetExprSeq*(VAR seq : ExprSeq);
 974   BEGIN
 975     seq.tide := 0;
 976     IF seq.a = NIL THEN InitExprSeq(seq, 2) END;
 977   END ResetExprSeq;
 978
 979   (* ---------------------------------- *)
 980
 981   PROCEDURE (VAR seq : ExprSeq)ResetTo*(newTide : INTEGER),NEW;
 982   BEGIN
 983     ASSERT(newTide <= seq.tide);
 984     seq.tide := newTide;
 985   END ResetTo;
 986
 987   (* ---------------------------------- *)
 988
 989   PROCEDURE AppendExpr*(VAR seq : ExprSeq; elem : Expr);
 990     VAR temp : POINTER TO ARRAY OF Expr;
 991         i    : INTEGER;
 992   BEGIN
 993     IF seq.a = NIL THEN
 994       InitExprSeq(seq, 2);
 995     ELSIF seq.tide > seq.high THEN (* must expand *)
 996       temp := seq.a;
 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;
1000     END;
1001     seq.a[seq.tide] := elem; INC(seq.tide);
1002   END AppendExpr;
1003
1004 (* -------------------------------------------- *)
1005
1006   PROCEDURE InitStmtSeq*(VAR seq : StmtSeq; capacity : INTEGER);
1007   BEGIN
1008     NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
1009   END InitStmtSeq;
1010
1011   PROCEDURE AppendStmt*(VAR seq : StmtSeq; elem : Stmt);
1012     VAR temp : POINTER TO ARRAY OF Stmt;
1013         i    : INTEGER;
1014   BEGIN
1015     IF seq.a = NIL THEN
1016       InitStmtSeq(seq, 2);
1017     ELSIF seq.tide > seq.high THEN (* must expand *)
1018       temp := seq.a;
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;
1022     END;
1023     seq.a[seq.tide] := elem; INC(seq.tide);
1024   END AppendStmt;
1025
1026 (* ============================================================ *)
1027
1028   PROCEDURE (p : Expr)NoteCall*(s : Scope),NEW,EMPTY;
1029
1030 (* ============================================================ *)
1031
1032   PROCEDURE (p : Expr)enterGuard*(tmp : Idnt) : Idnt,NEW,EXTENSIBLE;
1033   BEGIN RETURN NIL END enterGuard;
1034
1035 (* -------------------------------------------- *)
1036
1037   PROCEDURE (p : Expr)ExitGuard*(sav : Idnt; tmp : Idnt),NEW,EXTENSIBLE;
1038   BEGIN END ExitGuard;
1039
1040 (* -------------------------------------------- *)
1041
1042   PROCEDURE (p : Expr)checkLive*(s : Scope;
1043                                  l : V.VarSet) : V.VarSet,NEW,EXTENSIBLE;
1044   BEGIN RETURN l END checkLive;
1045
1046 (* -------------------------------------------- *)
1047
1048   PROCEDURE (p : Expr)assignLive*(s : Scope;
1049                                   l : V.VarSet) : V.VarSet,NEW,EXTENSIBLE;
1050   BEGIN RETURN p.checkLive(s,l) END assignLive;
1051
1052 (* -------------------------------------------- *)
1053
1054   PROCEDURE (p : Expr)BoolLive*(scpe : Scope;
1055                                 lvIn : V.VarSet;
1056                             OUT tSet : V.VarSet;
1057                             OUT fSet : V.VarSet),NEW,EXTENSIBLE;
1058   BEGIN
1059     tSet := p.checkLive(scpe, lvIn);
1060     fSet := tSet;
1061   END BoolLive;
1062
1063 (* ============================================================ *)
1064 (*    Set methods for the read-only fields                      *)
1065 (* ============================================================ *)
1066
1067   PROCEDURE (s : Idnt)SetMode*(m : INTEGER),NEW;
1068   BEGIN s.vMod := m END SetMode;
1069
1070 (* -------------------------------------------- *)
1071
1072   PROCEDURE (s : Idnt)SetKind*(m : INTEGER),NEW;
1073   BEGIN s.kind := m END SetKind;
1074
1075 (* -------------------------------------------- *)
1076
1077   PROCEDURE (s : Type)SetKind*(m : INTEGER),NEW;
1078   (** set the "kind" field AND allocate a serial#. *)
1079   BEGIN
1080     s.kind := m;
1081     IF m # standard THEN s.serial := next; INC(next) END;
1082   END SetKind;
1083
1084 (* -------------------------------------------- *)
1085
1086   PROCEDURE (s : Expr)SetKind*(m : INTEGER),NEW;
1087   BEGIN s.kind := m END SetKind;
1088
1089 (* -------------------------------------------- *)
1090
1091   PROCEDURE (s : Stmt)SetKind*(m : INTEGER),NEW;
1092   BEGIN s.kind := m END SetKind;
1093
1094 (* ============================================================ *)
1095 (*  Abstract method of the SymForAll visitor base type          *)
1096 (* ============================================================ *)
1097
1098   PROCEDURE (s : SymForAll)Op*(id : Idnt),NEW,ABSTRACT;
1099
1100 (* ============================================================ *)
1101 (*  Name-fetch methods for type-name diagnostic strings         *)
1102 (* ============================================================ *)
1103
1104   PROCEDURE (g : NameFetch)Of*(id : Idnt; OUT s : ARRAY OF CHAR),NEW;
1105     VAR chO : L.CharOpen;
1106   BEGIN
1107     chO := NameHash.charOpenOfHash(id.hash);
1108     IF chO = NIL THEN s := "<NIL>" ELSE GPText.Assign(chO^,s) END;
1109   END Of;
1110
1111 (* -------------------------------------------- *)
1112
1113   PROCEDURE (g : NameFetch)ChPtr*(id : Idnt) : L.CharOpen,NEW;
1114   BEGIN
1115     RETURN NameHash.charOpenOfHash(id.hash);
1116   END ChPtr;
1117
1118   PROCEDURE (g : NameFetch)NtStr*(id : Idnt) : RTS.NativeString,NEW;
1119   BEGIN
1120     IF g.ChPtr(id) = NIL THEN RETURN NIL;
1121         ELSE RETURN MKSTR(g.ChPtr(id)^);
1122         END;
1123   END NtStr;
1124
1125 (* ============================================================ *)
1126 (*  Private methods of the symbol-table info-blocks             *)
1127 (* ============================================================ *)
1128
1129   PROCEDURE mkSymInfo(h : INTEGER; d : Idnt) : SymInfo;
1130     VAR rtrn : SymInfo;
1131   BEGIN
1132     NEW(rtrn); rtrn.key := h; rtrn.val := d; RETURN rtrn;
1133   END mkSymInfo;
1134
1135 (* -------------------------------------------- *)
1136
1137   PROCEDURE (i : SymInfo)enter(h : INTEGER; d : Idnt) : BOOLEAN,NEW;
1138   BEGIN
1139     IF h < i.key THEN
1140       IF i.lOp = NIL THEN i.lOp := mkSymInfo(h,d); RETURN TRUE;
1141       ELSE RETURN i.lOp.enter(h,d);
1142       END;
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);
1146       END;
1147     ELSE (* h must equal i.key *) RETURN FALSE;
1148     END;
1149   END enter;
1150
1151 (* -------------------------------------------- *)
1152
1153   PROCEDURE (i : SymInfo)rmLeaf(h : INTEGER) : SymInfo,NEW;
1154   BEGIN
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;
1158     END;
1159     RETURN i;
1160   END rmLeaf;
1161
1162 (* -------------------------------------------- *)
1163
1164   PROCEDURE (i : SymInfo)write(h : INTEGER; d : Idnt) : SymInfo,NEW;
1165     VAR rtrn : SymInfo;
1166   BEGIN
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);
1170     ELSE  rtrn.val := d;
1171     END;
1172     RETURN rtrn;
1173   END write;
1174
1175 (* -------------------------------------------- *)
1176
1177   PROCEDURE (i : SymInfo)lookup(h : INTEGER) : Idnt,NEW;
1178   BEGIN
1179     IF h < i.key THEN
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 *)
1184       RETURN i.val;
1185     END;
1186   END lookup;
1187
1188 (* -------------------------------------------- *)
1189
1190   PROCEDURE (i : SymInfo)Apply(s : SymForAll),NEW;
1191   BEGIN
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 *)
1195   END Apply;
1196
1197 (* ============================================================ *)
1198 (*      Public methods of the symbol-table type                 *)
1199 (* ============================================================ *)
1200
1201   PROCEDURE (IN s : SymbolTable)isEmpty*() : BOOLEAN,NEW;
1202   BEGIN RETURN s.root = NIL END isEmpty;
1203
1204 (* -------------------------------------------- *)
1205
1206   PROCEDURE (VAR s : SymbolTable)enter*(hsh : INTEGER; id : Idnt) : BOOLEAN,NEW;
1207   (* Enter value in SymbolTable; Return value signals successful insertion. *)
1208   BEGIN
1209     IF s.root = NIL THEN
1210       s.root := mkSymInfo(hsh,id); RETURN TRUE;
1211     ELSE
1212       RETURN s.root.enter(hsh,id);
1213     END;
1214   END enter;
1215
1216 (* -------------------------------------------- *)
1217
1218   PROCEDURE (VAR s : SymbolTable)Overwrite*(hsh : INTEGER; id : Idnt),NEW;
1219   (* Overwrite value in SymbolTable; value must be present. *)
1220   BEGIN
1221     s.root := s.root.write(hsh,id);
1222   END Overwrite;
1223
1224 (* -------------------------------------------- *)
1225
1226   PROCEDURE (VAR s : SymbolTable)RemoveLeaf*(hsh : INTEGER),NEW;
1227   (* Remove value in SymbolTable; value must be a leaf. *)
1228   BEGIN
1229     s.root := s.root.rmLeaf(hsh);
1230   END RemoveLeaf;
1231
1232 (* -------------------------------------------- *)
1233
1234   PROCEDURE (IN s : SymbolTable)lookup*(h : INTEGER) : Idnt,NEW;
1235   (* Find value in symbol table, else return NIL. *)
1236   BEGIN
1237     IF s.root = NIL THEN RETURN NIL ELSE RETURN s.root.lookup(h) END;
1238   END lookup;
1239
1240 (* -------------------------------------------- *)
1241
1242   PROCEDURE (IN tab : SymbolTable)Apply*(sfa : SymForAll),NEW;
1243   (* Apply sfa.Op() to each entry in the symbol table. *)
1244   BEGIN
1245     IF tab.root # NIL THEN tab.root.Apply(sfa) END;
1246   END Apply;
1247
1248 (* ============================================================ *)
1249 (*      Public static methods on symbol-tables                  *)
1250 (* ============================================================ *)
1251
1252   PROCEDURE refused*(id : Idnt; scp : Scope) : BOOLEAN;
1253     VAR fail  : BOOLEAN;
1254         clash : Idnt;
1255   BEGIN
1256     fail := ~scp.symTb.enter(id.hash, id);
1257     IF fail THEN
1258       clash := scp.symTb.lookup(id.hash);
1259       IF clash.isImport() & clash.isWeak() THEN
1260         scp.symTb.Overwrite(id.hash, id); fail := FALSE;
1261       END;
1262     END;
1263     RETURN fail;
1264   END refused;
1265
1266 (* -------------------------------------------- *)
1267
1268   PROCEDURE bindLocal*(hash : INTEGER; scp : Scope) : Idnt;
1269   BEGIN
1270     RETURN scp.symTb.lookup(hash);
1271   END bindLocal;
1272
1273 (* -------------------------------------------- *)
1274
1275   PROCEDURE bind*(hash : INTEGER; scp : Scope) : Idnt;
1276     VAR resId : Idnt;
1277   BEGIN
1278     resId := scp.symTb.lookup(hash);
1279     IF resId = NIL THEN
1280       scp := scp.dfScp;
1281       WHILE (resId = NIL) & (scp # NIL) DO
1282         resId := scp.symTb.lookup(hash);
1283         scp := scp.dfScp;
1284       END;
1285     END;
1286     RETURN resId;
1287   END bind;
1288
1289 (* -------------------------------------------- *)
1290
1291   PROCEDURE maxMode*(i,j : INTEGER) : INTEGER;
1292   BEGIN
1293     IF    (i = pubMode) OR (j = pubMode) THEN RETURN pubMode;
1294     ELSIF (i = rdoMode) OR (j = rdoMode) THEN RETURN rdoMode;
1295     ELSE RETURN prvMode;
1296     END;
1297   END maxMode;
1298
1299 (* ============================================================ *)
1300 (*        Various diagnostic methods                            *)
1301 (* ============================================================ *)
1302
1303   PROCEDURE (IN tab : SymbolTable)Dump*(i : INTEGER),NEW;
1304     VAR sfa : SymTabDump;
1305   BEGIN
1306     H.Indent(i);
1307     Console.WriteString("+-------- Symtab dump ---------"); Console.WriteLn;
1308     NEW(sfa);
1309     sfa.indent := i;
1310     tab.Apply(sfa);
1311     H.Indent(i);
1312     Console.WriteString("+-------- dump ended ----------"); Console.WriteLn;
1313   END Dump;
1314
1315 (* -------------------------------------------- *)
1316
1317   PROCEDURE (id : Idnt)IdError*(n : INTEGER),NEW;
1318     VAR l,c : INTEGER;
1319   BEGIN
1320     IF id.token # NIL THEN l := id.token.lin; c := id.token.col;
1321     ELSE l := S.line; c := S.col;
1322     END;
1323     S.SemError.Report(n, l, c);
1324   END IdError;
1325
1326 (* -------------------------------------------- *)
1327
1328   PROCEDURE (id : Idnt)IdErrorStr*(n : INTEGER;
1329                                 IN s : ARRAY OF CHAR),NEW;
1330     VAR l,c : INTEGER;
1331   BEGIN
1332     IF id.token # NIL THEN l := id.token.lin; c := id.token.col;
1333     ELSE l := S.line; c := S.col;
1334     END;
1335     S.SemError.RepSt1(n,s,l,c);
1336   END IdErrorStr;
1337
1338 (* -------------------------------------------- *)
1339
1340   PROCEDURE (ty : Type)TypeError*(n : INTEGER),NEW,EXTENSIBLE;
1341     VAR l,c : INTEGER;
1342   BEGIN
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;
1346     END;
1347     S.SemError.Report(n,l,c);
1348   END TypeError;
1349
1350 (* -------------------------------------------- *)
1351
1352   PROCEDURE (ty : Type)TypeErrStr*(n : INTEGER;
1353                                 IN s : ARRAY OF CHAR),NEW,EXTENSIBLE;
1354     VAR l,c : INTEGER;
1355   BEGIN
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;
1359     END;
1360     S.SemError.RepSt1(n,s,l,c);
1361   END TypeErrStr;
1362
1363 (* -------------------------------------------- *)
1364
1365   PROCEDURE (xp : Expr)ExprError*(n : INTEGER),NEW;
1366     VAR l,c : INTEGER;
1367   BEGIN
1368     IF xp.token # NIL THEN l := xp.token.lin; c := xp.token.col;
1369     ELSE l := S.line; c := S.col;
1370     END;
1371     S.SemError.Report(n,l,c);
1372   END ExprError;
1373
1374 (* -------------------------------------------- *)
1375
1376   PROCEDURE (st : Stmt)StmtError*(n : INTEGER),NEW;
1377     VAR l,c : INTEGER;
1378   BEGIN
1379     IF st.token # NIL THEN l := st.token.lin; c := st.token.col;
1380     ELSE l := S.line; c := S.col;
1381     END;
1382     S.SemError.Report(n,l,c);
1383   END StmtError;
1384
1385 (* -------------------------------------------- *)
1386
1387   PROCEDURE (id : Idnt)name*() : L.CharOpen, NEW;
1388   BEGIN
1389     RETURN NameHash.charOpenOfHash(id.hash);
1390   END name;
1391
1392   PROCEDURE (t : Idnt)WriteName*(),NEW;
1393     VAR name : FileNames.NameString;
1394   BEGIN
1395     getName.Of(t, name);
1396     Console.WriteString(name$);
1397   END WriteName;
1398
1399 (* -------------------------------------------- *)
1400
1401   PROCEDURE DoXName*(i : INTEGER; s : L.CharOpen);
1402   BEGIN
1403     H.Indent(i);
1404     Console.WriteString("name = ");
1405     IF s # NIL THEN Console.WriteString(s) ELSE
1406                                         Console.WriteString("<nil>") END;
1407     Console.WriteLn;
1408   END DoXName;
1409
1410 (* -------------------------------------------- *)
1411
1412   PROCEDURE (t : Idnt)SuperDiag*(i : INTEGER),NEW;
1413     VAR dump : INTEGER;
1414   BEGIN
1415     dump := 0;
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");
1423     ELSE
1424       dump := t.type.dump;
1425       Console.WriteString(t.type.name());
1426     END;
1427     IF dump # 0 THEN
1428       Console.WriteString(") t$");
1429       Console.WriteInt(dump, 1);
1430     ELSE
1431       Console.Write(")");
1432     END;
1433     Console.Write("#"); Console.WriteInt(t.hash,1);
1434     Console.WriteLn;
1435   END SuperDiag;
1436
1437 (* -------------------------------------------- *)
1438
1439   PROCEDURE (t : Type)SuperDiag*(i : INTEGER),NEW;
1440   BEGIN
1441     (* H.Class("Type",t,i); *)
1442     H.Indent(i); Console.WriteString("Type: ");
1443     Console.WriteString(t.name());
1444     IF t.dump # 0 THEN
1445       Console.WriteString(" t$");
1446       Console.WriteInt(t.dump, 1);
1447       Console.Write(",");
1448     END;
1449     Console.WriteString(" s#");
1450     Console.WriteInt(t.serial, 1);
1451     Console.WriteLn;
1452   END SuperDiag;
1453
1454 (* -------------------------------------------- *)
1455
1456   PROCEDURE (t : Expr)SuperDiag*(i : INTEGER),NEW;
1457   BEGIN
1458     H.Class("Expr",t,i);
1459   END SuperDiag;
1460
1461 (* -------------------------------------------- *)
1462
1463   PROCEDURE (t : Stmt)SuperDiag*(i : INTEGER),NEW;
1464   BEGIN
1465     H.Class("Stmt",t,i);
1466     IF t.token # NIL THEN
1467       H.Indent(i);
1468       Console.WriteString("(lin:col ");
1469       Console.WriteInt(t.token.lin, 1); Console.Write(":");
1470       Console.WriteInt(t.token.col, 1); Console.Write(")");
1471       Console.WriteLn;
1472     END;
1473   END SuperDiag;
1474
1475 (* -------------------------------------------- *)
1476
1477   PROCEDURE (s : SymTabDump)Op*(id : Idnt);
1478   BEGIN
1479     id.Diagnose(s.indent);
1480   END Op;
1481
1482 (* -------------------------------------------- *)
1483
1484   PROCEDURE (s : Type)DiagFormalType*(i : INTEGER),NEW,EMPTY;
1485
1486 (* -------------------------------------------- *)
1487
1488   PROCEDURE (x : Expr)DiagSrcLoc*(),NEW;
1489   BEGIN
1490     IF x.token # NIL THEN
1491       Console.WriteString("Expr at ");
1492       Console.WriteInt(x.token.lin,1);
1493       Console.Write(":");
1494       Console.WriteInt(x.token.col,1);
1495     ELSE
1496       Console.WriteString("no src token");
1497     END;
1498     Console.WriteLn;
1499   END DiagSrcLoc;
1500
1501 (* -------------------------------------------- *)
1502
1503   PROCEDURE newNameDump() : NameDump;
1504     VAR dump : NameDump;
1505   BEGIN
1506     NEW(dump);
1507     NEW(dump.a, 32);
1508     dump.high := 31;
1509     dump.tide := 0;
1510     RETURN dump;
1511   END newNameDump;
1512
1513  (* --------------------------- *)
1514
1515   PROCEDURE (sfa : NameDump)Op*(id : Idnt);
1516     VAR name : L.CharOpen;
1517         temp : L.CharOpen;
1518         indx : INTEGER;
1519         newH : INTEGER;
1520         char : CHAR;
1521   BEGIN
1522     name := NameHash.charOpenOfHash(id.hash);
1523 (*
1524  *  IF sfa.tide + LEN(name) >= sfa.tide THEN         OOPS!
1525  *)
1526     IF sfa.tide + LEN(name) >= sfa.high THEN
1527       temp := sfa.a;
1528       newH := sfa.high + 3 * LEN(name);
1529       NEW(sfa.a, newH+1);
1530       FOR indx := 0 TO sfa.tide - 1 DO
1531         sfa.a[indx] := temp[indx];
1532       END;
1533       sfa.high := newH;
1534     END;
1535     IF sfa.tide > 0 THEN
1536       sfa.a[sfa.tide-1] := ",";
1537       sfa.a[sfa.tide  ] := " ";
1538       INC(sfa.tide);
1539     END;
1540     indx := 0;
1541     REPEAT
1542       char := name[indx];
1543       sfa.a[sfa.tide] := char;
1544       INC(sfa.tide);
1545       INC(indx);
1546     UNTIL char = 0X;
1547   END Op;
1548
1549  (* --------------------------- *)
1550
1551   PROCEDURE dumpList*(s : SymbolTable) : L.CharOpen;
1552     VAR sfa : NameDump;
1553   BEGIN
1554     sfa := newNameDump();
1555     s.Apply(sfa);
1556     RETURN sfa.a;
1557   END dumpList;
1558
1559 (* ============================================================ *)
1560 BEGIN (* ====================================================== *)
1561   NEW(getName);
1562   modMrk      := " *-!";
1563   modStr[val] := "";
1564   modStr[in ] := "IN ";
1565   modStr[out] := "OUT ";
1566   modStr[var] := "VAR ";
1567 END Symbols.  (* ============================================== *)
1568 (* ============================================================ *)
1569