gcc/ada/sem_case.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ C A S E                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1996-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Namet;    use Namet;
  32 with Nlists;   use Nlists;
  33 with Sem;      use Sem;
  34 with Sem_Eval; use Sem_Eval;
  35 with Sem_Res;  use Sem_Res;
  36 with Sem_Util; use Sem_Util;
  37 with Sem_Type; use Sem_Type;
  38 with Snames;   use Snames;
  39 with Stand;    use Stand;
  40 with Sinfo;    use Sinfo;
  41 with Uintp;    use Uintp;
  42
  43 with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
  44
  45 package body Sem_Case is
  46
  47    -----------------------
  48    -- Local Subprograms --
  49    -----------------------
  50
  51    type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
  52    --  This new array type is used as the actual table type for sorting
  53    --  discrete choices. The reason for not using Choice_Table_Type, is that
  54    --  in Sort_Choice_Table_Type we reserve entry 0 for the sorting algortim
  55    --  (this is not absolutely necessary but it makes the code more
  56    --  efficient).
  57
  58    procedure Check_Choices
  59      (Choice_Table   : in out Sort_Choice_Table_Type;
  60       Bounds_Type    : Entity_Id;
  61       Others_Present : Boolean;
  62       Msg_Sloc       : Source_Ptr);
  63    --  This is the procedure which verifies that a set of case statement,
  64    --  array aggregate or record variant choices has no duplicates, and
  65    --  covers the range specified by Bounds_Type. Choice_Table contains the
  66    --  discrete choices to check. These must start at position 1.
  67    --  Furthermore Choice_Table (0) must exist. This element is used by
  68    --  the sorting algorithm as a temporary. Others_Present is a flag
  69    --  indicating whether or not an Others choice is present. Finally
  70    --  Msg_Sloc gives the source location of the construct containing the
  71    --  choices in the Choice_Table.
  72
  73    function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
  74    --  Given a Pos value of enumeration type Ctype, returns the name
  75    --  ID of an appropriate string to be used in error message output.
  76
  77    -------------------
  78    -- Check_Choices --
  79    -------------------
  80
  81    procedure Check_Choices
  82      (Choice_Table   : in out Sort_Choice_Table_Type;
  83       Bounds_Type    : Entity_Id;
  84       Others_Present : Boolean;
  85       Msg_Sloc       : Source_Ptr)
  86    is
  87
  88       function Lt_Choice (C1, C2 : Natural) return Boolean;
  89       --  Comparison routine for comparing Choice_Table entries.
  90       --  Use the lower bound of each Choice as the key.
  91
  92       procedure Move_Choice (From : Natural; To : Natural);
  93       --  Move routine for sorting the Choice_Table.
  94
  95       procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
  96       procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
  97       procedure Issue_Msg (Value1 : Uint;    Value2 : Node_Id);
  98       procedure Issue_Msg (Value1 : Uint;    Value2 : Uint);
  99       --  Issue an error message indicating that there are missing choices,
 100       --  followed by the image of the missing choices themselves which lie
 101       --  between Value1 and Value2 inclusive.
 102
 103       ---------------
 104       -- Issue_Msg --
 105       ---------------
 106
 107       procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
 108       begin
 109          Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
 110       end Issue_Msg;
 111
 112       procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
 113       begin
 114          Issue_Msg (Expr_Value (Value1), Value2);
 115       end Issue_Msg;
 116
 117       procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
 118       begin
 119          Issue_Msg (Value1, Expr_Value (Value2));
 120       end Issue_Msg;
 121
 122       procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
 123       begin
 124          --  In some situations, we call this with a null range, and
 125          --  obviously we don't want to complain in this case!
 126
 127          if Value1 > Value2 then
 128             return;
 129          end if;
 130
 131          --  Case of only one value that is missing
 132
 133          if Value1 = Value2 then
 134             if Is_Integer_Type (Bounds_Type) then
 135                Error_Msg_Uint_1 := Value1;
 136                Error_Msg ("missing case value: ^!", Msg_Sloc);
 137             else
 138                Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
 139                Error_Msg ("missing case value: %!", Msg_Sloc);
 140             end if;
 141
 142          --  More than one choice value, so print range of values
 143
 144          else
 145             if Is_Integer_Type (Bounds_Type) then
 146                Error_Msg_Uint_1 := Value1;
 147                Error_Msg_Uint_2 := Value2;
 148                Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
 149             else
 150                Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
 151                Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
 152                Error_Msg ("missing case values: % .. %!", Msg_Sloc);
 153             end if;
 154          end if;
 155       end Issue_Msg;
 156
 157       ---------------
 158       -- Lt_Choice --
 159       ---------------
 160
 161       function Lt_Choice (C1, C2 : Natural) return Boolean is
 162       begin
 163          return
 164            Expr_Value (Choice_Table (Nat (C1)).Lo)
 165            <= Expr_Value (Choice_Table (Nat (C2)).Lo);
 166       end Lt_Choice;
 167
 168       -----------------
 169       -- Move_Choice --
 170       -----------------
 171
 172       procedure Move_Choice (From : Natural; To : Natural) is
 173       begin
 174          Choice_Table (Nat (To)) := Choice_Table (Nat (From));
 175       end Move_Choice;
 176
 177       --  Variables local to Check_Choices
 178
 179       Choice      : Node_Id;
 180       Bounds_Lo   : constant Node_Id := Type_Low_Bound (Bounds_Type);
 181       Bounds_Hi   : constant Node_Id := Type_High_Bound (Bounds_Type);
 182
 183       Prev_Choice : Node_Id;
 184
 185       Hi       : Uint;
 186       Lo       : Uint;
 187       Prev_Hi  : Uint;
 188
 189    --  Start processing for Check_Choices
 190
 191    begin
 192
 193       --  Choice_Table must start at 0 which is an unused location used
 194       --  by the sorting algorithm. However the first valid position for
 195       --  a discrete choice is 1.
 196
 197       pragma Assert (Choice_Table'First = 0);
 198
 199       if Choice_Table'Last = 0 then
 200          if not Others_Present then
 201             Issue_Msg (Bounds_Lo, Bounds_Hi);
 202          end if;
 203          return;
 204       end if;
 205
 206       Sort
 207         (Positive (Choice_Table'Last),
 208          Move_Choice'Unrestricted_Access,
 209          Lt_Choice'Unrestricted_Access);
 210
 211       Lo      := Expr_Value (Choice_Table (1).Lo);
 212       Hi      := Expr_Value (Choice_Table (1).Hi);
 213       Prev_Hi := Hi;
 214
 215       if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
 216          Issue_Msg (Bounds_Lo, Lo - 1);
 217       end if;
 218
 219       for J in 2 .. Choice_Table'Last loop
 220          Lo := Expr_Value (Choice_Table (J).Lo);
 221          Hi := Expr_Value (Choice_Table (J).Hi);
 222
 223          if Lo <= Prev_Hi then
 224             Prev_Choice := Choice_Table (J - 1).Node;
 225             Choice      := Choice_Table (J).Node;
 226
 227             if Sloc (Prev_Choice) <= Sloc (Choice) then
 228                Error_Msg_Sloc := Sloc (Prev_Choice);
 229                Error_Msg_N ("duplication of choice value#", Choice);
 230             else
 231                Error_Msg_Sloc := Sloc (Choice);
 232                Error_Msg_N ("duplication of choice value#", Prev_Choice);
 233             end if;
 234
 235          elsif not Others_Present and then Lo /= Prev_Hi + 1 then
 236             Issue_Msg (Prev_Hi + 1, Lo - 1);
 237          end if;
 238
 239          Prev_Hi := Hi;
 240       end loop;
 241
 242       if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
 243          Issue_Msg (Hi + 1, Bounds_Hi);
 244       end if;
 245    end Check_Choices;
 246
 247    ------------------
 248    -- Choice_Image --
 249    ------------------
 250
 251    function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
 252       Rtp : constant Entity_Id := Root_Type (Ctype);
 253       Lit : Entity_Id;
 254       C   : Int;
 255
 256    begin
 257       --  For character, or wide character. If we are in 7-bit ASCII graphic
 258       --  range, then build and return appropriate character literal name
 259
 260       if Rtp = Standard_Character
 261         or else Rtp = Standard_Wide_Character
 262       then
 263          C := UI_To_Int (Value);
 264
 265          if C in 16#20# .. 16#7E# then
 266             Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
 267             return Name_Find;
 268          end if;
 269
 270       --  For user defined enumeration type, find enum/char literal
 271
 272       else
 273          Lit := First_Literal (Rtp);
 274
 275          for J in 1 .. UI_To_Int (Value) loop
 276             Next_Literal (Lit);
 277          end loop;
 278
 279          --  If enumeration literal, just return its value
 280
 281          if Nkind (Lit) = N_Defining_Identifier then
 282             return Chars (Lit);
 283
 284          --  For character literal, get the name and use it if it is
 285          --  for a 7-bit ASCII graphic character in 16#20#..16#7E#.
 286
 287          else
 288             Get_Decoded_Name_String (Chars (Lit));
 289
 290             if Name_Len = 3
 291               and then Name_Buffer (2) in
 292                 Character'Val (16#20#) .. Character'Val (16#7E#)
 293             then
 294                return Chars (Lit);
 295             end if;
 296          end if;
 297       end if;
 298
 299       --  If we fall through, we have a character literal which is not in
 300       --  the 7-bit ASCII graphic set. For such cases, we construct the
 301       --  name "type'val(nnn)" where type is the choice type, and nnn is
 302       --  the pos value passed as an argument to Choice_Image.
 303
 304       Get_Name_String (Chars (First_Subtype (Ctype)));
 305       Name_Len := Name_Len + 1;
 306       Name_Buffer (Name_Len) := ''';
 307       Name_Len := Name_Len + 1;
 308       Name_Buffer (Name_Len) := 'v';
 309       Name_Len := Name_Len + 1;
 310       Name_Buffer (Name_Len) := 'a';
 311       Name_Len := Name_Len + 1;
 312       Name_Buffer (Name_Len) := 'l';
 313       Name_Len := Name_Len + 1;
 314       Name_Buffer (Name_Len) := '(';
 315
 316       UI_Image (Value);
 317
 318       for J in 1 .. UI_Image_Length loop
 319          Name_Len := Name_Len + 1;
 320          Name_Buffer (Name_Len) := UI_Image_Buffer (J);
 321       end loop;
 322
 323       Name_Len := Name_Len + 1;
 324       Name_Buffer (Name_Len) := ')';
 325       return Name_Find;
 326    end Choice_Image;
 327
 328    -----------
 329    -- No_OP --
 330    -----------
 331
 332    procedure No_OP (C : Node_Id) is
 333       pragma Warnings (Off, C);
 334
 335    begin
 336       null;
 337    end No_OP;
 338
 339    --------------------------------
 340    -- Generic_Choices_Processing --
 341    --------------------------------
 342
 343    package body Generic_Choices_Processing is
 344
 345       ---------------------
 346       -- Analyze_Choices --
 347       ---------------------
 348
 349       procedure Analyze_Choices
 350         (N              : Node_Id;
 351          Subtyp         : Entity_Id;
 352          Choice_Table   : in out Choice_Table_Type;
 353          Last_Choice    : out Nat;
 354          Raises_CE      : out Boolean;
 355          Others_Present : out Boolean)
 356       is
 357
 358          Nb_Choices        : constant Nat := Choice_Table'Length;
 359          Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
 360
 361          Choice_Type : constant Entity_Id := Base_Type (Subtyp);
 362          --  The actual type against which the discrete choices are
 363          --  resolved.  Note that this type is always the base type not the
 364          --  subtype of the ruling expression, index or discriminant.
 365
 366          Bounds_Type : Entity_Id;
 367          --  The type from which are derived the bounds of the values
 368          --  covered by th discrete choices (see 3.8.1 (4)). If a discrete
 369          --  choice specifies a value outside of these bounds we have an error.
 370
 371          Bounds_Lo   : Uint;
 372          Bounds_Hi   : Uint;
 373          --  The actual bounds of the above type.
 374
 375          Expected_Type : Entity_Id;
 376          --  The expected type of each choice. Equal to Choice_Type, except
 377          --  if the expression is universal,  in which case the choices can
 378          --  be of any integer type.
 379
 380          procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
 381          --  Checks the validity of the bounds of a choice.  When the bounds
 382          --  are static and no error occurred the bounds are entered into
 383          --  the choices table so that they can be sorted later on.
 384
 385          -----------
 386          -- Check --
 387          -----------
 388
 389          procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
 390             Lo_Val : Uint;
 391             Hi_Val : Uint;
 392
 393          begin
 394             --  First check if an error was already detected on either bounds
 395
 396             if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
 397                return;
 398
 399             --  Do not insert non static choices in the table to be sorted
 400
 401             elsif not Is_Static_Expression (Lo)
 402               or else not Is_Static_Expression (Hi)
 403             then
 404                Process_Non_Static_Choice (Choice);
 405                return;
 406
 407             --  Ignore range which raise constraint error
 408
 409             elsif Raises_Constraint_Error (Lo)
 410               or else Raises_Constraint_Error (Hi)
 411             then
 412                Raises_CE := True;
 413                return;
 414
 415             --  Otherwise we have an OK static choice
 416
 417             else
 418                Lo_Val := Expr_Value (Lo);
 419                Hi_Val := Expr_Value (Hi);
 420
 421                --  Do not insert null ranges in the choices table
 422
 423                if Lo_Val > Hi_Val then
 424                   Process_Empty_Choice (Choice);
 425                   return;
 426                end if;
 427             end if;
 428
 429             --  Check for bound out of range.
 430
 431             if Lo_Val < Bounds_Lo then
 432                if Is_Integer_Type (Bounds_Type) then
 433                   Error_Msg_Uint_1 := Bounds_Lo;
 434                   Error_Msg_N ("minimum allowed choice value is^", Lo);
 435                else
 436                   Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
 437                   Error_Msg_N ("minimum allowed choice value is%", Lo);
 438                end if;
 439
 440             elsif Hi_Val > Bounds_Hi then
 441                if Is_Integer_Type (Bounds_Type) then
 442                   Error_Msg_Uint_1 := Bounds_Hi;
 443                   Error_Msg_N ("maximum allowed choice value is^", Hi);
 444                else
 445                   Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
 446                   Error_Msg_N ("maximum allowed choice value is%", Hi);
 447                end if;
 448             end if;
 449
 450             --  We still store the bounds in the table, even if they are out
 451             --  of range, since this may prevent unnecessary cascaded errors
 452             --  for values that are covered by such an excessive range.
 453
 454             Last_Choice := Last_Choice + 1;
 455             Sort_Choice_Table (Last_Choice).Lo   := Lo;
 456             Sort_Choice_Table (Last_Choice).Hi   := Hi;
 457             Sort_Choice_Table (Last_Choice).Node := Choice;
 458          end Check;
 459
 460          --  Variables local to Analyze_Choices
 461
 462          Alt : Node_Id;
 463          --  A case statement alternative, an array aggregate component
 464          --  association or a variant in a record type declaration
 465
 466          Choice : Node_Id;
 467          Kind   : Node_Kind;
 468          --  The node kind of the current Choice.
 469
 470          E : Entity_Id;
 471
 472       --  Start of processing for Analyze_Choices
 473
 474       begin
 475          Last_Choice    := 0;
 476          Raises_CE      := False;
 477          Others_Present := False;
 478
 479          --  If Subtyp is not a static subtype Ada 95 requires then we use
 480          --  the bounds of its base type to determine the values covered by
 481          --  the discrete choices.
 482
 483          if Is_OK_Static_Subtype (Subtyp) then
 484             Bounds_Type := Subtyp;
 485          else
 486             Bounds_Type := Choice_Type;
 487          end if;
 488
 489          --  Obtain static bounds of type, unless this is a generic formal
 490          --  discrete type for which all choices will be non-static.
 491
 492          if not Is_Generic_Type (Root_Type (Bounds_Type))
 493            or else Ekind (Bounds_Type) /= E_Enumeration_Type
 494          then
 495             Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
 496             Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
 497          end if;
 498
 499          if Choice_Type = Universal_Integer then
 500             Expected_Type := Any_Integer;
 501          else
 502             Expected_Type := Choice_Type;
 503          end if;
 504
 505          --  Now loop through the case statement alternatives or array
 506          --  aggregate component associations or record variants.
 507
 508          Alt := First (Get_Alternatives (N));
 509          while Present (Alt) loop
 510
 511             --  If pragma, just analyze it
 512
 513             if Nkind (Alt) = N_Pragma then
 514                Analyze (Alt);
 515
 516             --  Otherwise check each choice against its base type
 517
 518             else
 519                Choice := First (Get_Choices (Alt));
 520
 521                while Present (Choice) loop
 522                   Analyze (Choice);
 523                   Kind := Nkind (Choice);
 524
 525                   --  Choice is a Range
 526
 527                   if Kind = N_Range
 528                     or else (Kind = N_Attribute_Reference
 529                              and then Attribute_Name (Choice) = Name_Range)
 530                   then
 531                      Resolve (Choice, Expected_Type);
 532                      Check (Choice, Low_Bound (Choice), High_Bound (Choice));
 533
 534                   --  Choice is a subtype name
 535
 536                   elsif Is_Entity_Name (Choice)
 537                     and then Is_Type (Entity (Choice))
 538                   then
 539                      if not Covers (Expected_Type, Etype (Choice)) then
 540                         Wrong_Type (Choice, Choice_Type);
 541
 542                      else
 543                         E := Entity (Choice);
 544
 545                         if not Is_Static_Subtype (E) then
 546                            Process_Non_Static_Choice (Choice);
 547                         else
 548                            Check
 549                              (Choice, Type_Low_Bound (E), Type_High_Bound (E));
 550                         end if;
 551                      end if;
 552
 553                   --  Choice is a subtype indication
 554
 555                   elsif Kind = N_Subtype_Indication then
 556                      Resolve_Discrete_Subtype_Indication
 557                        (Choice, Expected_Type);
 558
 559                      if Etype (Choice) /= Any_Type then
 560                         declare
 561                            C : constant Node_Id := Constraint (Choice);
 562                            R : constant Node_Id := Range_Expression (C);
 563                            L : constant Node_Id := Low_Bound (R);
 564                            H : constant Node_Id := High_Bound (R);
 565
 566                         begin
 567                            E := Entity (Subtype_Mark (Choice));
 568
 569                            if not Is_Static_Subtype (E) then
 570                               Process_Non_Static_Choice (Choice);
 571
 572                            else
 573                               if Is_OK_Static_Expression (L)
 574                                 and then Is_OK_Static_Expression (H)
 575                               then
 576                                  if Expr_Value (L) > Expr_Value (H) then
 577                                     Process_Empty_Choice (Choice);
 578                                  else
 579                                     if Is_Out_Of_Range (L, E) then
 580                                        Apply_Compile_Time_Constraint_Error
 581                                          (L, "static value out of range",
 582                                           CE_Range_Check_Failed);
 583                                     end if;
 584
 585                                     if Is_Out_Of_Range (H, E) then
 586                                        Apply_Compile_Time_Constraint_Error
 587                                          (H, "static value out of range",
 588                                           CE_Range_Check_Failed);
 589                                     end if;
 590                                  end if;
 591                               end if;
 592
 593                               Check (Choice, L, H);
 594                            end if;
 595                         end;
 596                      end if;
 597
 598                   --  The others choice is only allowed for the last
 599                   --  alternative and as its only choice.
 600
 601                   elsif Kind = N_Others_Choice then
 602                      if not (Choice = First (Get_Choices (Alt))
 603                              and then Choice = Last (Get_Choices (Alt))
 604                              and then Alt = Last (Get_Alternatives (N)))
 605                      then
 606                         Error_Msg_N
 607                           ("the choice OTHERS must appear alone and last",
 608                            Choice);
 609                         return;
 610                      end if;
 611
 612                      Others_Present := True;
 613
 614                   --  Only other possibility is an expression
 615
 616                   else
 617                      Resolve (Choice, Expected_Type);
 618                      Check (Choice, Choice, Choice);
 619                   end if;
 620
 621                   Next (Choice);
 622                end loop;
 623
 624                Process_Associated_Node (Alt);
 625             end if;
 626
 627             Next (Alt);
 628          end loop;
 629
 630          Check_Choices
 631            (Sort_Choice_Table (0 .. Last_Choice),
 632             Bounds_Type,
 633             Others_Present or else (Choice_Type = Universal_Integer),
 634             Sloc (N));
 635
 636          --  Now copy the sorted discrete choices
 637
 638          for J in 1 .. Last_Choice loop
 639             Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
 640          end loop;
 641
 642       end Analyze_Choices;
 643
 644       -----------------------
 645       -- Number_Of_Choices --
 646       -----------------------
 647
 648       function Number_Of_Choices (N : Node_Id) return Nat is
 649          Alt : Node_Id;
 650          --  A case statement alternative, an array aggregate component
 651          --  association or a record variant.
 652
 653          Choice : Node_Id;
 654          Count  : Nat := 0;
 655
 656       begin
 657          if not Present (Get_Alternatives (N)) then
 658             return 0;
 659          end if;
 660
 661          Alt := First_Non_Pragma (Get_Alternatives (N));
 662          while Present (Alt) loop
 663
 664             Choice := First (Get_Choices (Alt));
 665             while Present (Choice) loop
 666                if Nkind (Choice) /= N_Others_Choice then
 667                   Count := Count + 1;
 668                end if;
 669
 670                Next (Choice);
 671             end loop;
 672
 673             Next_Non_Pragma (Alt);
 674          end loop;
 675
 676          return Count;
 677       end Number_Of_Choices;
 678
 679    end Generic_Choices_Processing;
 680
 681 end Sem_Case;