gcc/m2/gm2-compiler/M2CaseList.mod

   1 (* M2CaseList.mod implement ISO case label lists.
   2
   3 Copyright (C) 2009-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  *)
  21
  22 IMPLEMENTATION MODULE M2CaseList ;
  23
  24
  25 FROM M2Debug IMPORT Assert ;
  26 FROM M2GCCDeclare IMPORT TryDeclareConstant, GetTypeMin, GetTypeMax ;
  27 FROM M2MetaError IMPORT MetaError1, MetaError2, MetaErrorT0, MetaErrorT1, MetaErrorT2, MetaErrorT3, MetaErrorT4, MetaErrorStringT0, MetaErrorString1 ;
  28 FROM M2Error IMPORT InternalError ;
  29 FROM M2Range IMPORT OverlapsRange, IsEqual, IsGreater ;
  30 FROM M2ALU IMPORT PushIntegerTree, PopIntegerTree, Addn, Sub, PushInt ;
  31 FROM Indexing IMPORT Index, InitIndex, PutIndice, GetIndice, ForeachIndiceInIndexDo, HighIndice ;
  32 FROM Lists IMPORT InitList, IncludeItemIntoList, RemoveItemFromList, NoOfItemsInList, GetItemFromList ;
  33 FROM NameKey IMPORT KeyToCharStar ;
  34 FROM SymbolConversion IMPORT GccKnowsAbout, Mod2Gcc, AddModGcc ;
  35 FROM DynamicStrings IMPORT InitString, InitStringCharStar, InitStringChar, ConCat, Mark, KillString ;
  36 FROM m2tree IMPORT Tree ;
  37 FROM m2block IMPORT RememberType ;
  38 FROM m2type IMPORT GetMinFrom ;
  39 FROM m2expr IMPORT GetIntegerOne, CSTIntToString, CSTIntToChar ;
  40 FROM Storage IMPORT ALLOCATE ;
  41 FROM M2Base IMPORT IsExpressionCompatible, Char ;
  42 FROM M2Printf IMPORT printf1 ;
  43 FROM M2LexBuf IMPORT TokenToLocation ;
  44
  45 FROM SymbolTable IMPORT NulSym, IsConst, IsFieldVarient, IsRecord, IsRecordField, GetVarientTag, GetType,
  46                         ForeachLocalSymDo, GetSymName, IsEnumeration, SkipType, NoOfElements, GetNth,
  47                         IsSubrange ;
  48
  49 TYPE
  50    RangePair = POINTER TO RECORD
  51                   low, high: CARDINAL ;
  52                   tokenno  : CARDINAL ;
  53                END ;
  54
  55    ConflictingPair = POINTER TO RECORD
  56                         a, b: RangePair ;
  57                      END ;
  58
  59    CaseList = POINTER TO RECORD
  60                  maxRangeId  : CARDINAL ;
  61                  rangeArray  : Index ;
  62                  currentRange: RangePair ;
  63                  varientField: CARDINAL ;
  64               END ;
  65
  66    CaseDescriptor = POINTER TO RECORD
  67                        elseClause   : BOOLEAN ;
  68                        elseField    : CARDINAL ;
  69                        record       : CARDINAL ;
  70                        varient      : CARDINAL ;
  71                        expression   : CARDINAL ;
  72                        maxCaseId    : CARDINAL ;
  73                        caseListArray: Index ;
  74                        currentCase  : CaseList ;
  75                        next         : CaseDescriptor ;
  76                     END ;
  77
  78    SetRange = POINTER TO RECORD
  79                  low, high: Tree ;
  80                  next     : SetRange ;
  81               END ;
  82
  83 VAR
  84    caseStack    : CaseDescriptor ;
  85    caseId       : CARDINAL ;
  86    caseArray    : Index ;
  87    conflictArray: Index ;
  88    FreeRangeList: SetRange ;
  89
  90
  91
  92 (*
  93    PushCase - create a case entity and push it to an internal stack.
  94               rec is NulSym if this is a CASE statement.
  95               If rec is a record then it indicates a possible
  96               varients reside in the record to check.
  97               Both rec and va might be NulSym and then the expr
  98               will contain the selector expression to a case statement.
  99               Return the case id.
 100 *)
 101
 102 PROCEDURE PushCase (rec, va, expr: CARDINAL) : CARDINAL ;
 103 VAR
 104    c: CaseDescriptor ;
 105 BEGIN
 106    INC (caseId) ;
 107    NEW (c) ;
 108    IF c = NIL
 109    THEN
 110       InternalError ('out of memory error')
 111    ELSE
 112       WITH c^ DO
 113          elseClause := FALSE ;
 114          elseField := NulSym ;
 115          record := rec ;
 116          varient := va ;
 117          expression := expr ;
 118          maxCaseId := 0 ;
 119          caseListArray := InitIndex (1) ;
 120          next := caseStack ;
 121          currentCase := NIL
 122       END ;
 123       caseStack := c ;
 124       PutIndice (caseArray, caseId, c)
 125    END ;
 126    RETURN caseId
 127 END PushCase ;
 128
 129
 130 (*
 131    PopCase - pop the top element of the case entity from the internal
 132              stack.
 133 *)
 134
 135 PROCEDURE PopCase ;
 136 BEGIN
 137    IF caseStack=NIL
 138    THEN
 139       InternalError ('case stack is empty')
 140    END ;
 141    caseStack := caseStack^.next
 142 END PopCase ;
 143
 144
 145 (*
 146    ElseCase - indicates that this case varient does have an else clause.
 147 *)
 148
 149 PROCEDURE ElseCase (f: CARDINAL) ;
 150 BEGIN
 151    WITH caseStack^ DO
 152       elseClause := TRUE ;
 153       elseField := f
 154    END
 155 END ElseCase ;
 156
 157
 158 (*
 159    BeginCaseList - create a new label list.
 160 *)
 161
 162 PROCEDURE BeginCaseList (v: CARDINAL) ;
 163 VAR
 164    l: CaseList ;
 165 BEGIN
 166    NEW(l) ;
 167    IF l=NIL
 168    THEN
 169       InternalError ('out of memory error')
 170    END ;
 171    WITH l^ DO
 172       maxRangeId   := 0 ;
 173       rangeArray   := InitIndex(1) ;
 174       currentRange := NIL ;
 175       varientField := v
 176    END ;
 177    WITH caseStack^ DO
 178       INC(maxCaseId) ;
 179       PutIndice(caseListArray, maxCaseId, l) ;
 180       currentCase := l
 181    END
 182 END BeginCaseList ;
 183
 184
 185 (*
 186    EndCaseList - terminate the current label list.
 187 *)
 188
 189 PROCEDURE EndCaseList ;
 190 BEGIN
 191    caseStack^.currentCase := NIL
 192 END EndCaseList ;
 193
 194
 195 (*
 196    AddRange - add a range to the current label list.
 197 *)
 198
 199 PROCEDURE AddRange (r1, r2: CARDINAL; tok: CARDINAL) ;
 200 VAR
 201    r: RangePair ;
 202 BEGIN
 203    NEW(r) ;
 204    IF r=NIL
 205    THEN
 206       InternalError ('out of memory error')
 207    ELSE
 208       WITH r^ DO
 209          low := r1 ;
 210          high := r2 ;
 211          tokenno := tok
 212       END ;
 213       WITH caseStack^.currentCase^ DO
 214          INC(maxRangeId) ;
 215          PutIndice(rangeArray, maxRangeId, r) ;
 216          currentRange := r
 217       END
 218    END
 219 END AddRange ;
 220
 221
 222 (*
 223    GetVariantTagType - returns the type associated with, variant.
 224 *)
 225
 226 PROCEDURE GetVariantTagType (variant: CARDINAL) : CARDINAL ;
 227 VAR
 228    tag: CARDINAL ;
 229 BEGIN
 230    tag := GetVarientTag(variant) ;
 231    IF IsFieldVarient(tag) OR IsRecordField(tag)
 232    THEN
 233       RETURN( GetType(tag) )
 234    ELSE
 235       RETURN( tag )
 236    END
 237 END GetVariantTagType ;
 238
 239
 240 (*
 241    CaseBoundsResolved - returns TRUE if all constants in the case list, c,
 242                         are known to GCC.
 243 *)
 244
 245 PROCEDURE CaseBoundsResolved (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
 246 VAR
 247    resolved: BOOLEAN ;
 248    p       : CaseDescriptor ;
 249    q       : CaseList ;
 250    r       : RangePair ;
 251    min,
 252    max,
 253    type,
 254    i, j    : CARDINAL ;
 255 BEGIN
 256    p := GetIndice(caseArray, c) ;
 257    WITH p^ DO
 258       IF varient#NulSym
 259       THEN
 260          (* not a CASE statement, but a varient record containing without an ELSE clause *)
 261          type := GetVariantTagType(varient) ;
 262          resolved := TRUE ;
 263          IF NOT GccKnowsAbout(type)
 264          THEN
 265             (* do we need to add, type, to the list of types required to be resolved? *)
 266             resolved := FALSE
 267          END ;
 268          min := GetTypeMin(type) ;
 269          IF NOT GccKnowsAbout(min)
 270          THEN
 271             TryDeclareConstant(tokenno, min) ;
 272             resolved := FALSE
 273          END ;
 274          max := GetTypeMax(type) ;
 275          IF NOT GccKnowsAbout(max)
 276          THEN
 277             TryDeclareConstant(tokenno, max) ;
 278             resolved := FALSE
 279          END ;
 280          IF NOT resolved
 281          THEN
 282             RETURN( FALSE )
 283          END
 284       END ;
 285       i := 1 ;
 286       WHILE i<=maxCaseId DO
 287          q := GetIndice(caseListArray, i) ;
 288          j := 1 ;
 289          WHILE j<=q^.maxRangeId DO
 290             r := GetIndice(q^.rangeArray, j) ;
 291             IF r^.low#NulSym
 292             THEN
 293                IF IsConst(r^.low)
 294                THEN
 295                   TryDeclareConstant(tokenno, r^.low) ;
 296                   IF NOT GccKnowsAbout(r^.low)
 297                   THEN
 298                      RETURN( FALSE )
 299                   END
 300                ELSE
 301                   IF r^.high=NulSym
 302                   THEN
 303                      MetaError1('the CASE statement variant must be defined by a constant {%1Da:is a {%1d}}', r^.low)
 304                   ELSE
 305                      MetaError1('the CASE statement variant low value in a range must be defined by a constant {%1Da:is a {%1d}}',
 306                                 r^.low)
 307                   END
 308                END
 309             END ;
 310             IF r^.high#NulSym
 311             THEN
 312                IF IsConst(r^.high)
 313                THEN
 314                   TryDeclareConstant(tokenno, r^.high) ;
 315                   IF NOT GccKnowsAbout(r^.high)
 316                   THEN
 317                      RETURN( FALSE )
 318                   END
 319                ELSE
 320                   MetaError1('the CASE statement variant high value in a range must be defined by a constant {%1Da:is a {%1d}}',
 321                              r^.high)
 322                END
 323             END ;
 324             INC(j)
 325          END ;
 326          INC(i)
 327       END
 328    END ;
 329    RETURN( TRUE )
 330 END CaseBoundsResolved ;
 331
 332
 333 (*
 334    IsSame - return TRUE if r, s, are in, e.
 335 *)
 336
 337 PROCEDURE IsSame (e: ConflictingPair; r, s: RangePair) : BOOLEAN ;
 338 BEGIN
 339    WITH e^ DO
 340       RETURN( ((a=r) AND (b=s)) OR ((a=s) AND (b=r)) )
 341    END
 342 END IsSame ;
 343
 344
 345 (*
 346    SeenBefore -
 347 *)
 348
 349 PROCEDURE SeenBefore (r, s: RangePair) : BOOLEAN ;
 350 VAR
 351    i, h: CARDINAL ;
 352    e   : ConflictingPair ;
 353 BEGIN
 354    h := HighIndice(conflictArray) ;
 355    i := 1 ;
 356    WHILE i<=h DO
 357       e := GetIndice(conflictArray, i) ;
 358       IF IsSame(e, r, s)
 359       THEN
 360          RETURN( TRUE )
 361       END ;
 362       INC(i)
 363    END ;
 364    NEW(e) ;
 365    WITH e^ DO
 366       a := r ;
 367       b := s
 368    END ;
 369    PutIndice(conflictArray, h+1, e) ;
 370    RETURN( FALSE )
 371 END SeenBefore ;
 372
 373
 374 (*
 375    Overlaps -
 376 *)
 377
 378 PROCEDURE Overlaps (r, s: RangePair) : BOOLEAN ;
 379 VAR
 380    a, b, c, d: CARDINAL ;
 381 BEGIN
 382    a := r^.low ;
 383    c := s^.low ;
 384    IF r^.high=NulSym
 385    THEN
 386       b := a ;
 387       IF s^.high=NulSym
 388       THEN
 389          d := c ;
 390          IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
 391          THEN
 392             IF NOT SeenBefore(r, s)
 393             THEN
 394                MetaErrorT2 (r^.tokenno, 'case label {%1ad} is a duplicate with {%2ad}', a, c) ;
 395                MetaErrorT2 (s^.tokenno, 'case label {%1ad} is a duplicate with {%2ad}', c, a)
 396             END ;
 397             RETURN( TRUE )
 398          END
 399       ELSE
 400          d := s^.high ;
 401          IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
 402          THEN
 403             IF NOT SeenBefore (r, s)
 404             THEN
 405                MetaErrorT3 (r^.tokenno, 'case label {%1ad} is a duplicate in the range {%2ad}..{%3ad}', a, c, d) ;
 406                MetaErrorT3 (s^.tokenno, 'case range {%2ad}..{%3ad} is a duplicate of case label {%1ad}', c, d, a)
 407             END ;
 408             RETURN( TRUE )
 409          END
 410       END
 411    ELSE
 412       b := r^.high ;
 413       IF s^.high=NulSym
 414       THEN
 415          d := c ;
 416          IF OverlapsRange (Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
 417          THEN
 418             IF NOT SeenBefore(r, s)
 419             THEN
 420                MetaErrorT3 (r^.tokenno, 'case range {%1ad}..{%2ad} is a duplicate with case label {%3ad}', a, b, c) ;
 421                MetaErrorT3 (s^.tokenno, 'case label {%1ad} is a duplicate with case range %{2ad}..{%3ad}', c, a, b)
 422             END ;
 423             RETURN( TRUE )
 424          END
 425       ELSE
 426          d := s^.high ;
 427          IF OverlapsRange(Mod2Gcc(a), Mod2Gcc(b), Mod2Gcc(c), Mod2Gcc(d))
 428          THEN
 429             IF NOT SeenBefore(r, s)
 430             THEN
 431                MetaErrorT4 (r^.tokenno, 'case range {%1ad}..{%2ad} overlaps case range {%3ad}..{%4ad}', a, b, c, d) ;
 432                MetaErrorT4 (s^.tokenno, 'case range {%1ad}..{%2ad} overlaps case range {%3ad}..{%4ad}', c, d, a, b)
 433             END ;
 434             RETURN( TRUE )
 435          END
 436       END
 437    END ;
 438    RETURN( FALSE )
 439 END Overlaps ;
 440
 441
 442 (*
 443    OverlappingCaseBound - returns TRUE if, r, overlaps any case bound in the
 444                           case statement, c.
 445 *)
 446
 447 PROCEDURE OverlappingCaseBound (r: RangePair; c: CARDINAL) : BOOLEAN ;
 448 VAR
 449    p      : CaseDescriptor ;
 450    q      : CaseList ;
 451    s      : RangePair ;
 452    i, j   : CARDINAL ;
 453    overlap: BOOLEAN ;
 454 BEGIN
 455    p := GetIndice (caseArray, c) ;
 456    overlap := FALSE ;
 457    WITH p^ DO
 458       i := 1 ;
 459       WHILE i<=maxCaseId DO
 460          q := GetIndice (caseListArray, i) ;
 461          j := 1 ;
 462          WHILE j<=q^.maxRangeId DO
 463             s := GetIndice (q^.rangeArray, j) ;
 464             IF (s#r) AND Overlaps (r, s)
 465             THEN
 466                overlap := TRUE
 467             END ;
 468             INC (j)
 469          END ;
 470          INC (i)
 471       END
 472    END ;
 473    RETURN( overlap )
 474 END OverlappingCaseBound ;
 475
 476
 477 (*
 478    OverlappingCaseBounds - returns TRUE if there were any overlapping bounds
 479                            in the case list, c.  It will generate an error
 480                            messages for each overlapping bound found.
 481 *)
 482
 483 PROCEDURE OverlappingCaseBounds (c: CARDINAL) : BOOLEAN ;
 484 VAR
 485    p      : CaseDescriptor ;
 486    q      : CaseList ;
 487    r      : RangePair ;
 488    i, j   : CARDINAL ;
 489    overlap: BOOLEAN ;
 490 BEGIN
 491    p := GetIndice(caseArray, c) ;
 492    overlap := FALSE ;
 493    WITH p^ DO
 494       i := 1 ;
 495       WHILE i<=maxCaseId DO
 496          q := GetIndice(caseListArray, i) ;
 497          j := 1 ;
 498          WHILE j<=q^.maxRangeId DO
 499             r := GetIndice(q^.rangeArray, j) ;
 500             IF OverlappingCaseBound (r, c)
 501             THEN
 502                overlap := TRUE
 503             END ;
 504             INC(j)
 505          END ;
 506          INC(i)
 507       END
 508    END ;
 509    RETURN( overlap )
 510 END OverlappingCaseBounds ;
 511
 512
 513 (*
 514    NewRanges - return a new range from the freelist or heap.
 515 *)
 516
 517 PROCEDURE NewRanges () : SetRange ;
 518 VAR
 519    s: SetRange ;
 520 BEGIN
 521    IF FreeRangeList=NIL
 522    THEN
 523       NEW(s)
 524    ELSE
 525       s := FreeRangeList ;
 526       FreeRangeList := FreeRangeList^.next
 527    END ;
 528    s^.next := NIL ;
 529    RETURN( s )
 530 END NewRanges ;
 531
 532
 533 (*
 534    NewSet - returns a new set based on type with the low and high fields assigned
 535             to the min and max values for the type.
 536 *)
 537
 538 PROCEDURE NewSet (type: CARDINAL) : SetRange ;
 539 VAR
 540    s: SetRange ;
 541 BEGIN
 542    s := NewRanges() ;
 543    WITH s^ DO
 544       low := Mod2Gcc(GetTypeMin(type)) ;
 545       high := Mod2Gcc(GetTypeMax(type)) ;
 546       next := NIL
 547    END ;
 548    RETURN( s )
 549 END NewSet ;
 550
 551
 552 (*
 553    DisposeRanges - place set and its list onto the free list.
 554 *)
 555
 556 PROCEDURE DisposeRanges (set: SetRange) : SetRange ;
 557 VAR
 558    t: SetRange ;
 559 BEGIN
 560    IF set#NIL
 561    THEN
 562       IF FreeRangeList=NIL
 563       THEN
 564          FreeRangeList := set
 565       ELSE
 566          t := set ;
 567          WHILE t^.next#NIL DO
 568             t := t^.next
 569          END ;
 570          t^.next := FreeRangeList ;
 571          FreeRangeList := set
 572       END
 573    END ;
 574    RETURN( NIL )
 575 END DisposeRanges ;
 576
 577
 578 (*
 579    RemoveRange - removes the range descriptor h from set and return the
 580                  possibly new head of set.
 581 *)
 582
 583 PROCEDURE RemoveRange (set: SetRange; h: SetRange) : SetRange ;
 584 VAR
 585    i: SetRange ;
 586 BEGIN
 587    IF h=set
 588    THEN
 589       set := set^.next ;
 590       h^.next := NIL ;
 591       h := DisposeRanges(h) ;
 592    ELSE
 593       i := set ;
 594       WHILE i^.next#h DO
 595          i := i^.next
 596       END ;
 597       i^.next := h^.next ;
 598       i := h ;
 599       h := h^.next ;
 600       i^.next := NIL ;
 601       i := DisposeRanges(i)
 602    END ;
 603    RETURN set
 604 END RemoveRange ;
 605
 606
 607 (*
 608    SubBitRange - subtracts bits, lo..hi, from, set.
 609 *)
 610
 611 PROCEDURE SubBitRange (set: SetRange; lo, hi: Tree; tokenno: CARDINAL) : SetRange ;
 612 VAR
 613    h, i: SetRange ;
 614 BEGIN
 615    h := set ;
 616    WHILE h#NIL DO
 617       (* Check to see if a single set element h is obliterated by lo..hi.  *)
 618       IF (h^.high=NIL) OR IsEqual(h^.high, h^.low)
 619       THEN
 620          IF IsEqual(h^.low, lo) OR OverlapsRange(lo, hi, h^.low, h^.low)
 621          THEN
 622             set := RemoveRange (set, h) ;
 623             h := set
 624          ELSE
 625             h := h^.next
 626          END
 627       (* Now check to see if the lo..hi match exactly with the set range.  *)
 628       ELSIF (h^.high#NIL) AND IsEqual (lo, h^.low) AND IsEqual (hi, h^.high)
 629       THEN
 630          (* Remove h and return as lo..hi have been removed.  *)
 631          RETURN RemoveRange (set, h)
 632       ELSE
 633          (* All other cases require modifying the existing set range.  *)
 634          IF OverlapsRange(lo, hi, h^.low, h^.high)
 635          THEN
 636             IF IsGreater(h^.low, lo) OR IsGreater(hi, h^.high)
 637             THEN
 638                MetaErrorT0 (tokenno, 'variant case range lies outside tag value')
 639             ELSE
 640                IF IsEqual(h^.low, lo)
 641                THEN
 642                   PushIntegerTree(hi) ;
 643                   PushInt(1) ;
 644                   Addn ;
 645                   h^.low := PopIntegerTree()
 646                ELSIF IsEqual(h^.high, hi)
 647                THEN
 648                   PushIntegerTree(lo) ;
 649                   PushInt(1) ;
 650                   Sub ;
 651                   h^.high := PopIntegerTree()
 652                ELSE
 653                   (* lo..hi  exist inside range h^.low..h^.high *)
 654                   i := NewRanges() ;
 655                   i^.next := h^.next ;
 656                   h^.next := i ;
 657                   i^.high := h^.high ;
 658                   PushIntegerTree(lo) ;
 659                   PushInt(1) ;
 660                   Sub ;
 661                   h^.high := PopIntegerTree() ;
 662                   PushIntegerTree(hi) ;
 663                   PushInt(1) ;
 664                   Addn ;
 665                   i^.low := PopIntegerTree()
 666                END
 667             END
 668          ELSE
 669             h := h^.next
 670          END
 671       END
 672    END ;
 673    RETURN( set )
 674 END SubBitRange ;
 675
 676
 677 (*
 678    CheckLowHigh - checks to see the low value <= high value and issues an error
 679                   if this is not true.
 680 *)
 681
 682 PROCEDURE CheckLowHigh (rp: RangePair) ;
 683 VAR
 684    lo, hi: Tree ;
 685    temp  : CARDINAL ;
 686 BEGIN
 687    lo := Mod2Gcc (rp^.low) ;
 688    hi := Mod2Gcc (rp^.high) ;
 689    IF IsGreater (lo, hi)
 690    THEN
 691       MetaErrorT2 (rp^.tokenno, 'case range should be low..high rather than high..low, range specified as {%1Euad}..{%2Euad}', rp^.low, rp^.high) ;
 692       temp := rp^.high ;
 693       rp^.high := rp^.low ;
 694       rp^.low := temp
 695    END
 696 END CheckLowHigh ;
 697
 698
 699 (*
 700    ExcludeCaseRanges - excludes all case ranges found in, p, from, set
 701 *)
 702
 703 PROCEDURE ExcludeCaseRanges (set: SetRange; cd: CaseDescriptor) : SetRange ;
 704 VAR
 705    i, j: CARDINAL ;
 706    cl  : CaseList ;
 707    rp  : RangePair ;
 708 BEGIN
 709    WITH cd^ DO
 710       i := 1 ;
 711       WHILE i <= maxCaseId DO
 712          cl := GetIndice (caseListArray, i) ;
 713          j := 1 ;
 714          WHILE j <= cl^.maxRangeId DO
 715             rp := GetIndice (cl^.rangeArray, j) ;
 716             IF rp^.high = NulSym
 717             THEN
 718                set := SubBitRange (set,
 719                                    Mod2Gcc (rp^.low),
 720                                    Mod2Gcc (rp^.low), rp^.tokenno)
 721             ELSE
 722                CheckLowHigh (rp) ;
 723                set := SubBitRange (set,
 724                                    Mod2Gcc (rp^.low),
 725                                    Mod2Gcc (rp^.high), rp^.tokenno)
 726             END ;
 727             INC (j)
 728          END ;
 729          INC (i)
 730       END
 731    END ;
 732    RETURN set
 733 END ExcludeCaseRanges ;
 734
 735
 736 VAR
 737    errorString: String ;
 738
 739
 740 (*
 741    IncludeElement - only include enumeration field into errorString if it lies between low..high.
 742 *)
 743
 744 PROCEDURE IncludeElement (enumList: List; field: CARDINAL; low, high: Tree) ;
 745 VAR
 746    fieldTree: Tree ;
 747 BEGIN
 748    IF field # NulSym
 749    THEN
 750       fieldTree := Mod2Gcc (field) ;
 751       IF OverlapsRange (fieldTree, fieldTree, low, high)
 752       THEN
 753          IncludeItemIntoList (enumList, field)
 754       END
 755    END
 756 END IncludeElement ;
 757
 758
 759 (*
 760    IncludeElements - only include enumeration field values low..high in errorString.
 761 *)
 762
 763 PROCEDURE IncludeElements (type: CARDINAL; enumList: List; low, high: Tree) ;
 764 VAR
 765    field     : CARDINAL ;
 766    i,
 767    NoElements: CARDINAL ;
 768 BEGIN
 769    NoElements := NoOfElements (type) ;
 770    i := 1 ;
 771    WHILE i <= NoElements DO
 772       field := GetNth (type, i) ;
 773       IncludeElement (enumList, field, low, high) ;
 774       INC (i)
 775    END
 776 END IncludeElements ;
 777
 778
 779 (*
 780    ErrorRangeEnum - include enumeration fields Low to High in errorString.
 781 *)
 782
 783 PROCEDURE ErrorRangeEnum (type: CARDINAL; set: SetRange; enumList: List) ;
 784 VAR
 785    Low, High: Tree ;
 786 BEGIN
 787    Low := set^.low ;
 788    High := set^.high ;
 789    IF Low = NIL
 790    THEN
 791       Low := High
 792    END ;
 793    IF High = NIL
 794    THEN
 795       High := Low
 796    END ;
 797    IF (Low # NIL) AND (High # NIL)
 798    THEN
 799       IncludeElements (type, enumList, Low, High)
 800    END
 801 END ErrorRangeEnum ;
 802
 803
 804 (*
 805    ErrorRanges - return a list of all enumeration fields not present in the case statement.
 806                  The return value will be nil if type is not an enumeration type.
 807 *)
 808
 809 PROCEDURE ErrorRanges (type: CARDINAL; set: SetRange) : List ;
 810 VAR
 811    enumSet: List ;
 812 BEGIN
 813    type := SkipType (type) ;
 814    IF IsEnumeration (type)
 815    THEN
 816       InitList (enumSet) ;
 817       WHILE set#NIL DO
 818          ErrorRangeEnum (type, set, enumSet) ;
 819          set := set^.next
 820       END ;
 821       RETURN enumSet
 822    END ;
 823    RETURN NIL
 824 END ErrorRanges ;
 825
 826
 827 (*
 828    appendString - appends str to errorString.
 829 *)
 830
 831 PROCEDURE appendString (str: String) ;
 832 BEGIN
 833    errorString := ConCat (errorString, str)
 834 END appendString ;
 835
 836
 837 (*
 838    appendEnum - appends enum to errorString.
 839 *)
 840
 841 PROCEDURE appendEnum (enum: CARDINAL) ;
 842 BEGIN
 843    appendString (Mark (InitStringCharStar (KeyToCharStar (GetSymName (enum)))))
 844 END appendEnum ;
 845
 846
 847 (*
 848    appendStr - appends str to errorString.
 849 *)
 850
 851 PROCEDURE appendStr (str: ARRAY OF CHAR) ;
 852 BEGIN
 853    appendString (Mark (InitString (str)))
 854 END appendStr ;
 855
 856
 857 (*
 858    EnumerateErrors - populate errorString with the contents of enumList.
 859 *)
 860
 861 PROCEDURE EnumerateErrors (enumList: List) ;
 862 VAR
 863    i, n: CARDINAL ;
 864 BEGIN
 865    n := NoOfItemsInList (enumList) ;
 866    IF (enumList # NIL) AND (n > 0)
 867    THEN
 868       IF n = 1
 869       THEN
 870          errorString := InitString ('{%W}the missing enumeration field is: ') ;
 871       ELSE
 872          errorString := InitString ('{%W}the missing enumeration fields are: ') ;
 873       END ;
 874       appendEnum (GetItemFromList (enumList, 1)) ;
 875       IF n > 1
 876       THEN
 877          IF n > 2
 878          THEN
 879             i := 2 ;
 880             WHILE i <= n-1 DO
 881                appendStr (', ') ;
 882                appendEnum (GetItemFromList (enumList, i)) ;
 883                INC (i)
 884             END
 885          END ;
 886          appendStr (' and ') ;
 887          appendEnum (GetItemFromList (enumList, n))
 888       END
 889    END
 890 END EnumerateErrors ;
 891
 892
 893 (*
 894    NoOfSetElements - return the number of set elements.
 895 *)
 896
 897 PROCEDURE NoOfSetElements (set: SetRange) : Tree ;
 898 BEGIN
 899    PushInt (0) ;
 900    WHILE set # NIL DO
 901       IF ((set^.low # NIL) AND (set^.high = NIL)) OR
 902          ((set^.low = NIL) AND (set^.high # NIL))
 903       THEN
 904          PushInt (1) ;
 905          Addn
 906       ELSIF (set^.low # NIL) AND (set^.high # NIL)
 907       THEN
 908          PushIntegerTree (set^.high) ;
 909          PushIntegerTree (set^.low) ;
 910          Sub ;
 911          PushInt (1) ;
 912          Addn ;
 913          Addn
 914       END ;
 915       set := set^.next
 916    END ;
 917    RETURN PopIntegerTree ()
 918 END NoOfSetElements ;
 919
 920
 921 (*
 922    isPrintableChar - a cautious isprint.
 923 *)
 924
 925 PROCEDURE isPrintableChar (value: Tree) : BOOLEAN ;
 926 BEGIN
 927    CASE CSTIntToChar (value) OF
 928
 929    'a'..'z':  RETURN TRUE |
 930    'A'..'Z':  RETURN TRUE |
 931    '0'..'9':  RETURN TRUE |
 932    '!', '@':  RETURN TRUE |
 933    '#', '$':  RETURN TRUE |
 934    '%', '^':  RETURN TRUE |
 935    '&', '*':  RETURN TRUE |
 936    '(', ')':  RETURN TRUE |
 937    '[', ']':  RETURN TRUE |
 938    '{', '}':  RETURN TRUE |
 939    '-', '+':  RETURN TRUE |
 940    '_', '=':  RETURN TRUE |
 941    ':', ';':  RETURN TRUE |
 942    "'", '"':  RETURN TRUE |
 943    ',', '.':  RETURN TRUE |
 944    '<', '>':  RETURN TRUE |
 945    '/', '?':  RETURN TRUE |
 946    '\', '|':  RETURN TRUE |
 947    '~', '`':  RETURN TRUE |
 948    ' '     :  RETURN TRUE
 949
 950    ELSE
 951       RETURN FALSE
 952    END
 953 END isPrintableChar ;
 954
 955
 956 (*
 957    appendTree - append tree value to the errorString.  It attempts to pretty print
 958                 CHAR constants and will fall back to CHR (x) if necessary.
 959 *)
 960
 961 PROCEDURE appendTree (value: Tree; type: CARDINAL) ;
 962 BEGIN
 963     IF SkipType (GetType (type)) = Char
 964     THEN
 965        IF isPrintableChar (value)
 966        THEN
 967           IF CSTIntToChar (value) = "'"
 968           THEN
 969              appendString (InitStringChar ('"')) ;
 970              appendString (InitStringChar (CSTIntToChar (value))) ;
 971              appendString (InitStringChar ('"'))
 972           ELSE
 973              appendString (InitStringChar ("'")) ;
 974              appendString (InitStringChar (CSTIntToChar (value))) ;
 975              appendString (InitStringChar ("'"))
 976           END
 977        ELSE
 978           appendString (InitString ('CHR (')) ;
 979           appendString (InitStringCharStar (CSTIntToString (value))) ;
 980           appendString (InitStringChar (')'))
 981        END
 982     ELSE
 983        appendString (InitStringCharStar (CSTIntToString (value)))
 984     END
 985 END appendTree ;
 986
 987
 988 (*
 989    SubrangeErrors - create an errorString containing all set ranges.
 990 *)
 991
 992 PROCEDURE SubrangeErrors (subrangetype: CARDINAL; set: SetRange) ;
 993 VAR
 994    sr       : SetRange ;
 995    rangeNo  : CARDINAL ;
 996    nMissing,
 997    zero, one: Tree ;
 998 BEGIN
 999    nMissing := NoOfSetElements (set) ;
1000    PushInt (0) ;
1001    zero := PopIntegerTree () ;
1002    IF IsGreater (nMissing, zero)
1003    THEN
1004       PushInt (1) ;
1005       one := PopIntegerTree () ;
1006       IF IsGreater (nMissing, one)
1007       THEN
1008          errorString := InitString ('{%W}there are a total of ')
1009       ELSE
1010          errorString := InitString ('{%W}there is a total of ')
1011       END ;
1012       appendString (InitStringCharStar (CSTIntToString (nMissing))) ;
1013       appendStr (' missing values in the subrange, the {%kCASE} statement needs labels (or an {%kELSE} statement)') ;
1014       appendStr (' for the following values: ') ;
1015       sr := set ;
1016       rangeNo := 0 ;
1017       WHILE sr # NIL DO
1018          INC (rangeNo) ;
1019          IF rangeNo > 1
1020          THEN
1021             IF sr^.next = NIL
1022             THEN
1023                appendStr (' and ')
1024             ELSE
1025                appendStr (', ')
1026             END
1027          END ;
1028          IF sr^.low = NIL
1029          THEN
1030             appendTree (sr^.high, subrangetype)
1031          ELSIF (sr^.high = NIL) OR IsEqual (sr^.low, sr^.high)
1032          THEN
1033             appendTree (sr^.low, subrangetype)
1034          ELSE
1035             appendTree (sr^.low, subrangetype) ;
1036             appendStr ('..') ;
1037             appendTree (sr^.high, subrangetype)
1038          END ;
1039          sr := sr^.next
1040       END
1041    END
1042 END SubrangeErrors ;
1043
1044
1045 (*
1046    EmitMissingRangeErrors - emits a singular/plural error message for an enumeration type.
1047 *)
1048
1049 PROCEDURE EmitMissingRangeErrors (tokenno: CARDINAL; type: CARDINAL; set: SetRange) ;
1050 BEGIN
1051    errorString := NIL ;
1052    IF IsEnumeration (type)
1053    THEN
1054       EnumerateErrors (ErrorRanges (type, set))
1055    ELSIF IsSubrange (type)
1056    THEN
1057       SubrangeErrors (type, set)
1058    END ;
1059    IF errorString # NIL
1060    THEN
1061       MetaErrorStringT0 (tokenno, errorString)
1062    END
1063 END EmitMissingRangeErrors ;
1064
1065
1066 (*
1067    MissingCaseBounds - returns true if there were any missing bounds
1068                        in the varient record case list, c.  It will
1069                        generate an error message for each missing
1070                        bounds found.
1071 *)
1072
1073 PROCEDURE MissingCaseBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
1074 VAR
1075    p      : CaseDescriptor ;
1076    type   : CARDINAL ;
1077    missing: BOOLEAN ;
1078    set    : SetRange ;
1079 BEGIN
1080    p := GetIndice (caseArray, c) ;
1081    missing := FALSE ;
1082    WITH p^ DO
1083       IF NOT elseClause
1084       THEN
1085          IF (record # NulSym) AND (varient # NulSym)
1086          THEN
1087             (* Not a case statement, but a varient record without an else clause.  *)
1088             type := GetVariantTagType (varient) ;
1089             set := NewSet (type) ;
1090             set := ExcludeCaseRanges (set, p) ;
1091             IF set # NIL
1092             THEN
1093                missing := TRUE ;
1094                MetaErrorT2 (tokenno,
1095                             'not all variant record alternatives in the {%kCASE} clause are specified, hint you either need to specify each value of {%2ad} or use an {%kELSE} clause',
1096                             varient, type) ;
1097                EmitMissingRangeErrors (tokenno, type, set)
1098             END ;
1099             set := DisposeRanges (set)
1100          END
1101       END
1102    END ;
1103    RETURN missing
1104 END MissingCaseBounds ;
1105
1106
1107 (*
1108    MissingCaseStatementBounds - returns true if the case statement has a missing
1109                                 clause.  It will also generate error messages.
1110 *)
1111
1112 PROCEDURE MissingCaseStatementBounds (tokenno: CARDINAL; c: CARDINAL) : BOOLEAN ;
1113 VAR
1114    p      : CaseDescriptor ;
1115    type   : CARDINAL ;
1116    missing: BOOLEAN ;
1117    set    : SetRange ;
1118 BEGIN
1119    p := GetIndice (caseArray, c) ;
1120    missing := FALSE ;
1121    WITH p^ DO
1122       IF NOT elseClause
1123       THEN
1124          IF expression # NulSym
1125          THEN
1126             type := SkipType (GetType (expression)) ;
1127             IF type # NulSym
1128             THEN
1129                IF IsEnumeration (type) OR IsSubrange (type)
1130                THEN
1131                   (* A case statement sequence without an else clause but
1132                      selecting using an enumeration type.  *)
1133                   set := NewSet (type) ;
1134                   set := ExcludeCaseRanges (set, p) ;
1135                   IF set # NIL
1136                   THEN
1137                      missing := TRUE ;
1138                      MetaErrorT1 (tokenno,
1139                                   'not all {%1Wd} values in the {%kCASE} statements are specified, hint you either need to specify each value of {%1ad} or use an {%kELSE} clause',
1140                                   type) ;
1141                      EmitMissingRangeErrors (tokenno, type, set)
1142                   END ;
1143                   set := DisposeRanges (set)
1144                END
1145             END
1146          END
1147       END
1148    END ;
1149    RETURN missing
1150 END MissingCaseStatementBounds ;
1151
1152
1153 (*
1154    InRangeList - returns true if the value, tag, is defined in the case list.
1155
1156 procedure InRangeList (cl: CaseList; tag: cardinal) : boolean ;
1157 var
1158    i, h: cardinal ;
1159    r   : RangePair ;
1160    a   : Tree ;
1161 begin
1162    with cl^ do
1163       i := 1 ;
1164       h := HighIndice(rangeArray) ;
1165       while i<=h do
1166          r := GetIndice(rangeArray, i) ;
1167          with r^ do
1168             if high=NulSym
1169             then
1170                a := Mod2Gcc(low)
1171             else
1172                a := Mod2Gcc(high)
1173             end ;
1174             if OverlapsRange(Mod2Gcc(low), a, Mod2Gcc(tag), Mod2Gcc(tag))
1175             then
1176                return( true )
1177             end
1178          end ;
1179          inc(i)
1180       end
1181    end ;
1182    return( false )
1183 end InRangeList ;
1184 *)
1185
1186
1187 (*
1188    WriteCase - dump out the case list (internal debugging).
1189 *)
1190
1191 PROCEDURE WriteCase (c: CARDINAL) ;
1192 BEGIN
1193    (* this debugging PROCEDURE should be finished.  *)
1194    printf1 ("%d", c)
1195 END WriteCase ;
1196
1197
1198 (*
1199    checkTypes - checks to see that, constant, and, type, are compatible.
1200 *)
1201
1202 PROCEDURE checkTypes (constant, type: CARDINAL) : BOOLEAN ;
1203 VAR
1204    consttype: CARDINAL ;
1205 BEGIN
1206    IF (constant # NulSym) AND IsConst (constant)
1207    THEN
1208       consttype := GetType (constant) ;
1209       IF NOT IsExpressionCompatible (consttype, type)
1210       THEN
1211          MetaError2 ('the case statement variant tag {%1ad} must be type compatible with the constant {%2Da:is a {%2d}}',
1212                      type, constant) ;
1213          RETURN FALSE
1214       END
1215    END ;
1216    RETURN TRUE
1217 END checkTypes ;
1218
1219
1220 (*
1221    inRange - returns true if, min <= i <= max.
1222 *)
1223
1224 PROCEDURE inRange (i, min, max: CARDINAL) : BOOLEAN ;
1225 BEGIN
1226    RETURN OverlapsRange (Mod2Gcc (i), Mod2Gcc (i), Mod2Gcc (min), Mod2Gcc (max))
1227 END inRange ;
1228
1229
1230 (*
1231    TypeCaseBounds - returns true if all bounds in case list, c, are
1232                     compatible with the tagged type.
1233 *)
1234
1235 PROCEDURE TypeCaseBounds (c: CARDINAL) : BOOLEAN ;
1236 VAR
1237    p         : CaseDescriptor ;
1238    q         : CaseList ;
1239    r         : RangePair ;
1240    min, max,
1241    type,
1242    i, j      : CARDINAL ;
1243    compatible: BOOLEAN ;
1244 BEGIN
1245    p := GetIndice(caseArray, c) ;
1246    type := NulSym ;
1247    WITH p^ DO
1248       type := NulSym ;
1249       IF varient#NulSym
1250       THEN
1251          (* not a CASE statement, but a varient record containing without an ELSE clause *)
1252          type := GetVariantTagType(varient) ;
1253          min := GetTypeMin(type) ;
1254          max := GetTypeMax(type)
1255       END ;
1256       IF type=NulSym
1257       THEN
1258          RETURN( TRUE )
1259       END ;
1260       compatible := TRUE ;
1261       i := 1 ;
1262       WHILE i<=maxCaseId DO
1263          q := GetIndice(caseListArray, i) ;
1264          j := 1 ;
1265          WHILE j<=q^.maxRangeId DO
1266             r := GetIndice(q^.rangeArray, j) ;
1267             IF (r^.low#NulSym) AND (NOT inRange(r^.low, min, max))
1268             THEN
1269                MetaError2('the CASE statement variant range {%1ad} exceeds that of the tag type {%2ad}',
1270                           r^.low, type) ;
1271                compatible := FALSE
1272             END ;
1273             IF NOT checkTypes(r^.low, type)
1274             THEN
1275                compatible := FALSE
1276             END ;
1277             IF (r^.high#NulSym) AND (NOT inRange(r^.high, min, max))
1278             THEN
1279                MetaError2('the CASE statement variant range {%1ad} exceeds that of the tag type {%2ad}',
1280                           r^.high, type) ;
1281                compatible := FALSE
1282             END ;
1283             IF NOT checkTypes(r^.high, type)
1284             THEN
1285                compatible := FALSE
1286             END ;
1287             INC (j)
1288          END ;
1289          INC (i)
1290       END ;
1291       RETURN compatible
1292    END
1293 END TypeCaseBounds ;
1294
1295
1296 BEGIN
1297    caseStack := NIL ;
1298    caseId := 0 ;
1299    caseArray := InitIndex(1) ;
1300    conflictArray := InitIndex(1) ;
1301    FreeRangeList := NIL
1302 END M2CaseList.