gpcp/StatDesc.cp

   1 (* ==================================================================== *)
   2 (*                                                                      *)
   3 (*  StatDesc Module for the Gardens Point Component Pascal Compiler.    *)
   4 (*  Implements statement descriptors that are extensions of             *)
   5 (*  Symbols.Stmt                                                        *)
   6 (*                                                                      *)
   7 (*  Copyright (c) John Gough 1999, 2000.                                *)
   8 (*                                                                      *)
   9 (* ==================================================================== *)
  10 (* Empty Assign Return Block ProcCall ForLoop Choice ExitSt TestLoop CaseSt *)
  11 (* ==================================================================== *)
  12
  13 MODULE StatDesc;
  14
  15   IMPORT
  16         GPCPcopyright,
  17         GPText,
  18         Console,
  19         FileNames,
  20         LitValue,
  21         B := Builtin,
  22         V := VarSets,
  23         S := CPascalS,
  24         D := Symbols ,
  25         I := IdDesc  ,
  26         T := TypeDesc,
  27         E := ExprDesc,
  28         G := CompState,
  29         H := DiagHelper;
  30
  31 (* ============================================================ *)
  32
  33   CONST (* stmt-kinds *)
  34     emptyS* = 0;  assignS* = 1; procCall* = 2;  ifStat*  = 3;
  35     caseS*  = 4;  whileS*  = 5; repeatS*  = 6;  forStat* = 7;
  36     loopS*  = 8;  withS*   = 9; exitS*    = 10; returnS* = 11;
  37     blockS* = 12;
  38
  39 (* ============================================================ *)
  40
  41   CONST (* case statement density *)
  42     DENSITY = 0.7;
  43
  44
  45 (* ============================================================ *)
  46
  47   TYPE
  48     Empty*  = POINTER TO RECORD (D.Stmt)
  49              (* ----------------------------------------- *
  50               * kind-  : INTEGER; (* tag for unions *)
  51               * token* : S.Token; (* stmt first tok *)
  52               * ----------------------------------------- *)
  53               END;
  54
  55 (* ============================================================ *)
  56
  57   TYPE
  58     Return* = POINTER TO RECORD (D.Stmt)
  59              (* ----------------------------------------- *
  60               * kind-  : INTEGER; (* tag for unions *)
  61               * token* : S.Token; (* stmt first tok *)
  62               * ----------------------------------------- *)
  63                 retX*  : D.Expr;  (* NIL ==> void   *)
  64                 prId*  : D.Scope; (* Parent Ident   *)
  65               END;
  66
  67 (* ============================================================ *)
  68
  69   TYPE
  70     Block* = POINTER TO RECORD (D.Stmt)
  71              (* ----------------------------------------- *
  72               * kind-  : INTEGER; (* tag for unions *)
  73               * token* : S.Token; (* stmt first tok *)
  74               * ----------------------------------------- *)
  75                 sequ*  : D.StmtSeq;
  76               END;
  77
  78 (* ============================================================ *)
  79
  80   TYPE
  81     Assign* = POINTER TO RECORD (D.Stmt)
  82              (* ----------------------------------------- *
  83               * kind-  : INTEGER; (* tag for unions *)
  84               * token* : S.Token; (* stmt first tok *)
  85               * ----------------------------------------- *)
  86                 lhsX*  : D.Expr;
  87                 rhsX*  : D.Expr;
  88               END;
  89
  90 (* ============================================================ *)
  91
  92   TYPE
  93     ProcCall* = POINTER TO RECORD (D.Stmt)
  94                (* ----------------------------------------- *
  95                 * kind-  : INTEGER; (* tag for unions *)
  96                 * token* : S.Token; (* stmt first tok *)
  97                 * ----------------------------------------- *)
  98                   expr*  : D.Expr;
  99                 END;
 100
 101 (* ============================================================ *)
 102
 103   TYPE
 104     ForLoop* = POINTER TO RECORD (D.Stmt)
 105               (* ----------------------------------------- *
 106                * kind-  : INTEGER; (* tag for unions *)
 107                * token* : S.Token; (* stmt first tok *)
 108                * ----------------------------------------- *)
 109                  cVar*  : D.Idnt;  (* c'trl variable *)
 110                  loXp*  : D.Expr;  (* low limit expr *)
 111                  hiXp*  : D.Expr;  (* high limit exp *)
 112                  byXp*  : D.Expr;  (* must be numLt  *)
 113                  body*  : D.Stmt;  (* possibly block *)
 114                END;
 115
 116 (* ============================================================ *)
 117
 118   TYPE
 119     Choice* = POINTER TO RECORD (D.Stmt)
 120              (* ----------------------------------------- *
 121               * kind-  : INTEGER; (* tag for unions *)
 122               * token* : S.Token; (* stmt first tok *)
 123               * ----------------------------------------- *
 124               *  This descriptor is used for IF and WITH. *
 125               *  In the case of IF each predicate in the  *
 126               *  sequence has a boolean type, and the     *
 127               *  "predicate" corresponding to else is NIL *
 128               *  For the WITH statement, each predicate   *
 129               *  syntactically denoted as <id> ":" <tp>   *
 130               *  is represented by an IS binary nodetype. *
 131               * ----------------------------------------- *)
 132                 preds*  : D.ExprSeq;  (* else test NIL  *)
 133                 blocks* : D.StmtSeq;  (* stmt choices   *)
 134                 temps*  : D.IdSeq;    (* with tempvars  *)
 135               END;
 136
 137 (* ============================================================ *)
 138
 139   TYPE
 140     ExitSt* = POINTER TO RECORD (D.Stmt)
 141              (* ----------------------------------------- *
 142               * kind-  : INTEGER; (* tag for unions *)
 143               * token* : S.Token; (* stmt first tok *)
 144               * ----------------------------------------- *)
 145                 loop*  : TestLoop;  (* enclosing loop *)
 146               END;
 147
 148 (* ============================================================ *)
 149
 150   TYPE
 151     TestLoop* = POINTER TO RECORD (D.Stmt)
 152                (* ----------------------------------------- *
 153                 * kind-  : INTEGER; (* tag for unions *)
 154                 * token* : S.Token; (* stmt first tok *)
 155                 * ----------------------------------------- *
 156                 *  This descriptor is used for WHILE and    *
 157                 *  REPEAT loops.  These are distinguished   *
 158                 *  by the different tag values in v.kind    *
 159                 *  LOOPs use the structure with a NIL test  *
 160                 * ----------------------------------------- *)
 161                   test*  : D.Expr;  (* the loop test  *)
 162                   body*  : D.Stmt;  (* possibly block *)
 163                   label* : INTEGER; (* readonly field *)
 164                   tgLbl* : ANYPTR;
 165                   merge  : V.VarSet;
 166                 END;
 167
 168 (* ============================================================ *)
 169
 170   TYPE
 171     Triple* = POINTER TO RECORD
 172                 loC- : INTEGER;   (* low of range   *)
 173                 hiC- : INTEGER;   (* high of range  *)
 174                 ord- : INTEGER;   (* case block ord *)
 175               END;
 176
 177   (* ---------------------------------- *)
 178
 179   TYPE
 180     TripleSeq* = RECORD
 181                    tide- : INTEGER;
 182                    high : INTEGER;
 183                    a- : POINTER TO ARRAY OF Triple;
 184                  END;
 185
 186   (* ---------------------------------- *)
 187
 188   TYPE
 189     CaseSt* = POINTER TO RECORD (D.Stmt)
 190              (* ----------------------------------------- *
 191               * kind-  : INTEGER; (* tag for unions *)
 192               * token* : S.Token; (* stmt first tok *)
 193               * ----------------------------------------- *)
 194                 select* : D.Expr; (* case selector  *)
 195                 chrSel* : BOOLEAN;  (* ==> use chars  *)
 196                 blocks* : D.StmtSeq;  (* case bodies    *)
 197                 elsBlk* : D.Stmt; (* elseCase | NIL *)
 198                 labels* : TripleSeq;  (* label seqence  *)
 199                 groups- : TripleSeq;  (* dense groups   *)
 200               END;
 201   (* ---------------------------------------------------------- *
 202    *  Notes on the semantics of this structure. "blocks" holds  *
 203    *  an ordered list of case statement code blocks. "labels" *
 204    *  is a list of ranges, intially in textual order, with flds *
 205    *  loC, hiC and ord corresponding to the range min, max and  *
 206    *  the selected block ordinal number.  This list is later  *
 207    *  sorted on the loC value, and adjacent values merged if  *
 208    *  they select the same block.  The "groups" list of triples *
 209    *  groups ranges into dense subranges in the selector space. *
 210    *  The fields loC, hiC, and ord to hold the lower and upper  *
 211    *  indices into the labels list, and the number of non-  *
 212    *  default values in the group. Groups are guaranteed to *
 213    *  have density (nonDefN / (max-min+1)) > DENSITY    *
 214    * ---------------------------------------------------------- *)
 215
 216 (* ============================================================ *)
 217
 218   PROCEDURE newTriple*(lo,hi,ord : INTEGER) : Triple;
 219     VAR new : Triple;
 220   BEGIN
 221     NEW(new); new.loC := lo; new.hiC := hi; new.ord := ord; RETURN new;
 222   END newTriple;
 223
 224   (* ---------------------------------- *)
 225
 226   PROCEDURE InitTripleSeq*(VAR seq : TripleSeq; capacity : INTEGER);
 227   BEGIN
 228     NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
 229   END InitTripleSeq;
 230
 231   (* ---------------------------------- *)
 232
 233   PROCEDURE (VAR seq : TripleSeq)ResetTo(newTide : INTEGER),NEW;
 234   BEGIN
 235     ASSERT(newTide <= seq.tide);
 236     seq.tide := newTide;
 237   END ResetTo;
 238
 239   (* ---------------------------------- *)
 240
 241   PROCEDURE AppendTriple*(VAR seq : TripleSeq; elem : Triple);
 242     VAR temp : POINTER TO ARRAY OF Triple;
 243         i    : INTEGER;
 244   BEGIN
 245     IF seq.a = NIL THEN
 246       InitTripleSeq(seq, 8);
 247     ELSIF seq.tide > seq.high THEN (* must expand *)
 248       temp := seq.a;
 249       seq.high := seq.high * 2 + 1;
 250       NEW(seq.a, seq.high+1);
 251       FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
 252     END;
 253     seq.a[seq.tide] := elem; INC(seq.tide);
 254   END AppendTriple;
 255
 256   (* ---------------------------------- *)
 257
 258 (*
 259  *PROCEDURE (VAR seq : TripleSeq)Diagnose(IN str : ARRAY OF CHAR),NEW;
 260  *  VAR index : INTEGER;
 261  *BEGIN
 262  *  Console.WriteString("Diagnose TripleSeq " + str); Console.WriteLn;
 263  *  FOR index := 0 TO seq.tide-1 DO
 264  *    Console.WriteInt(index, 3);
 265  *    Console.WriteInt(seq.a[index].loC, 8);
 266  *    Console.WriteInt(seq.a[index].hiC, 8);
 267  *    Console.WriteInt(seq.a[index].ord, 8);
 268  *    Console.WriteLn;
 269  *  END;
 270  *END Diagnose;
 271  *)
 272
 273 (* ============================================================ *)
 274 (*            Various Statement Text-Span Constructors          *)
 275 (* ============================================================ *)
 276
 277   PROCEDURE (s : Empty)Span*() : S.Span;
 278   BEGIN
 279     RETURN NIL;
 280   END Span;
 281
 282   PROCEDURE (s : Return)Span*() : S.Span;
 283     VAR rslt : S.Span;
 284   BEGIN
 285     rslt := S.mkSpanT(s.token);
 286     IF s.retX # NIL THEN rslt := S.Merge(rslt, s.retX.tSpan) END;
 287     RETURN rslt;
 288   END Span;
 289
 290   PROCEDURE (s : Block)Span*() : S.Span;
 291   BEGIN
 292     RETURN NIL;
 293   END Span;
 294
 295   PROCEDURE (s : Assign)Span*() : S.Span;
 296   BEGIN
 297     RETURN S.Merge(s.lhsX.tSpan, s.rhsX.tSpan);
 298   END Span;
 299
 300   PROCEDURE (s : ProcCall)Span*() : S.Span;
 301   BEGIN
 302     RETURN s.expr.tSpan;
 303   END Span;
 304
 305   (*PROCEDURE (s : ProcCall)Span*() : S.Span;
 306   BEGIN
 307     RETURN s.expr.tSpan;
 308   END Span;*)
 309
 310
 311 (* ============================================================ *)
 312 (*      Various Statement Descriptor Constructors   *)
 313 (* ============================================================ *)
 314
 315   PROCEDURE newEmptyS*() : Empty;
 316     VAR new : Empty;
 317   BEGIN
 318     NEW(new); new.SetKind(emptyS);
 319     new.token := S.prevTok; RETURN new;
 320   END newEmptyS;
 321
 322   (* ---------------------------------- *)
 323
 324   PROCEDURE newBlockS*(t : S.Token) : Block;
 325     VAR new : Block;
 326   BEGIN
 327     NEW(new); new.SetKind(blockS);
 328     new.token := t; RETURN new;
 329   END newBlockS;
 330
 331   (* ---------------------------------- *)
 332
 333   PROCEDURE newReturnS*(retX : D.Expr) : Return;
 334     VAR new : Return;
 335   BEGIN
 336     NEW(new); new.token := S.prevTok;
 337     new.retX := retX; new.SetKind(returnS); RETURN new;
 338   END newReturnS;
 339
 340   (* ---------------------------------- *)
 341
 342   PROCEDURE newAssignS*() : Assign;
 343     VAR new : Assign;
 344   BEGIN
 345     NEW(new); new.SetKind(assignS);
 346     new.token := S.prevTok; RETURN new;
 347   END newAssignS;
 348
 349   (* ---------------------------------- *)
 350
 351   PROCEDURE newWhileS*() : TestLoop;
 352     VAR new : TestLoop;
 353   BEGIN
 354     NEW(new); new.SetKind(whileS);
 355     new.token := S.prevTok; RETURN new;
 356   END newWhileS;
 357
 358   (* ---------------------------------- *)
 359
 360   PROCEDURE newRepeatS*() : TestLoop;
 361     VAR new : TestLoop;
 362   BEGIN
 363     NEW(new); new.SetKind(repeatS);
 364     new.token := S.prevTok; RETURN new;
 365   END newRepeatS;
 366
 367   (* ---------------------------------- *)
 368
 369   PROCEDURE newIfStat*() : Choice;
 370     VAR new : Choice;
 371   BEGIN
 372     NEW(new); new.SetKind(ifStat);
 373     new.token := S.prevTok; RETURN new;
 374   END newIfStat;
 375
 376   (* ---------------------------------- *)
 377
 378   PROCEDURE newWithS*() : Choice;
 379     VAR new : Choice;
 380   BEGIN
 381     NEW(new); new.SetKind(withS);
 382     new.token := S.prevTok; RETURN new;
 383   END newWithS;
 384
 385   (* ---------------------------------- *)
 386
 387   PROCEDURE newForStat*() : ForLoop;
 388     VAR new : ForLoop;
 389   BEGIN
 390     NEW(new); new.SetKind(forStat);
 391     new.token := S.prevTok; RETURN new;
 392   END newForStat;
 393
 394   (* ---------------------------------- *)
 395
 396   PROCEDURE newProcCall*() : ProcCall;
 397     VAR new : ProcCall;
 398   BEGIN
 399     NEW(new); new.token := S.prevTok;
 400     new.SetKind(procCall); RETURN new;
 401   END newProcCall;
 402
 403   (* ---------------------------------- *)
 404
 405   PROCEDURE newExitS*(loop : D.Stmt) : ExitSt;
 406     VAR new : ExitSt;
 407   BEGIN
 408     NEW(new); new.token := S.prevTok;
 409     new.loop  := loop(TestLoop); new.SetKind(exitS); RETURN new;
 410   END newExitS;
 411
 412   (* ---------------------------------- *)
 413
 414   PROCEDURE newLoopS*() : TestLoop;
 415     VAR new : TestLoop;
 416   BEGIN
 417     NEW(new); new.SetKind(loopS);
 418     new.token := S.prevTok; RETURN new;
 419   END newLoopS;
 420
 421   (* ---------------------------------- *)
 422
 423   PROCEDURE newCaseS*() : CaseSt;
 424     VAR new : CaseSt;
 425   BEGIN
 426     NEW(new); new.SetKind(caseS);
 427     new.token := S.prevTok; RETURN new;
 428   END newCaseS;
 429
 430 (* ============================================================ *)
 431
 432   PROCEDURE (for : ForLoop)isSimple*() : BOOLEAN,NEW;
 433   (* A for loop is simple if it always executes at least once. *)
 434     VAR loVal : LONGINT;
 435         hiVal : LONGINT;
 436         byVal : LONGINT;
 437   BEGIN
 438     IF  (for.loXp.kind = E.numLt) &
 439         (for.hiXp.kind = E.numLt) THEN
 440       loVal := for.loXp(E.LeafX).value.long();
 441       hiVal := for.hiXp(E.LeafX).value.long();
 442       byVal := for.byXp(E.LeafX).value.long();
 443       IF byVal > 0 THEN
 444         RETURN hiVal >= loVal;
 445       ELSE
 446         RETURN hiVal <= loVal;
 447       END;
 448     ELSE
 449       RETURN FALSE;
 450     END;
 451   END isSimple;
 452
 453 (* ============================================================ *)
 454 (*          Type Erasure                                        *)
 455 (* ============================================================ *)
 456   PROCEDURE (s : Empty)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 457
 458   PROCEDURE (s : Block)TypeErase*(t : D.Scope);
 459       VAR index : INTEGER;
 460     BEGIN
 461       FOR index := 0 TO s.sequ.tide - 1 DO
 462         s.sequ.a[index].TypeErase(t);
 463       END;
 464   END TypeErase;
 465
 466   PROCEDURE (s : Assign)TypeErase*(t : D.Scope);
 467   BEGIN
 468     s.rhsX := s.rhsX.TypeErase();
 469   END TypeErase;
 470
 471   PROCEDURE (s : Return)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 472   PROCEDURE (s : ProcCall)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 473   PROCEDURE (s : ForLoop)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 474   PROCEDURE (s : Choice)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 475   PROCEDURE (s : ExitSt)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 476   PROCEDURE (s : TestLoop)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 477   PROCEDURE (s : CaseSt)TypeErase*(t : D.Scope); BEGIN END TypeErase;
 478
 479 (* ============================================================ *)
 480 (*          Statement Attribution     *)
 481 (* ============================================================ *)
 482
 483   PROCEDURE (s : Empty)StmtAttr*(scope : D.Scope);
 484   BEGIN END StmtAttr;
 485
 486   (* ---------------------------------- *)
 487
 488   PROCEDURE (s : Block)StmtAttr*(scope : D.Scope);
 489     VAR index : INTEGER;
 490   BEGIN
 491     FOR index := 0 TO s.sequ.tide - 1 DO
 492       s.sequ.a[index].StmtAttr(scope);
 493     END;
 494   END StmtAttr;
 495
 496   (* ---------------------------------- *)
 497
 498   PROCEDURE (s : Assign)StmtAttr*(scope : D.Scope);
 499     VAR lTp, rTp : D.Type;
 500         eNm : INTEGER;
 501   BEGIN
 502    (*
 503     * Assert: lhsX is a designator, it has been
 504     * attributed during parsing, and has a non-null type.
 505     *
 506     * First: attribute the right-hand-side expression.
 507     *)
 508     s.rhsX := s.rhsX.exprAttr();
 509    (*
 510     * First check: is the designator writeable.
 511     *)
 512     s.lhsX.CheckWriteable();
 513
 514     IF (s.rhsX # NIL) & (s.rhsX.type # NIL) THEN
 515       lTp := s.lhsX.type;
 516       rTp := s.rhsX.type;
 517      (*
 518       * Second check: does the expression need dereferencing.
 519       *)
 520       IF (lTp.kind = T.recTp) & (rTp.kind = T.ptrTp) THEN
 521         s.rhsX := E.mkDeref(s.rhsX);
 522         rTp := s.rhsX.type;
 523       END;
 524       IF lTp.assignCompat(s.rhsX) THEN
 525        (*
 526         * Third check: does the expression need type coercion.
 527         *)
 528         IF (rTp # lTp) & (rTp IS T.Base) THEN
 529           s.rhsX := E.coerceUp(s.rhsX, lTp);
 530           rTp := lTp;
 531         END;
 532        (*
 533         * Fourth check: are value copies allowed here.
 534         *)
 535         IF ~rTp.valCopyOK() THEN s.rhsX.ExprError(152) END;
 536         IF rTp IS T.Procedure THEN
 537           s.StmtError(301);
 538           IF G.targetIsJVM() THEN s.StmtError(320 (*213*));
 539           ELSIF (rTp # lTp) & ~s.rhsX.isProcLit() THEN s.StmtError(191);
 540           END;
 541         END;
 542       ELSE (* sort out which error to report *)
 543         IF    rTp.isOpenArrType() THEN eNm := 142;
 544         ELSIF rTp.isExtnRecType() THEN eNm := 143;
 545         ELSIF (rTp.kind = T.prcTp) &
 546               (s.rhsX.kind = E.qualId) &
 547               ~s.rhsX.isProcVar() THEN eNm := 165;
 548         ELSIF lTp.isCharArrayType() &
 549               rTp.isStringType() THEN  eNm :=  27;
 550         ELSE             eNm :=  83;
 551         END;
 552         IF eNm # 83 THEN s.rhsX.ExprError(eNm);
 553         ELSE D.RepTypesErrTok(83, lTp, rTp, s.token);
 554         END;
 555       END;
 556     END;
 557   END StmtAttr;
 558
 559   (* ---------------------------------- *)
 560
 561   PROCEDURE (s : Return)StmtAttr*(scope : D.Scope);
 562     VAR prId : I.Procs;
 563         rTyp : D.Type;
 564         xTyp : D.Type;
 565         rExp : D.Expr;
 566   BEGIN
 567     IF scope.kind = I.modId THEN
 568       s.StmtError(73);
 569     ELSE
 570       prId := scope(I.Procs);
 571       s.prId := prId;
 572       rTyp := prId.type(T.Procedure).retType;
 573       IF rTyp = NIL THEN
 574         IF s.retX # NIL THEN s.retX.ExprError(74) END;
 575       ELSE
 576         IF s.retX = NIL THEN
 577           s.StmtError(75);
 578         ELSE
 579           rExp := s.retX.exprAttr();
 580           s.retX := rExp;
 581           xTyp := rExp.type;
 582           IF rExp # NIL THEN (* fixed 28 July 2001 *)
 583             IF ~rTyp.assignCompat(rExp) THEN
 584               D.RepTypesErrTok(76, rTyp, xTyp, s.token);
 585             ELSIF rTyp # xTyp THEN
 586               IF xTyp IS T.Base THEN
 587                 rExp := E.coerceUp(rExp, rTyp);
 588                 s.retX := rExp;
 589               ELSIF rTyp IS T.Procedure THEN
 590                 rExp.type := rTyp;
 591               END;
 592             END;
 593             IF scope.kind = I.ctorP THEN
 594               WITH rExp : E.IdLeaf DO
 595                 IF rExp.ident.hash # B.selfBk THEN rExp.ExprError(225) END;
 596               ELSE rExp.ExprError(225);
 597               END;
 598             END;
 599           END;
 600         END;
 601       END;
 602     END;
 603   END StmtAttr;
 604
 605   (* ---------------------------------- *)
 606
 607   PROCEDURE (s : ProcCall)StmtAttr*(scope : D.Scope);
 608     VAR callX : E.CallX;
 609         tempX : D.Expr;
 610         idntX : E.IdentX;
 611   BEGIN
 612     callX  := s.expr(E.CallX);
 613     s.expr := E.checkCall(callX);
 614     IF (s.expr # NIL) &
 615        (callX.kid.kind = E.sprMrk) THEN E.CheckSuper(callX, scope) END;
 616   END StmtAttr;
 617
 618   (* ---------------------------------- *)
 619
 620   PROCEDURE (s : ForLoop)StmtAttr*(scope : D.Scope);
 621   BEGIN
 622     s.loXp := s.loXp.exprAttr();
 623     s.hiXp := s.hiXp.exprAttr();
 624     IF (s.loXp # NIL) & ~s.loXp.isIntExpr() THEN s.loXp.ExprError(37) END;
 625     IF (s.hiXp # NIL) & ~s.hiXp.isIntExpr() THEN s.hiXp.ExprError(37) END;
 626     s.body.StmtAttr(scope);
 627   END StmtAttr;
 628
 629   (* ---------------------------------- *)
 630
 631   PROCEDURE (s : Choice)StmtAttr*(scope : D.Scope);
 632     VAR index : INTEGER;
 633         predN : D.Expr;
 634         nextN : D.Expr;
 635         blokN : D.Stmt;
 636   BEGIN
 637     FOR index := 0 TO s.preds.tide - 1 DO
 638       predN := s.preds.a[index];
 639       blokN := s.blocks.a[index];
 640       IF predN # NIL THEN
 641         nextN := predN.exprAttr();
 642         IF nextN # NIL THEN
 643           IF nextN # predN THEN s.preds.a[index] := nextN END;
 644           IF ~nextN.isBooleanExpr() THEN predN.ExprError(36) END;
 645         END;
 646       END;
 647       IF blokN # NIL THEN blokN.StmtAttr(scope) END;
 648     END;
 649   END StmtAttr;
 650
 651   (* ---------------------------------- *)
 652
 653   PROCEDURE (s : ExitSt)StmtAttr*(scope : D.Scope);
 654   BEGIN END StmtAttr; (* nothing to do *)
 655
 656   (* ---------------------------------- *)
 657
 658   PROCEDURE (s : TestLoop)StmtAttr*(scope : D.Scope);
 659   BEGIN
 660     IF s.test # NIL THEN s.test := s.test.exprAttr() END;
 661     IF (s.test # NIL) & ~s.test.isBooleanExpr() THEN s.test.ExprError(36) END;
 662     s.body.StmtAttr(scope);
 663   END StmtAttr;
 664
 665   (* ---------------------------------- *)
 666
 667   PROCEDURE (s : CaseSt)StmtAttr*(scope : D.Scope);
 668   (* At this point the select expression has already been attributed  *)
 669   (* during parsing, and the raw case ordinals have been checked. *)
 670     VAR index : INTEGER;
 671
 672   (* ------------------------- *)
 673
 674     PROCEDURE QuickSort(VAR array : TripleSeq; min, max : INTEGER);
 675       VAR i,j : INTEGER;
 676           key : INTEGER;
 677           tmp : Triple;
 678     BEGIN
 679       i := min; j := max;
 680       key := array.a[(min+max) DIV 2].loC;
 681       REPEAT
 682         WHILE array.a[i].loC < key DO INC(i) END;
 683         WHILE array.a[j].loC > key DO DEC(j) END;
 684         IF i <= j THEN
 685           tmp := array.a[i]; array.a[i] := array.a[j]; array.a[j] := tmp;
 686           INC(i); DEC(j);
 687         END;
 688       UNTIL i > j;
 689       IF min < j THEN QuickSort(array, min,j) END;
 690       IF i < max THEN QuickSort(array, i,max) END;
 691     END QuickSort;
 692
 693   (* ------------------------- *)
 694
 695     PROCEDURE DoErr89(cs : CaseSt; ix,mx : INTEGER);
 696       VAR n1, n2 : ARRAY 32 OF CHAR;
 697           lo, hi : INTEGER;
 698           o1, o2 : INTEGER;
 699           tr     : Triple;
 700           s1,s2  : D.Stmt;
 701     BEGIN
 702       tr := cs.labels.a[ix];
 703       lo := tr.loC; hi := tr.hiC; o1 := tr.ord;
 704       (* overlap is from "lo" to MIN(mx, hi) ... *)
 705       hi := MIN(hi, mx);
 706       GPText.IntToStr(lo, n1);
 707       IF lo # hi THEN (* range overlap *)
 708         GPText.IntToStr(hi, n2);
 709         n1 := n1 + " .. " + n2;
 710       END;
 711       o2 := cs.labels.a[ix-1].ord;
 712      (*
 713       *  We want to place a full diagnostic on the earlier
 714       *  of the two cases, if there are two. Place a simple
 715       *  diagnostic on the second of the two cases.
 716       *)
 717       s1 := cs.blocks.a[o1];
 718       s2 := cs.blocks.a[o2];
 719       IF o1 < o2 THEN
 720         S.SemError.RepSt1(89, n1, s1.token.lin, s1.token.col);
 721         S.SemError.Report(89, s2.token.lin, s2.token.col);
 722       ELSIF o1 > o2 THEN
 723         S.SemError.RepSt1(89, n1, s2.token.lin, s2.token.col);
 724         S.SemError.Report(89, s1.token.lin, s1.token.col);
 725       ELSE  (* list once only *)
 726         S.SemError.RepSt1(89, n1, s1.token.lin, s1.token.col);
 727       END;
 728     END DoErr89;
 729
 730   (* ------------------------- *)
 731
 732     PROCEDURE Compact(cs : CaseSt);
 733       VAR index : INTEGER;    (* read index on sequence *)
 734           write : INTEGER;    (* write index on new seq *)
 735           nextI : INTEGER;    (* adjacent selector val  *)
 736           crOrd : INTEGER;    (* current case ordinal   *)
 737           thisT : Triple;
 738     BEGIN
 739       write := -1;
 740       nextI := MIN(INTEGER);
 741       crOrd := MIN(INTEGER);
 742       FOR index := 0 TO cs.labels.tide - 1 DO
 743         thisT := cs.labels.a[index];
 744         (* test for overlaps ! *)
 745         IF thisT.loC < nextI THEN DoErr89(cs, index, nextI-1) END;
 746         IF (thisT.loC = nextI) & (thisT.ord = crOrd) THEN (* merge *)
 747           cs.labels.a[write].hiC := thisT.hiC;
 748         ELSE
 749           INC(write);
 750           crOrd := thisT.ord;
 751           cs.labels.a[write].loC := thisT.loC;
 752           cs.labels.a[write].hiC := thisT.hiC;
 753           cs.labels.a[write].ord := thisT.ord;
 754         END;
 755         nextI := thisT.hiC + 1;
 756       END;
 757       cs.labels.ResetTo(write+1);
 758     END Compact;
 759
 760   (* ------------------------- *)
 761
 762     PROCEDURE FindGroups(cs : CaseSt);
 763       VAR index : INTEGER;    (* read index on sequence *)
 764           sm,sM : INTEGER;    (* group min/Max selector *)
 765           nextN : INTEGER;    (* updated group ordNum.  *)
 766           dense : BOOLEAN;
 767           crGrp : Triple;   (* current group triple   *)
 768           crRng : Triple;   (* triple to cond. add on *)
 769           p1Grp : TripleSeq;    (* temporary sequence.    *)
 770     BEGIN
 771    (* IF G.verbose THEN cs.labels.Diagnose("selector labels") END; *)
 772      (*
 773       *  Perform the backward pass, merging dense groups.
 774       *  Indices are between cs.labels.tide-1 and 0.
 775       *)
 776       index := cs.labels.tide-1; dense := FALSE; crGrp := NIL;
 777       WHILE (index >= 0) & ~dense  DO
 778        (* Invariant: all ranges with index > "index" have been  *
 779         * grouped and appended to the first pass list p1Grp.  *)
 780         dense := TRUE;
 781         crRng := cs.labels.a[index];
 782         sM := crRng.hiC;
 783         crGrp := newTriple(index, index, sM - crRng.loC + 1);
 784         WHILE (index > 0) & dense DO
 785          (* Invariant: crGrp groups info on all ranges with   *
 786           * index >= "index" not already appended to tempGP *)
 787           DEC(index);
 788           crRng := cs.labels.a[index];
 789           nextN := crGrp.ord + crRng.hiC -crRng.loC + 1;
 790           IF nextN / (sM - crRng.loC + 1) > DENSITY THEN
 791             crGrp.loC := index; crGrp.ord := nextN; (* add to crGrp *)
 792           ELSE
 793             AppendTriple(p1Grp, crGrp); dense := FALSE; (* append; exit *)
 794           END;
 795         END;
 796       END;
 797       IF dense THEN AppendTriple(p1Grp, crGrp) END;
 798    (* IF G.verbose THEN p1Grp.Diagnose("first pass groups") END; *)
 799      (*
 800       *  Perform the forward pass, merging dense groups.
 801       *  Indices are between 0 and p1Grp.tide-1.
 802       *  Note the implicit list reversal here.
 803       *)
 804       index := p1Grp.tide-1; dense := FALSE;
 805       WHILE (index >= 0) & ~dense DO
 806        (* Invariant: all groups with index > "index" have been  *
 807         * grouped and appended to the final list cs.groups. *)
 808         dense := TRUE;
 809         crGrp := p1Grp.a[index];
 810         sm := cs.labels.a[crGrp.loC].loC;
 811         WHILE (index > 0) & dense DO
 812          (* Invariant: crGrp contains info on all groups with   *
 813           * index >= "index" not already appended to tempGP *)
 814           DEC(index);
 815           crRng := p1Grp.a[index];
 816           sM := cs.labels.a[crRng.hiC].hiC;
 817           nextN := crGrp.ord + crRng.ord;
 818           IF nextN / (sM - sm + 1) > DENSITY THEN
 819             crGrp.hiC := crRng.hiC; crGrp.ord := nextN; (* add to crGrp *)
 820           ELSE
 821             AppendTriple(cs.groups, crGrp);     (* append; exit *)
 822             dense := FALSE;
 823           END;
 824         END;
 825       END;
 826       IF dense THEN AppendTriple(cs.groups, crGrp) END;
 827    (* IF G.verbose THEN cs.groups.Diagnose("final groups") END; *)
 828     END FindGroups;
 829
 830   (* ------------------------- *)
 831
 832   BEGIN
 833     IF s.blocks.tide = 0 THEN RETURN END; (* Empty case statement *)
 834    (*
 835     *  First: do all controlled statement attribution.
 836     *)
 837     FOR index := 0 TO s.blocks.tide - 1 DO
 838       s.blocks.a[index].StmtAttr(scope);
 839     END;
 840     IF s.elsBlk # NIL THEN s.elsBlk.StmtAttr(scope) END;
 841    (*
 842     *  Next: sort all triples on the loC value.
 843     *)
 844  (* IF G.verbose THEN s.labels.Diagnose("unsorted labels") END; *)
 845     QuickSort(s.labels, 0, s.labels.tide - 1);
 846  (* IF G.verbose THEN s.labels.Diagnose("sorted labels") END; *)
 847    (*
 848     *  Next: compact adjacent cases with same block-ord.
 849     *)
 850     Compact(s);
 851    (*
 852     *  Next: create lists of dense subranges.
 853     *)
 854     FindGroups(s);
 855   END StmtAttr;
 856
 857 (* ============================================================ *)
 858 (*  Flow attribute evaluation for all statement types *)
 859 (* ============================================================ *)
 860
 861   PROCEDURE (s : Block)flowAttr*(t : D.Scope; i : V.VarSet) : V.VarSet;
 862     VAR ix : INTEGER;
 863   BEGIN
 864     FOR ix := 0 TO s.sequ.tide-1 DO
 865       i := s.sequ.a[ix].flowAttr(t, i);
 866     END;
 867     RETURN i;
 868   END flowAttr;
 869
 870   (* ---------------------------------- *)
 871
 872   PROCEDURE (s : Assign)flowAttr*(t : D.Scope; lvIn : V.VarSet) : V.VarSet;
 873    (* Invariant: param lvIn is unchanged by this procedure *)
 874     VAR lhLv, rhLv : V.VarSet;
 875   BEGIN
 876     rhLv := s.rhsX.checkLive(t, lvIn);
 877     lhLv := s.lhsX.assignLive(t, lvIn); (* specialized for Assign | others *)
 878     RETURN lhLv.cup(rhLv);
 879   END flowAttr;
 880
 881   (* ---------------------------------- *)
 882
 883   PROCEDURE (s : Empty)flowAttr*(t : D.Scope; i : V.VarSet) : V.VarSet;
 884   BEGIN
 885     RETURN i;
 886   END flowAttr;
 887
 888   (* ---------------------------------- *)
 889
 890   PROCEDURE (s : Return)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
 891   BEGIN
 892     IF s.retX # NIL THEN live := s.retX.checkLive(t, live) END;
 893     t.type.OutCheck(live);
 894     RETURN V.newUniv(live.cardinality());
 895   END flowAttr;
 896
 897   (* ---------------------------------- *)
 898
 899   PROCEDURE (s : ProcCall)flowAttr*(t : D.Scope; i : V.VarSet) : V.VarSet;
 900   BEGIN
 901     RETURN s.expr.checkLive(t, i);
 902   END flowAttr;
 903
 904   (* ---------------------------------- *)
 905
 906   PROCEDURE (s : ForLoop)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
 907     VAR junk : V.VarSet;
 908   BEGIN
 909    (*
 910     *   The limits are evaluated in a prescribed order,
 911     *   chaining the live set. The body may or may not
 912     *   be evaluated.  [We might later test this for static
 913     *   evaluation, but might need to emit different code
 914     *   for the two cases, to keep the verifier happy.]
 915     *   [This is now done, 30-Mar-2000, (kjg)]
 916     *)
 917     live := s.loXp.checkLive(t, live);
 918     live := s.hiXp.checkLive(t, live);
 919     live := live.newCopy();
 920     live.Incl(s.cVar(I.AbVar).varOrd);
 921     junk := s.body.flowAttr(t,live);
 922     IF s.isSimple() THEN
 923      (*
 924       *   If this for loop is simple, it will be executed
 925       *   at least once.  Thus the flow-attribution consequences
 926       *   of execution will be included in live-out var-set.
 927       *)
 928       live := live.cup(junk);
 929     END;
 930     RETURN live;
 931   END flowAttr;
 932
 933   (* ---------------------------------- *)
 934
 935   PROCEDURE (s : Choice)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
 936     VAR idx : INTEGER;
 937         out : V.VarSet;
 938         tru : V.VarSet;
 939         fal : V.VarSet;
 940         pred : D.Expr;
 941         else : BOOLEAN;
 942   BEGIN
 943     out := V.newUniv(live.cardinality());
 944     tru := live;
 945     fal := live;
 946     IF s.kind = ifStat THEN
 947      (*
 948       *  In the case of IF statements there is always the possiblity
 949       *  that a predicate evaluation will have a side-effect. Thus ...
 950       *)
 951       else := FALSE;
 952       FOR idx := 0 TO s.preds.tide-1 DO
 953         pred := s.preds.a[idx];
 954         IF pred # NIL THEN
 955           pred.BoolLive(t, fal, tru, fal);
 956           out  := out.cap(s.blocks.a[idx].flowAttr(t, tru));
 957         ELSE (* must be elsepart *)
 958           else := TRUE;
 959           out  := out.cap(s.blocks.a[idx].flowAttr(t, fal));
 960         END;
 961       END;
 962      (*
 963       *   If we did not find an elsepart, then we must
 964       *   merge the result of executing the implicit "skip".
 965       *)
 966       IF ~else THEN out  := out.cap(fal) END;
 967     ELSE
 968      (*
 969       *  In the case of WITH statements there is no evaluation
 970       *  involved in the predicate test, and hence no side-effect.
 971       *)
 972       FOR idx := 0 TO s.preds.tide-1 DO
 973         pred := s.preds.a[idx];
 974         IF pred # NIL THEN
 975           tru := pred(E.BinaryX).lKid.checkLive(t, live);
 976         END;
 977         out := out.cap(s.blocks.a[idx].flowAttr(t, tru));
 978       END;
 979     END;
 980     RETURN out;
 981   END flowAttr;
 982
 983   (* ---------------------------------- *)
 984
 985   PROCEDURE (s : ExitSt)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
 986   (* Merge all exit sets into the "merge" set of the enclosing  *)
 987   (* LOOP.  Return the input live set, unchanged.   *)
 988   BEGIN
 989     s.loop.merge := live.cap(s.loop.merge);
 990     RETURN V.newUniv(live.cardinality());
 991   END flowAttr;
 992
 993   (* ---------------------------------- *)
 994
 995   PROCEDURE (s : TestLoop)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
 996     VAR tSet, fSet, junk : V.VarSet;
 997   BEGIN
 998     IF s.kind = whileS THEN
 999      (*
1000       *  For a WHILE statement, the expression is evaluated first.
1001       *)
1002       s.test.BoolLive(t, live, tSet, fSet);
1003       junk := s.body.flowAttr(t, tSet);
1004       RETURN fSet;
1005     ELSIF s.kind = repeatS THEN
1006      (*
1007       *  For a REPEAT statement, the expression is evaluated last.
1008       *)
1009       junk := s.body.flowAttr(t, live);
1010       s.test.BoolLive(t, junk, tSet, fSet);
1011       RETURN fSet;
1012     ELSE (* must be loopS *)
1013       s.merge := V.newUniv(live.cardinality());
1014       junk := s.body.flowAttr(t, live);
1015       RETURN s.merge;
1016     END;
1017     RETURN live;
1018   END flowAttr;
1019
1020   (* ---------------------------------- *)
1021
1022   PROCEDURE (s : CaseSt)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
1023     VAR lvOu : V.VarSet;
1024         indx : INTEGER;
1025         tmp : V.VarSet;
1026   BEGIN
1027     lvOu := V.newUniv(live.cardinality());
1028     live := s.select.checkLive(t, live);
1029    (*
1030     *  The live-out set of this statement is the intersection
1031     *  of the live-out of all of the components of the CASE.
1032     *  All cases receive the same input set: the result of the
1033     *  evaluation of the select expression.
1034     *)
1035     FOR indx := 0 TO s.blocks.tide-1 DO
1036       lvOu := lvOu.cap(s.blocks.a[indx].flowAttr(t, live));
1037     END;
1038    (*
1039     *  In the event that there is no ELSE case, and unlike the
1040     *  case of the IF statement, the program aborts and does
1041     *  not effect the accumulated live-out set, lvOu.
1042     *)
1043     IF s.elsBlk # NIL THEN
1044       lvOu := lvOu.cap(s.elsBlk.flowAttr(t, live));
1045     END;
1046     RETURN lvOu;
1047   END flowAttr;
1048
1049 (* ============================================================ *)
1050 (*          Diagnostic Procedures     *)
1051 (* ============================================================ *)
1052
1053   PROCEDURE WriteTag(t : D.Stmt; ind : INTEGER);
1054   BEGIN
1055     H.Indent(ind);
1056     CASE t.kind OF
1057     | emptyS   : Console.WriteString("emptyS   ");
1058     | assignS  : Console.WriteString("assignS  ");
1059     | procCall : Console.WriteString("procCall ");
1060     | ifStat   : Console.WriteString("ifStat   ");
1061     | caseS    : Console.WriteString("caseS    ");
1062     | whileS   : Console.WriteString("whileS   ");
1063     | repeatS  : Console.WriteString("repeatS  ");
1064     | forStat  : Console.WriteString("forStat  ");
1065     | loopS    : Console.WriteString("loopS    ");
1066     | withS    : Console.WriteString("withS    ");
1067     | exitS    : Console.WriteString("exitS    ");
1068     | returnS  : Console.WriteString("returnS  ");
1069     | blockS   : Console.WriteString("blockS   ");
1070     ELSE
1071       Console.WriteString("unknown stmt, tag="); Console.WriteInt(t.kind,1);
1072     END;
1073     IF t.token # NIL THEN
1074       Console.WriteString("(lin:col ");
1075       Console.WriteInt(t.token.lin, 1); Console.Write(":");
1076       Console.WriteInt(t.token.col, 1); Console.Write(")");
1077     END;
1078   END WriteTag;
1079
1080   (* ---------------------------------- *)
1081
1082   PROCEDURE (t : Empty)Diagnose*(i : INTEGER);
1083   BEGIN
1084     WriteTag(t, i); Console.WriteLn;
1085   END Diagnose;
1086
1087   (* ---------------------------------- *)
1088
1089   PROCEDURE (t : Return)Diagnose*(i : INTEGER);
1090   BEGIN
1091     WriteTag(t, i); Console.WriteLn;
1092     IF t.retX # NIL THEN t.retX.Diagnose(i+4) END;
1093   END Diagnose;
1094
1095   (* ---------------------------------- *)
1096
1097   PROCEDURE (t : Block)Diagnose*(i : INTEGER);
1098     VAR index : INTEGER;
1099   BEGIN
1100     WriteTag(t, i);
1101     Console.WriteString(" {"); Console.WriteLn;
1102     FOR index := 0 TO t.sequ.tide - 1 DO
1103       t.sequ.a[index].Diagnose(i+4);
1104     END;
1105     H.Indent(i); Console.Write("}"); Console.WriteLn;
1106   END Diagnose;
1107
1108   (* ---------------------------------- *)
1109
1110   PROCEDURE (t : Assign)Diagnose*(i : INTEGER);
1111   BEGIN
1112     WriteTag(t, i); Console.WriteLn;
1113     IF t.lhsX # NIL THEN t.lhsX.Diagnose(i+4) END;
1114     IF t.rhsX # NIL THEN t.rhsX.Diagnose(i+4) END;
1115   END Diagnose;
1116
1117   (* ---------------------------------- *)
1118
1119   PROCEDURE (t : ProcCall)Diagnose*(i : INTEGER);
1120   BEGIN
1121     WriteTag(t, i); Console.WriteLn;
1122     IF t.expr # NIL THEN t.expr.Diagnose(i+4) END;
1123   END Diagnose;
1124
1125   (* ---------------------------------- *)
1126
1127   PROCEDURE (t : ForLoop)Diagnose*(i : INTEGER);
1128   BEGIN
1129     WriteTag(t, i);
1130     IF t.cVar # NIL THEN t.cVar.WriteName END;
1131     Console.WriteLn;
1132     IF t.loXp # NIL THEN t.loXp.Diagnose(i+2) END;
1133     IF t.hiXp # NIL THEN t.hiXp.Diagnose(i+2) END;
1134     H.Indent(i); Console.Write("{"); Console.WriteLn;
1135     t.body.Diagnose(i+4);
1136     H.Indent(i); Console.Write("}"); Console.WriteLn;
1137   END Diagnose;
1138
1139   (* ---------------------------------- *)
1140
1141   PROCEDURE (t : Choice)Diagnose*(i : INTEGER);
1142     CONST nil = "<nil>";
1143     VAR index : INTEGER;
1144         stmt  : D.Stmt;
1145         expr  : D.Expr;
1146   BEGIN
1147     WriteTag(t, i); Console.Write("{"); Console.WriteLn;
1148     FOR index := 0 TO t.preds.tide - 1 DO
1149       expr := t.preds.a[index];
1150       stmt := t.blocks.a[index];
1151       IF expr = NIL THEN
1152         H.Indent(i); Console.WriteString(nil); Console.WriteLn;
1153       ELSE
1154         expr.Diagnose(i);
1155       END;
1156       IF stmt = NIL THEN
1157         H.Indent(i+4); Console.WriteString(nil); Console.WriteLn;
1158       ELSE
1159         stmt.Diagnose(i+4);
1160       END;
1161     END;
1162     H.Indent(i); Console.Write("}"); Console.WriteLn;
1163   END Diagnose;
1164
1165   (* ---------------------------------- *)
1166
1167   PROCEDURE (t : ExitSt)Diagnose*(i : INTEGER);
1168   BEGIN
1169     WriteTag(t, i); Console.WriteLn;
1170   END Diagnose;
1171
1172   (* ---------------------------------- *)
1173
1174   PROCEDURE (t : TestLoop)Diagnose*(i : INTEGER);
1175   BEGIN
1176     WriteTag(t, i); Console.WriteLn;
1177     IF t.test # NIL THEN t.test.Diagnose(i) END;
1178     H.Indent(i); Console.Write("{"); Console.WriteLn;
1179     t.body.Diagnose(i+4);
1180     H.Indent(i); Console.Write("}"); Console.WriteLn;
1181   END Diagnose;
1182
1183   (* ---------------------------------- *)
1184
1185   PROCEDURE (t : CaseSt)Diagnose*(i : INTEGER);
1186     VAR index : INTEGER;
1187         trio  : Triple;
1188         next  : Triple;
1189         stIx  : INTEGER;
1190
1191   (* ------------------------- *)
1192     PROCEDURE WriteTrio(p : Triple);
1193     BEGIN
1194       Console.WriteInt(p.loC, 0);
1195       IF p.loC # p.hiC THEN
1196         Console.WriteString(" ..");
1197         Console.WriteInt(p.hiC, 0);
1198       END;
1199     END WriteTrio;
1200   (* ------------------------- *)
1201
1202   BEGIN
1203     WriteTag(t, i); Console.WriteLn;
1204     IF t.select # NIL THEN t.select.Diagnose(i) END;
1205     H.Indent(i); Console.Write("{"); Console.WriteLn;
1206     index := 0;
1207     IF t.labels.tide > 0 THEN
1208       H.Indent(i); Console.Write("|");
1209       trio := t.labels.a[index]; stIx := trio.ord; INC(index);
1210       WHILE index < t.labels.tide DO
1211         next := t.labels.a[index]; INC(index);
1212         IF next.ord = stIx THEN (* write out previous label *)
1213           WriteTrio(trio);
1214           trio := next;
1215           Console.WriteString(", ");
1216         ELSE (* next label belongs to the next case *)
1217           WriteTrio(trio);
1218           Console.WriteString(" : #");
1219           Console.WriteInt(trio.ord, 1); Console.WriteLn;
1220           H.Indent(i); Console.Write("|");
1221           trio := next; stIx := trio.ord;
1222         END;
1223       END;
1224       (* write out last label and case *)
1225       WriteTrio(trio);
1226       Console.WriteString(" : #");
1227       Console.WriteInt(trio.ord, 1); Console.WriteLn;
1228       FOR index := 0 TO t.blocks.tide - 1 DO
1229         H.Indent(i); Console.Write("#"); Console.WriteInt(index, 1);
1230         Console.WriteString(" -->"); Console.WriteLn;
1231         t.blocks.a[index].Diagnose(i+4);
1232       END;
1233     END;
1234     H.Indent(i); Console.WriteString("else");
1235     IF t.elsBlk # NIL THEN
1236       Console.WriteLn;
1237       t.elsBlk.Diagnose(i+4);
1238     ELSE
1239       Console.WriteString(" trap here");
1240       Console.WriteLn;
1241     END;
1242     H.Indent(i); Console.Write("}"); Console.WriteLn;
1243   END Diagnose;
1244
1245 (* ============================================================ *)
1246 BEGIN (* ====================================================== *)
1247 END StatDesc. (* ============================================== *)
1248 (* ============================================================ *)
1249