1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2021, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Einfo
.Entities
; use Einfo
.Entities
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Namet
; use Namet
;
33 with Nlists
; use Nlists
;
34 with Nmake
; use Nmake
;
37 with Sem_Aux
; use Sem_Aux
;
38 with Sem_Eval
; use Sem_Eval
;
39 with Sem_Res
; use Sem_Res
;
40 with Sem_Util
; use Sem_Util
;
41 with Sem_Type
; use Sem_Type
;
42 with Snames
; use Snames
;
43 with Stand
; use Stand
;
44 with Sinfo
; use Sinfo
;
45 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
46 with Sinfo
.Utils
; use Sinfo
.Utils
;
47 with Stringt
; use Stringt
;
49 with Tbuild
; use Tbuild
;
50 with Uintp
; use Uintp
;
52 with Ada
.Unchecked_Deallocation
;
54 with GNAT
.Heap_Sort_G
;
57 package body Sem_Case
is
59 type Choice_Bounds
is record
64 -- Represent one choice bounds entry with Lo and Hi values, Node points
65 -- to the choice node itself.
67 type Choice_Table_Type
is array (Nat
range <>) of Choice_Bounds
;
68 -- Table type used to sort the choices present in a case statement or
69 -- record variant. The actual entries are stored in 1 .. Last, but we
70 -- have a 0 entry for use in sorting.
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 procedure Check_Choice_Set
77 (Choice_Table
: in out Choice_Table_Type
;
78 Bounds_Type
: Entity_Id
;
80 Others_Present
: Boolean;
82 -- This is the procedure which verifies that a set of case alternatives
83 -- or record variant choices has no duplicates, and covers the range
84 -- specified by Bounds_Type. Choice_Table contains the discrete choices
85 -- to check. These must start at position 1.
87 -- Furthermore Choice_Table (0) must exist. This element is used by
88 -- the sorting algorithm as a temporary. Others_Present is a flag
89 -- indicating whether or not an Others choice is present. Finally
90 -- Msg_Sloc gives the source location of the construct containing the
91 -- choices in the Choice_Table.
93 -- Bounds_Type is the type whose range must be covered by the alternatives
95 -- Subtyp is the subtype of the expression. If its bounds are nonstatic
96 -- the alternatives must cover its base type.
98 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
;
99 -- Given a Pos value of enumeration type Ctype, returns the name
100 -- ID of an appropriate string to be used in error message output.
102 function Has_Static_Discriminant_Constraint
103 (Subtyp
: Entity_Id
) return Boolean;
104 -- Returns True if the given subtype is subject to a discriminant
105 -- constraint and at least one of the constraint values is nonstatic.
107 package Composite_Case_Ops
is
109 function Box_Value_Required
(Subtyp
: Entity_Id
) return Boolean;
110 -- If result is True, then the only allowed value (in a choice
111 -- aggregate) for a component of this (sub)type is a box. This rule
112 -- means that such a component can be ignored in case alternative
113 -- selection. This in turn implies that it is ok if the component
114 -- type doesn't meet the usual restrictions, such as not being an
115 -- access/task/protected type, since nobody is going to look
118 function Choice_Count
(Alternatives
: List_Id
) return Nat
;
119 -- The sum of the number of choices for each alternative in the given
122 function Normalized_Case_Expr_Type
123 (Case_Statement
: Node_Id
) return Entity_Id
;
124 -- Usually returns the Etype of the selector expression of the
125 -- case statement. However, in the case of a constrained composite
126 -- subtype with a nonstatic constraint, returns the unconstrained
129 function Scalar_Part_Count
(Subtyp
: Entity_Id
) return Nat
;
130 -- Given the composite type Subtyp of a case selector, returns the
131 -- number of scalar parts in an object of this type. This is the
132 -- dimensionality of the associated Cartesian product space.
134 package Array_Case_Ops
is
135 function Array_Choice_Length
(Choice
: Node_Id
) return Nat
;
136 -- Given a choice expression of an array type, returns its length.
138 function Unconstrained_Array_Effective_Length
139 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
;
140 -- If the nominal subtype of the case selector is unconstrained,
141 -- then use the length of the longest choice of the case statement.
142 -- Components beyond that index value will not influence the case
143 -- selection decision.
145 function Unconstrained_Array_Scalar_Part_Count
146 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
;
147 -- Same as Scalar_Part_Count except that the value used for the
148 -- "length" of the array subtype being cased on is determined by
149 -- calling Unconstrained_Array_Effective_Length.
153 Case_Statement
: Node_Id
;
154 package Choice_Analysis
is
158 type Alternative_Id
is
159 new Int
range 1 .. List_Length
(Alternatives
(Case_Statement
));
161 new Int
range 1 .. Choice_Count
(Alternatives
(Case_Statement
));
163 Case_Expr_Type
: constant Entity_Id
:=
164 Normalized_Case_Expr_Type
(Case_Statement
);
166 Unconstrained_Array_Case
: constant Boolean :=
167 Is_Array_Type
(Case_Expr_Type
)
168 and then not Is_Constrained
(Case_Expr_Type
);
170 -- If Unconstrained_Array_Case is True, choice lengths may differ:
171 -- when "Aaa" | "Bb" | "C" | "" =>
173 -- Strictly speaking, the name "Unconstrained_Array_Case" is
174 -- slightly imprecise; a subtype with a nonstatic constraint is
175 -- also treated as unconstrained (see Normalize_Case_Expr_Type).
177 type Part_Id
is new Int
range
178 1 .. (if Unconstrained_Array_Case
179 then Unconstrained_Array_Scalar_Part_Count
180 (Case_Expr_Type
, Case_Statement
)
181 else Scalar_Part_Count
(Case_Expr_Type
));
183 type Discrete_Range_Info
is
188 type Composite_Range_Info
is array (Part_Id
) of Discrete_Range_Info
;
190 type Choice_Range_Info
(Is_Others
: Boolean := False) is
194 Ranges
: Composite_Range_Info
;
200 type Choices_Range_Info
is array (Choice_Id
) of Choice_Range_Info
;
202 package Value_Sets
is
204 type Value_Set
is private;
205 -- A set of points in the Cartesian product space defined
206 -- by the composite type of the case selector.
207 -- Implemented as an access type.
209 type Set_Comparison
is
210 (Disjoint
, Equal
, Contains
, Contained_By
, Overlaps
);
212 function Compare
(S1
, S2
: Value_Set
) return Set_Comparison
;
213 -- If either argument (or both) is empty, result is Disjoint.
214 -- Otherwise, result is Equal if the two sets are equal.
216 Empty
: constant Value_Set
;
218 function Matching_Values
219 (Info
: Composite_Range_Info
) return Value_Set
;
220 -- The Cartesian product of the given array of ranges
221 -- (excluding any values outside the Cartesian product of the
222 -- component ranges).
224 procedure Union
(Target
: in out Value_Set
; Source
: Value_Set
);
225 -- Add elements of Source into Target
227 procedure Remove
(Target
: in out Value_Set
; Source
: Value_Set
);
228 -- Remove elements of Source from Target
230 function Complement_Is_Empty
(Set
: Value_Set
) return Boolean;
231 -- Return True iff the set is "maximal", in the sense that it
232 -- includes every value in the Cartesian product of the
235 procedure Free_Value_Sets
;
236 -- Reclaim storage associated with implementation of this package.
239 type Value_Set
is new Natural;
240 -- An index for a table that will be declared in the package body.
242 Empty
: constant Value_Set
:= 0;
246 type Single_Choice_Info
(Is_Others
: Boolean := False) is
248 Alternative
: Alternative_Id
;
251 Matches
: Value_Sets
.Value_Set
;
257 type Choices_Info
is array (Choice_Id
) of Single_Choice_Info
;
259 function Analysis
return Choices_Info
;
260 -- Parse the case choices in order to determine the set of
261 -- matching values associated with each choice.
263 type Bound_Values
is array (Positive range <>) of Node_Id
;
267 end Composite_Case_Ops
;
269 procedure Expand_Others_Choice
270 (Case_Table
: Choice_Table_Type
;
271 Others_Choice
: Node_Id
;
272 Choice_Type
: Entity_Id
);
273 -- The case table is the table generated by a call to Check_Choices
274 -- (with just 1 .. Last_Choice entries present). Others_Choice is a
275 -- pointer to the N_Others_Choice node (this routine is only called if
276 -- an others choice is present), and Choice_Type is the discrete type
277 -- of the bounds. The effect of this call is to analyze the cases and
278 -- determine the set of values covered by others. This choice list is
279 -- set in the Others_Discrete_Choices field of the N_Others_Choice node.
281 ----------------------
282 -- Check_Choice_Set --
283 ----------------------
285 procedure Check_Choice_Set
286 (Choice_Table
: in out Choice_Table_Type
;
287 Bounds_Type
: Entity_Id
;
289 Others_Present
: Boolean;
292 Predicate_Error
: Boolean := False;
293 -- Flag to prevent cascaded errors when a static predicate is known to
294 -- be violated by one choice.
296 Num_Choices
: constant Nat
:= Choice_Table
'Last;
298 procedure Check_Against_Predicate
299 (Pred
: in out Node_Id
;
300 Choice
: Choice_Bounds
;
301 Prev_Lo
: in out Uint
;
302 Prev_Hi
: in out Uint
;
303 Error
: in out Boolean);
304 -- Determine whether a choice covers legal values as defined by a static
305 -- predicate set. Pred is a static predicate range. Choice is the choice
306 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
307 -- choice that covered a predicate set. Error denotes whether the check
308 -- found an illegal intersection.
310 procedure Check_Duplicates
;
311 -- Check for duplicate choices, and call Dup_Choice if there are any
312 -- such errors. Note that predicates are irrelevant here.
314 procedure Dup_Choice
(Lo
, Hi
: Uint
; C
: Node_Id
);
315 -- Post message "duplication of choice value(s) bla bla at xx". Message
316 -- is posted at location C. Caller sets Error_Msg_Sloc for xx.
318 procedure Explain_Non_Static_Bound
;
319 -- Called when we find a nonstatic bound, requiring the base type to
320 -- be covered. Provides where possible a helpful explanation of why the
321 -- bounds are nonstatic, since this is not always obvious.
323 function Lt_Choice
(C1
, C2
: Natural) return Boolean;
324 -- Comparison routine for comparing Choice_Table entries. Use the lower
325 -- bound of each Choice as the key.
327 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
);
328 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
);
329 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
);
330 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
);
331 -- Issue an error message indicating that there are missing choices,
332 -- followed by the image of the missing choices themselves which lie
333 -- between Value1 and Value2 inclusive.
335 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
);
336 -- Emit an error message for each non-covered static predicate set.
337 -- Prev_Hi denotes the upper bound of the last choice covering a set.
339 procedure Move_Choice
(From
: Natural; To
: Natural);
340 -- Move routine for sorting the Choice_Table
342 package Sorting
is new GNAT
.Heap_Sort_G
(Move_Choice
, Lt_Choice
);
344 -----------------------------
345 -- Check_Against_Predicate --
346 -----------------------------
348 procedure Check_Against_Predicate
349 (Pred
: in out Node_Id
;
350 Choice
: Choice_Bounds
;
351 Prev_Lo
: in out Uint
;
352 Prev_Hi
: in out Uint
;
353 Error
: in out Boolean)
355 procedure Illegal_Range
359 -- Emit an error message regarding a choice that clashes with the
360 -- legal static predicate sets. Loc is the location of the choice
361 -- that introduced the illegal range. Lo .. Hi is the range.
363 function Inside_Range
366 Val
: Uint
) return Boolean;
367 -- Determine whether position Val within a discrete type is within
368 -- the range Lo .. Hi inclusive.
374 procedure Illegal_Range
380 Error_Msg_Name_1
:= Chars
(Bounds_Type
);
385 if Is_Integer_Type
(Bounds_Type
) then
386 Error_Msg_Uint_1
:= Lo
;
387 Error_Msg
("static predicate on % excludes value ^!", Loc
);
389 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
390 Error_Msg
("static predicate on % excludes value %!", Loc
);
396 if Is_Integer_Type
(Bounds_Type
) then
397 Error_Msg_Uint_1
:= Lo
;
398 Error_Msg_Uint_2
:= Hi
;
400 ("static predicate on % excludes range ^ .. ^!", Loc
);
402 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
403 Error_Msg_Name_3
:= Choice_Image
(Hi
, Bounds_Type
);
405 ("static predicate on % excludes range % .. %!", Loc
);
414 function Inside_Range
417 Val
: Uint
) return Boolean
420 return Lo
<= Val
and then Val
<= Hi
;
425 Choice_Hi
: constant Uint
:= Expr_Value
(Choice
.Hi
);
426 Choice_Lo
: constant Uint
:= Expr_Value
(Choice
.Lo
);
434 -- Start of processing for Check_Against_Predicate
437 -- Find the proper error message location
439 if Present
(Choice
.Node
) then
447 if Present
(Pred
) then
448 Pred_Lo
:= Expr_Value
(Low_Bound
(Pred
));
449 Pred_Hi
:= Expr_Value
(High_Bound
(Pred
));
451 -- Previous choices managed to satisfy all static predicate sets
454 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
459 -- Step 1: Ignore duplicate choices, other than to set the flag,
460 -- because these were already detected by Check_Duplicates.
462 if Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Lo
)
463 or else Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Hi
)
467 -- Step 2: Detect full coverage
469 -- Choice_Lo Choice_Hi
473 elsif Choice_Lo
= Pred_Lo
and then Choice_Hi
= Pred_Hi
then
474 Prev_Lo
:= Choice_Lo
;
475 Prev_Hi
:= Choice_Hi
;
478 -- Step 3: Detect all cases where a choice mentions values that are
479 -- not part of the static predicate sets.
481 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
482 -- +-----------+ . . . . . +=========+
485 elsif Choice_Lo
< Pred_Lo
and then Choice_Hi
< Pred_Lo
then
486 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
489 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
490 -- +-----------+=========+===========+
493 elsif Choice_Lo
< Pred_Lo
494 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Hi
)
496 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
499 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
500 -- +=========+ . . . . +-----------+
503 elsif Pred_Lo
< Choice_Lo
and then Pred_Hi
< Choice_Lo
then
504 if Others_Present
then
506 -- Current predicate set is covered by others clause.
511 Missing_Choice
(Pred_Lo
, Pred_Hi
);
515 -- There may be several static predicate sets between the current
516 -- one and the choice. Inspect the next static predicate set.
519 Check_Against_Predicate
526 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
527 -- +=========+===========+-----------+
530 elsif Pred_Hi
< Choice_Hi
531 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Lo
)
535 -- The choice may fall in a static predicate set. If this is the
536 -- case, avoid mentioning legal values in the error message.
538 if Present
(Pred
) then
539 Next_Lo
:= Expr_Value
(Low_Bound
(Pred
));
540 Next_Hi
:= Expr_Value
(High_Bound
(Pred
));
542 -- The next static predicate set is to the right of the choice
544 if Choice_Hi
< Next_Lo
and then Choice_Hi
< Next_Hi
then
545 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
547 Illegal_Range
(Loc
, Pred_Hi
+ 1, Next_Lo
- 1);
550 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
555 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
556 -- +-----------+=========+-----------+
557 -- ^ illegal ^ ^ illegal ^
559 -- Emit an error on the low gap, disregard the upper gap
561 elsif Choice_Lo
< Pred_Lo
and then Pred_Hi
< Choice_Hi
then
562 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
565 -- Step 4: Detect all cases of partial or missing coverage
567 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
568 -- +=========+==========+===========+
572 -- An "others" choice covers all gaps
574 if Others_Present
then
575 Prev_Lo
:= Choice_Lo
;
576 Prev_Hi
:= Choice_Hi
;
578 -- Check whether predicate set is fully covered by choice
580 if Pred_Hi
= Choice_Hi
then
584 -- Choice_Lo Choice_Hi Pred_Hi
585 -- +===========+===========+
588 -- The upper gap may be covered by a subsequent choice
590 elsif Pred_Lo
= Choice_Lo
then
591 Prev_Lo
:= Choice_Lo
;
592 Prev_Hi
:= Choice_Hi
;
594 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
595 -- +===========+=========+===========+===========+
596 -- ^ covered ^ ^ gap ^
598 else pragma Assert
(Pred_Lo
< Choice_Lo
);
600 -- A previous choice covered the gap up to the current choice
602 if Prev_Hi
= Choice_Lo
- 1 then
603 Prev_Lo
:= Choice_Lo
;
604 Prev_Hi
:= Choice_Hi
;
606 if Choice_Hi
= Pred_Hi
then
610 -- The previous choice did not intersect with the current
611 -- static predicate set.
613 elsif Prev_Hi
< Pred_Lo
then
614 Missing_Choice
(Pred_Lo
, Choice_Lo
- 1);
617 -- The previous choice covered part of the static predicate set
618 -- but there is a gap after Prev_Hi.
621 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
626 end Check_Against_Predicate
;
628 ----------------------
629 -- Check_Duplicates --
630 ----------------------
632 procedure Check_Duplicates
is
636 Prev_Choice
: Node_Id
:= Empty
;
640 Prev_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
642 for Outer_Index
in 2 .. Num_Choices
loop
643 Choice_Lo
:= Expr_Value
(Choice_Table
(Outer_Index
).Lo
);
644 Choice_Hi
:= Expr_Value
(Choice_Table
(Outer_Index
).Hi
);
646 -- Choices overlap; this is an error
648 if Choice_Lo
<= Prev_Hi
then
649 Choice
:= Choice_Table
(Outer_Index
).Node
;
651 -- Find first previous choice that overlaps
653 for Inner_Index
in 1 .. Outer_Index
- 1 loop
655 Expr_Value
(Choice_Table
(Inner_Index
).Hi
)
657 Prev_Choice
:= Choice_Table
(Inner_Index
).Node
;
662 pragma Assert
(Present
(Prev_Choice
));
664 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
665 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
666 Dup_Choice
(Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Choice
);
668 Error_Msg_Sloc
:= Sloc
(Choice
);
670 (Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Prev_Choice
);
674 if Choice_Hi
> Prev_Hi
then
675 Prev_Hi
:= Choice_Hi
;
678 end Check_Duplicates
;
684 procedure Dup_Choice
(Lo
, Hi
: Uint
; C
: Node_Id
) is
686 -- In some situations, we call this with a null range, and obviously
687 -- we don't want to complain in this case.
693 -- Case of only one value that is duplicated
699 if Is_Integer_Type
(Bounds_Type
) then
701 -- We have an integer value, Lo, but if the given choice
702 -- placement is a constant with that value, then use the
703 -- name of that constant instead in the message:
705 if Nkind
(C
) = N_Identifier
706 and then Compile_Time_Known_Value
(C
)
707 and then Expr_Value
(C
) = Lo
710 ("duplication of choice value: &#!", Original_Node
(C
));
712 -- Not that special case, so just output the integer value
715 Error_Msg_Uint_1
:= Lo
;
717 ("duplication of choice value: ^#!", Original_Node
(C
));
723 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
725 ("duplication of choice value: %#!", Original_Node
(C
));
728 -- More than one choice value, so print range of values
733 if Is_Integer_Type
(Bounds_Type
) then
735 -- Similar to the above, if C is a range of known values which
736 -- match Lo and Hi, then use the names. We have to go to the
737 -- original nodes, since the values will have been rewritten
738 -- to their integer values.
740 if Nkind
(C
) = N_Range
741 and then Nkind
(Original_Node
(Low_Bound
(C
))) = N_Identifier
742 and then Nkind
(Original_Node
(High_Bound
(C
))) = N_Identifier
743 and then Compile_Time_Known_Value
(Low_Bound
(C
))
744 and then Compile_Time_Known_Value
(High_Bound
(C
))
745 and then Expr_Value
(Low_Bound
(C
)) = Lo
746 and then Expr_Value
(High_Bound
(C
)) = Hi
748 Error_Msg_Node_2
:= Original_Node
(High_Bound
(C
));
750 ("duplication of choice values: & .. &#!",
751 Original_Node
(Low_Bound
(C
)));
753 -- Not that special case, output integer values
756 Error_Msg_Uint_1
:= Lo
;
757 Error_Msg_Uint_2
:= Hi
;
759 ("duplication of choice values: ^ .. ^#!",
766 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
767 Error_Msg_Name_2
:= Choice_Image
(Hi
, Bounds_Type
);
769 ("duplication of choice values: % .. %#!", Original_Node
(C
));
774 ------------------------------
775 -- Explain_Non_Static_Bound --
776 ------------------------------
778 procedure Explain_Non_Static_Bound
is
782 if Nkind
(Case_Node
) = N_Variant_Part
then
783 Expr
:= Name
(Case_Node
);
785 Expr
:= Expression
(Case_Node
);
788 if Bounds_Type
/= Subtyp
then
790 -- If the case is a variant part, the expression is given by the
791 -- discriminant itself, and the bounds are the culprits.
793 if Nkind
(Case_Node
) = N_Variant_Part
then
795 ("bounds of & are not static, "
796 & "alternatives must cover base type!", Expr
, Expr
);
798 -- If this is a case statement, the expression may be nonstatic
799 -- or else the subtype may be at fault.
801 elsif Is_Entity_Name
(Expr
) then
803 ("bounds of & are not static, "
804 & "alternatives must cover base type!", Expr
, Expr
);
808 ("subtype of expression is not static, "
809 & "alternatives must cover base type!", Expr
);
812 -- Otherwise the expression is not static, even if the bounds of the
813 -- type are, or else there are missing alternatives. If both, the
814 -- additional information may be redundant but harmless. Examine
815 -- whether original node is an entity, because it may have been
816 -- constant-folded to a literal if value is known.
818 elsif not Is_Entity_Name
(Original_Node
(Expr
)) then
820 ("subtype of expression is not static, "
821 & "alternatives must cover base type!", Expr
);
823 end Explain_Non_Static_Bound
;
829 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
832 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
834 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
841 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
) is
843 Missing_Choice
(Expr_Value
(Value1
), Expr_Value
(Value2
));
846 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
) is
848 Missing_Choice
(Expr_Value
(Value1
), Value2
);
851 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
) is
853 Missing_Choice
(Value1
, Expr_Value
(Value2
));
860 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
) is
862 -- AI05-0188 : within an instance the non-others choices do not have
863 -- to belong to the actual subtype.
865 if Ada_Version
>= Ada_2012
and then In_Instance
then
868 -- In some situations, we call this with a null range, and obviously
869 -- we don't want to complain in this case.
871 elsif Value1
> Value2
then
874 -- If predicate is already known to be violated, do not check for
875 -- coverage error, to prevent cascaded messages.
877 elsif Predicate_Error
then
881 -- Case of only one value that is missing
883 if Value1
= Value2
then
884 if Is_Integer_Type
(Bounds_Type
) then
885 Error_Msg_Uint_1
:= Value1
;
886 Error_Msg_N
("missing case value: ^!", Case_Node
);
888 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
889 Error_Msg_N
("missing case value: %!", Case_Node
);
892 -- More than one choice value, so print range of values
895 if Is_Integer_Type
(Bounds_Type
) then
896 Error_Msg_Uint_1
:= Value1
;
897 Error_Msg_Uint_2
:= Value2
;
898 Error_Msg_N
("missing case values: ^ .. ^!", Case_Node
);
900 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
901 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
902 Error_Msg_N
("missing case values: % .. %!", Case_Node
);
907 ---------------------
908 -- Missing_Choices --
909 ---------------------
911 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
) is
918 while Present
(Set
) loop
919 Lo
:= Expr_Value
(Low_Bound
(Set
));
920 Hi
:= Expr_Value
(High_Bound
(Set
));
922 -- A choice covered part of a static predicate set
924 if Lo
<= Prev_Hi
and then Prev_Hi
< Hi
then
925 Missing_Choice
(Prev_Hi
+ 1, Hi
);
928 Missing_Choice
(Lo
, Hi
);
939 procedure Move_Choice
(From
: Natural; To
: Natural) is
941 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
946 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
947 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
948 Has_Predicate
: constant Boolean :=
949 Is_OK_Static_Subtype
(Bounds_Type
)
950 and then Has_Static_Predicate
(Bounds_Type
);
958 -- Start of processing for Check_Choice_Set
961 -- If the case is part of a predicate aspect specification, do not
962 -- recheck it against itself.
964 if Present
(Parent
(Case_Node
))
965 and then Nkind
(Parent
(Case_Node
)) = N_Aspect_Specification
970 -- Choice_Table must start at 0 which is an unused location used by the
971 -- sorting algorithm. However the first valid position for a discrete
974 pragma Assert
(Choice_Table
'First = 0);
976 -- The choices do not cover the base range. Emit an error if "others" is
977 -- not available and return as there is no need for further processing.
979 if Num_Choices
= 0 then
980 if not Others_Present
then
981 Missing_Choice
(Bounds_Lo
, Bounds_Hi
);
987 Sorting
.Sort
(Positive (Choice_Table
'Last));
989 -- First check for duplicates. This involved the choices; predicates, if
990 -- any, are irrelevant.
994 -- Then check for overlaps
996 -- If the subtype has a static predicate, the predicate defines subsets
997 -- of legal values and requires finer-grained analysis.
999 -- Note that in GNAT the predicate is considered static if the predicate
1000 -- expression is static, independently of whether the aspect mentions
1001 -- Static explicitly.
1003 if Has_Predicate
then
1004 Pred
:= First
(Static_Discrete_Predicate
(Bounds_Type
));
1006 -- Make initial value smaller than 'First of type, so that first
1007 -- range comparison succeeds. This applies both to integer types
1008 -- and to enumeration types.
1010 Prev_Lo
:= Expr_Value
(Type_Low_Bound
(Bounds_Type
)) - 1;
1014 Error
: Boolean := False;
1016 for Index
in 1 .. Num_Choices
loop
1017 Check_Against_Predicate
1019 Choice
=> Choice_Table
(Index
),
1024 -- The analysis detected an illegal intersection between a
1025 -- choice and a static predicate set. Do not examine other
1026 -- choices unless all errors are requested.
1029 Predicate_Error
:= True;
1031 if not All_Errors_Mode
then
1038 if Predicate_Error
then
1042 -- The choices may legally cover some of the static predicate sets,
1043 -- but not all. Emit an error for each non-covered set.
1045 if not Others_Present
then
1046 Missing_Choices
(Pred
, Prev_Hi
);
1052 Choice_Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
1053 Choice_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
1054 Prev_Hi
:= Choice_Hi
;
1056 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Choice_Lo
then
1057 Missing_Choice
(Bounds_Lo
, Choice_Lo
- 1);
1059 -- If values are missing outside of the subtype, add explanation.
1060 -- No additional message if only one value is missing.
1062 if Expr_Value
(Bounds_Lo
) < Choice_Lo
- 1 then
1063 Explain_Non_Static_Bound
;
1067 for Index
in 2 .. Num_Choices
loop
1068 Choice_Lo
:= Expr_Value
(Choice_Table
(Index
).Lo
);
1069 Choice_Hi
:= Expr_Value
(Choice_Table
(Index
).Hi
);
1071 if Choice_Lo
> Prev_Hi
+ 1 and then not Others_Present
then
1072 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
1075 if Choice_Hi
> Prev_Hi
then
1076 Prev_Hi
:= Choice_Hi
;
1080 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Prev_Hi
then
1081 Missing_Choice
(Prev_Hi
+ 1, Bounds_Hi
);
1083 if Expr_Value
(Bounds_Hi
) > Prev_Hi
+ 1 then
1084 Explain_Non_Static_Bound
;
1088 end Check_Choice_Set
;
1094 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
1095 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
1100 -- For character, or wide [wide] character. If 7-bit ASCII graphic
1101 -- range, then build and return appropriate character literal name
1103 if Is_Standard_Character_Type
(Ctype
) then
1104 C
:= UI_To_Int
(Value
);
1106 if C
in 16#
20#
.. 16#
7E#
then
1107 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
1111 -- For user defined enumeration type, find enum/char literal
1114 Lit
:= First_Literal
(Rtp
);
1116 for J
in 1 .. UI_To_Int
(Value
) loop
1120 -- If enumeration literal, just return its value
1122 if Nkind
(Lit
) = N_Defining_Identifier
then
1125 -- For character literal, get the name and use it if it is
1126 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
1129 Get_Decoded_Name_String
(Chars
(Lit
));
1132 and then Name_Buffer
(2) in
1133 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
1140 -- If we fall through, we have a character literal which is not in
1141 -- the 7-bit ASCII graphic set. For such cases, we construct the
1142 -- name "type'val(nnn)" where type is the choice type, and nnn is
1143 -- the pos value passed as an argument to Choice_Image.
1145 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
1147 Add_Str_To_Name_Buffer
("'val(");
1149 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
1150 Add_Char_To_Name_Buffer
(')');
1154 package body Composite_Case_Ops
is
1156 function Static_Array_Length
(Subtyp
: Entity_Id
) return Nat
;
1157 -- Given a one-dimensional constrained array subtype with
1158 -- statically known bounds, return its length.
1160 -------------------------
1161 -- Static_Array_Length --
1162 -------------------------
1164 function Static_Array_Length
(Subtyp
: Entity_Id
) return Nat
is
1165 pragma Assert
(Is_Constrained
(Subtyp
));
1166 pragma Assert
(Number_Dimensions
(Subtyp
) = 1);
1167 Index
: constant Node_Id
:= First_Index
(Subtyp
);
1168 pragma Assert
(Is_OK_Static_Range
(Index
));
1169 Lo
: constant Uint
:= Expr_Value
(Low_Bound
(Index
));
1170 Hi
: constant Uint
:= Expr_Value
(High_Bound
(Index
));
1171 Len
: constant Uint
:= UI_Max
(0, (Hi
- Lo
) + 1);
1173 return UI_To_Int
(Len
);
1174 end Static_Array_Length
;
1176 ------------------------
1177 -- Box_Value_Required --
1178 ------------------------
1180 function Box_Value_Required
(Subtyp
: Entity_Id
) return Boolean is
1181 -- Some of these restrictions will be relaxed eventually, but best
1182 -- to initially err in the direction of being too restrictive.
1184 if Has_Predicates
(Subtyp
) then
1186 elsif Is_Discrete_Type
(Subtyp
) then
1187 if not Is_Static_Subtype
(Subtyp
) then
1189 elsif Is_Enumeration_Type
(Subtyp
)
1190 and then Has_Enumeration_Rep_Clause
(Subtyp
)
1191 -- Maybe enumeration rep clauses can be ignored here?
1195 elsif Is_Array_Type
(Subtyp
) then
1196 if Number_Dimensions
(Subtyp
) /= 1 then
1198 elsif not Is_Constrained
(Subtyp
) then
1199 if not Is_Static_Subtype
(Etype
(First_Index
(Subtyp
))) then
1202 elsif not Is_OK_Static_Range
(First_Index
(Subtyp
)) then
1205 elsif Is_Record_Type
(Subtyp
) then
1206 if Has_Discriminants
(Subtyp
)
1207 and then Is_Constrained
(Subtyp
)
1208 and then not Has_Static_Discriminant_Constraint
(Subtyp
)
1210 -- Perhaps treat differently the case where Subtyp is the
1211 -- subtype of the top-level selector expression, as opposed
1212 -- to the subtype of some subcomponent thereof.
1216 -- Return True for any type that is not a discrete type,
1217 -- a record type, or an array type.
1222 end Box_Value_Required
;
1228 function Choice_Count
(Alternatives
: List_Id
) return Nat
is
1230 Alt
: Node_Id
:= First
(Alternatives
);
1232 while Present
(Alt
) loop
1233 Result
:= Result
+ List_Length
(Discrete_Choices
(Alt
));
1239 -------------------------------
1240 -- Normalized_Case_Expr_Type --
1241 -------------------------------
1243 function Normalized_Case_Expr_Type
1244 (Case_Statement
: Node_Id
) return Entity_Id
1246 Unnormalized
: constant Entity_Id
:=
1247 Etype
(Expression
(Case_Statement
));
1249 Is_Dynamically_Constrained_Array
: constant Boolean :=
1250 Is_Array_Type
(Unnormalized
)
1251 and then Is_Constrained
(Unnormalized
)
1252 and then not Has_Static_Array_Bounds
(Unnormalized
);
1254 Is_Dynamically_Constrained_Record
: constant Boolean :=
1255 Is_Record_Type
(Unnormalized
)
1256 and then Has_Discriminants
(Unnormalized
)
1257 and then Is_Constrained
(Unnormalized
)
1258 and then not Has_Static_Discriminant_Constraint
(Unnormalized
);
1260 if Is_Dynamically_Constrained_Array
1261 or Is_Dynamically_Constrained_Record
1263 return Base_Type
(Unnormalized
);
1265 return Unnormalized
;
1267 end Normalized_Case_Expr_Type
;
1269 -----------------------
1270 -- Scalar_Part_Count --
1271 -----------------------
1273 function Scalar_Part_Count
(Subtyp
: Entity_Id
) return Nat
is
1275 if Box_Value_Required
(Subtyp
) then
1276 return 0; -- component does not participate in case selection
1277 elsif Is_Scalar_Type
(Subtyp
) then
1279 elsif Is_Array_Type
(Subtyp
) then
1280 return Static_Array_Length
(Subtyp
)
1281 * Scalar_Part_Count
(Component_Type
(Subtyp
));
1282 elsif Is_Record_Type
(Subtyp
) then
1285 Comp
: Entity_Id
:= First_Component_Or_Discriminant
1286 (Base_Type
(Subtyp
));
1288 while Present
(Comp
) loop
1289 Result
:= Result
+ Scalar_Part_Count
(Etype
(Comp
));
1290 Next_Component_Or_Discriminant
(Comp
);
1295 pragma Assert
(Serious_Errors_Detected
> 0);
1298 end Scalar_Part_Count
;
1300 package body Array_Case_Ops
is
1302 -------------------------
1303 -- Array_Choice_Length --
1304 -------------------------
1306 function Array_Choice_Length
(Choice
: Node_Id
) return Nat
is
1308 case Nkind
(Choice
) is
1309 when N_String_Literal
=>
1310 return String_Length
(Strval
(Choice
));
1313 Bounds
: constant Node_Id
:=
1314 Aggregate_Bounds
(Choice
);
1315 pragma Assert
(Is_OK_Static_Range
(Bounds
));
1316 Lo
: constant Uint
:=
1317 Expr_Value
(Low_Bound
(Bounds
));
1318 Hi
: constant Uint
:=
1319 Expr_Value
(High_Bound
(Bounds
));
1320 Len
: constant Uint
:= (Hi
- Lo
) + 1;
1322 return UI_To_Int
(Len
);
1324 when N_Has_Entity
=>
1325 if Present
(Entity
(Choice
))
1326 and then Ekind
(Entity
(Choice
)) = E_Constant
1328 return Array_Choice_Length
1329 (Expression
(Parent
(Entity
(Choice
))));
1331 when N_Others_Choice
=>
1337 if Nkind
(Original_Node
(Choice
))
1338 in N_String_Literal | N_Aggregate
1340 return Array_Choice_Length
(Original_Node
(Choice
));
1343 Error_Msg_N
("Unsupported case choice", Choice
);
1345 end Array_Choice_Length
;
1347 ------------------------------------------
1348 -- Unconstrained_Array_Effective_Length --
1349 ------------------------------------------
1351 function Unconstrained_Array_Effective_Length
1352 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
1354 pragma Assert
(Is_Array_Type
(Array_Type
));
1355 -- Array_Type is otherwise unreferenced for now.
1358 Alt
: Node_Id
:= First
(Alternatives
(Case_Statement
));
1360 while Present
(Alt
) loop
1362 Choice
: Node_Id
:= First
(Discrete_Choices
(Alt
));
1364 while Present
(Choice
) loop
1365 Result
:= Nat
'Max (Result
, Array_Choice_Length
(Choice
));
1373 end Unconstrained_Array_Effective_Length
;
1375 -------------------------------------------
1376 -- Unconstrained_Array_Scalar_Part_Count --
1377 -------------------------------------------
1379 function Unconstrained_Array_Scalar_Part_Count
1380 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
1383 -- Add one for the length, which is treated like a discriminant
1385 return 1 + (Unconstrained_Array_Effective_Length
1386 (Array_Type
=> Array_Type
,
1387 Case_Statement
=> Case_Statement
)
1388 * Scalar_Part_Count
(Component_Type
(Array_Type
)));
1389 end Unconstrained_Array_Scalar_Part_Count
;
1393 package body Choice_Analysis
is
1395 function Component_Bounds_Info
return Composite_Range_Info
;
1396 -- Returns the (statically known) bounds for each component.
1397 -- The selector expression value (or any other value of the type
1398 -- of the selector expression) can be thought of as a point in the
1399 -- Cartesian product of these sets.
1401 function Parse_Choice
(Choice
: Node_Id
;
1402 Alt
: Node_Id
) return Choice_Range_Info
;
1403 -- Extract Choice_Range_Info from a Choice node
1405 ---------------------------
1406 -- Component_Bounds_Info --
1407 ---------------------------
1409 function Component_Bounds_Info
return Composite_Range_Info
is
1410 Result
: Composite_Range_Info
;
1411 Next
: Part_Id
:= 1;
1412 Done
: Boolean := False;
1414 procedure Update_Result
(Info
: Discrete_Range_Info
);
1415 -- Initialize first remaining uninitialized element of Result.
1416 -- Also set Next and Done.
1422 procedure Update_Result
(Info
: Discrete_Range_Info
) is
1424 Result
(Next
) := Info
;
1425 if Next
/= Part_Id
'Last then
1428 pragma Assert
(not Done
);
1433 procedure Traverse_Discrete_Parts
(Subtyp
: Entity_Id
);
1434 -- Traverse the given subtype, looking for discrete parts.
1435 -- For an array subtype of length N, the element subtype
1436 -- is traversed N times. For a record subtype, traverse
1437 -- each component's subtype (once). When a discrete part is
1438 -- found, call Update_Result.
1440 -----------------------------
1441 -- Traverse_Discrete_Parts --
1442 -----------------------------
1444 procedure Traverse_Discrete_Parts
(Subtyp
: Entity_Id
) is
1446 if Box_Value_Required
(Subtyp
) then
1450 if Is_Discrete_Type
(Subtyp
) then
1452 ((Low
=> Expr_Value
(Type_Low_Bound
(Subtyp
)),
1453 High
=> Expr_Value
(Type_High_Bound
(Subtyp
))));
1454 elsif Is_Array_Type
(Subtyp
) then
1458 if Is_Constrained
(Subtyp
) then
1459 Len
:= Static_Array_Length
(Subtyp
);
1461 -- Length will be treated like a discriminant;
1462 -- We could compute High more precisely as
1463 -- 1 + Index_Subtype'Last - Index_Subtype'First
1464 -- (we currently require that those bounds be
1465 -- static, so this is an option), but only downside of
1466 -- overshooting is if somebody wants to omit a
1467 -- "when others" choice and exhaustively cover all
1468 -- possibilities explicitly.
1471 High
=> Uint_2
** Uint_32
));
1473 Len
:= Unconstrained_Array_Effective_Length
1474 (Array_Type
=> Subtyp
,
1475 Case_Statement
=> Case_Statement
);
1477 for I
in 1 .. Len
loop
1478 Traverse_Discrete_Parts
(Component_Type
(Subtyp
));
1481 elsif Is_Record_Type
(Subtyp
) then
1482 if Has_Static_Discriminant_Constraint
(Subtyp
) then
1484 -- The component range for a constrained discriminant
1485 -- is a single value.
1487 Dc_Elmt
: Elmt_Id
:=
1488 First_Elmt
(Discriminant_Constraint
(Subtyp
));
1491 while Present
(Dc_Elmt
) loop
1492 Dc_Value
:= Expr_Value
(Node
(Dc_Elmt
));
1493 Update_Result
((Low
=> Dc_Value
,
1496 Next_Elmt
(Dc_Elmt
);
1500 -- Generate ranges for nondiscriminant components.
1502 Comp
: Entity_Id
:= First_Component
1503 (Base_Type
(Subtyp
));
1505 while Present
(Comp
) loop
1506 Traverse_Discrete_Parts
(Etype
(Comp
));
1507 Next_Component
(Comp
);
1511 -- Generate ranges for all components
1514 First_Component_Or_Discriminant
1515 (Base_Type
(Subtyp
));
1517 while Present
(Comp
) loop
1518 Traverse_Discrete_Parts
(Etype
(Comp
));
1519 Next_Component_Or_Discriminant
(Comp
);
1525 ("case selector type having a non-discrete non-record"
1526 & " non-array subcomponent type not implemented",
1527 Expression
(Case_Statement
));
1529 end Traverse_Discrete_Parts
;
1532 Traverse_Discrete_Parts
(Case_Expr_Type
);
1533 pragma Assert
(Done
or else Serious_Errors_Detected
> 0);
1535 end Component_Bounds_Info
;
1537 Component_Bounds
: constant Composite_Range_Info
1538 := Component_Bounds_Info
;
1540 package Case_Bindings
is
1542 procedure Note_Binding
1543 (Comp_Assoc
: Node_Id
;
1546 -- Note_Binding is called once for each component association
1547 -- that defines a binding (using either "A => B is X" or
1548 -- "A => <X>" syntax);
1550 procedure Check_Bindings
;
1551 -- After all calls to Note_Binding, check that bindings are
1552 -- ok (e.g., check consistency among different choices of
1553 -- one alternative).
1557 procedure Refresh_Binding_Info
(Aggr
: Node_Id
);
1558 -- The parser records binding-related info in the tree.
1559 -- The choice nodes that we see here might not be (will never be?)
1560 -- the original nodes that were produced by the parser. The info
1561 -- recorded by the parser is missing in that case, so this
1562 -- procedure recovers it.
1564 -- There are bugs here. In some cases involving nested aggregates,
1565 -- the path back to the parser-created nodes is lost. In particular,
1566 -- we may fail to detect an illegal case like
1567 -- when (F1 | F2 => (Aa => Natural, Bb => Natural is X)) =>
1568 -- This should be rejected because it is binding X to both the
1569 -- F1.Bb and to the F2.Bb subcomponents of the case selector.
1570 -- It would be nice if the not-specific-to-pattern-matching
1571 -- aggregate-processing code could remain unaware of the existence
1572 -- of this binding-related info but perhaps that isn't possible.
1574 --------------------------
1575 -- Refresh_Binding_Info --
1576 --------------------------
1578 procedure Refresh_Binding_Info
(Aggr
: Node_Id
) is
1579 Orig_Aggr
: constant Node_Id
:= Original_Node
(Aggr
);
1580 Orig_Comp
: Node_Id
:= First
(Component_Associations
(Orig_Aggr
));
1582 if Aggr
= Orig_Aggr
then
1586 while Present
(Orig_Comp
) loop
1587 if Nkind
(Orig_Comp
) = N_Component_Association
1588 and then Binding_Chars
(Orig_Comp
) /= No_Name
1590 if List_Length
(Choices
(Orig_Comp
)) /= 1 then
1591 -- Conceivably this could be checked during parsing,
1592 -- but checking is easier here.
1595 ("binding shared by multiple components", Orig_Comp
);
1600 Orig_Name
: constant Name_Id
:=
1601 Chars
(First
(Choices
(Orig_Comp
)));
1602 Comp
: Node_Id
:= First
(Component_Associations
(Aggr
));
1603 Matching_Comp
: Node_Id
:= Empty
;
1605 while Present
(Comp
) loop
1606 if Chars
(First
(Choices
(Comp
))) = Orig_Name
then
1607 pragma Assert
(not Present
(Matching_Comp
));
1608 Matching_Comp
:= Comp
;
1614 pragma Assert
(Present
(Matching_Comp
));
1618 Binding_Chars
(Orig_Comp
));
1624 end Refresh_Binding_Info
;
1630 function Parse_Choice
(Choice
: Node_Id
;
1631 Alt
: Node_Id
) return Choice_Range_Info
1633 Result
: Choice_Range_Info
(Is_Others
=> False);
1634 Ranges
: Composite_Range_Info
renames Result
.Ranges
;
1635 Next_Part
: Part_Id
'Base range 1 .. Part_Id
'Last + 1 := 1;
1637 procedure Traverse_Choice
(Expr
: Node_Id
);
1638 -- Traverse a legal choice expression, looking for
1639 -- values/ranges of discrete parts. Call Update_Result
1642 procedure Update_Result
(Discrete_Range
: Discrete_Range_Info
);
1643 -- Initialize first remaining uninitialized element of Ranges.
1644 -- Also set Next_Part.
1646 procedure Update_Result_For_Full_Coverage
(Comp_Type
: Entity_Id
);
1647 -- For each scalar part of the given component type, call
1648 -- Update_Result with the full range for that scalar part.
1649 -- This is used for both box components in aggregates and
1650 -- for any inactive-variant components that do not appear in
1651 -- a given aggregate.
1657 procedure Update_Result
(Discrete_Range
: Discrete_Range_Info
) is
1659 Ranges
(Next_Part
) := Discrete_Range
;
1660 Next_Part
:= Next_Part
+ 1;
1663 -------------------------------------
1664 -- Update_Result_For_Full_Coverage --
1665 -------------------------------------
1667 procedure Update_Result_For_Full_Coverage
(Comp_Type
: Entity_Id
)
1670 for Counter
in 1 .. Scalar_Part_Count
(Comp_Type
) loop
1671 Update_Result
(Component_Bounds
(Next_Part
));
1673 end Update_Result_For_Full_Coverage
;
1675 ---------------------
1676 -- Traverse_Choice --
1677 ---------------------
1679 procedure Traverse_Choice
(Expr
: Node_Id
) is
1681 if Nkind
(Expr
) = N_Qualified_Expression
then
1682 Traverse_Choice
(Expression
(Expr
));
1684 elsif Nkind
(Expr
) = N_Type_Conversion
1685 and then not Comes_From_Source
(Expr
)
1687 if Expr
/= Original_Node
(Expr
) then
1688 Traverse_Choice
(Original_Node
(Expr
));
1690 Traverse_Choice
(Expression
(Expr
));
1693 elsif Nkind
(Expr
) = N_Aggregate
then
1694 if Is_Record_Type
(Etype
(Expr
)) then
1695 Refresh_Binding_Info
(Aggr
=> Expr
);
1698 Comp_Assoc
: Node_Id
:=
1699 First
(Component_Associations
(Expr
));
1700 -- Aggregate has been normalized (components in
1701 -- order, only one component per choice, etc.).
1703 Comp_From_Type
: Node_Id
:=
1704 First_Component_Or_Discriminant
1705 (Base_Type
(Etype
(Expr
)));
1707 Saved_Next_Part
: constant Part_Id
:= Next_Part
;
1709 while Present
(Comp_Assoc
) loop
1711 (List_Length
(Choices
(Comp_Assoc
)) = 1);
1714 Comp
: constant Node_Id
:=
1715 Entity
(First
(Choices
(Comp_Assoc
)));
1716 Comp_Seen
: Boolean := False;
1719 if Original_Record_Component
(Comp
) =
1720 Original_Record_Component
(Comp_From_Type
)
1724 -- We have an aggregate of a type that
1725 -- has a variant part (or has a
1726 -- subcomponent type that has a variant
1727 -- part) and we have to deal with a
1728 -- component that is present in the type
1729 -- but not in the aggregate (because the
1730 -- component is in an inactive variant).
1732 Update_Result_For_Full_Coverage
1733 (Comp_Type
=> Etype
(Comp_From_Type
));
1737 Next_Component_Or_Discriminant
1740 exit when Comp_Seen
;
1745 Comp_Type
: constant Entity_Id
:=
1746 Etype
(First
(Choices
(Comp_Assoc
)));
1748 if Box_Value_Required
(Comp_Type
) then
1749 -- This component is not allowed to
1750 -- influence which alternative is
1751 -- chosen; case choice must be box.
1753 -- For example, component might be
1754 -- of a real type or of an access type
1755 -- or of a non-static discrete subtype.
1756 if not Box_Present
(Comp_Assoc
) then
1758 ("Non-box case choice component value" &
1759 " of unsupported type/subtype",
1760 Expression
(Comp_Assoc
));
1762 elsif Box_Present
(Comp_Assoc
) then
1763 -- Box matches all values
1764 Update_Result_For_Full_Coverage
1765 (Etype
(First
(Choices
(Comp_Assoc
))));
1767 Traverse_Choice
(Expression
(Comp_Assoc
));
1771 if Binding_Chars
(Comp_Assoc
) /= No_Name
1773 Case_Bindings
.Note_Binding
1774 (Comp_Assoc
=> Comp_Assoc
,
1782 while Present
(Comp_From_Type
) loop
1783 -- Deal with any trailing inactive-variant
1786 -- See earlier commment about calling
1787 -- Update_Result_For_Full_Coverage for such
1790 Update_Result_For_Full_Coverage
1791 (Comp_Type
=> Etype
(Comp_From_Type
));
1794 Next_Component_Or_Discriminant
(Comp_From_Type
);
1798 Expr_Type
: Entity_Id
:= Etype
(Expr
);
1800 if Has_Discriminants
(Expr_Type
) then
1801 -- Avoid nonstatic choice expr types,
1802 -- for which Scalar_Part_Count returns 0.
1803 Expr_Type
:= Base_Type
(Expr_Type
);
1807 (Nat
(Next_Part
- Saved_Next_Part
)
1808 = Scalar_Part_Count
(Expr_Type
));
1811 elsif Is_Array_Type
(Etype
(Expr
)) then
1812 if Is_Non_Empty_List
(Component_Associations
(Expr
)) then
1814 ("non-positional array aggregate as/within case "
1815 & "choice not implemented", Expr
);
1818 if not Unconstrained_Array_Case
1819 and then List_Length
(Expressions
(Expr
))
1820 /= Nat
(Part_Id
'Last)
1822 Error_Msg_Uint_1
:= UI_From_Int
1823 (List_Length
(Expressions
(Expr
)));
1824 Error_Msg_Uint_2
:= UI_From_Int
(Int
(Part_Id
'Last));
1826 ("array aggregate length ^ does not match length " &
1827 "of statically constrained case selector ^", Expr
);
1832 Subexpr
: Node_Id
:= First
(Expressions
(Expr
));
1834 while Present
(Subexpr
) loop
1835 Traverse_Choice
(Subexpr
);
1840 raise Program_Error
;
1842 elsif Nkind
(Expr
) = N_String_Literal
then
1843 if not Is_Array_Type
(Etype
(Expr
)) then
1845 ("User-defined string literal not allowed as/within"
1846 & "case choice", Expr
);
1849 Char_Type
: constant Entity_Id
:=
1850 Root_Type
(Component_Type
(Etype
(Expr
)));
1852 -- If the component type is not a standard character
1853 -- type then this string lit should have already been
1854 -- transformed into an aggregate in
1855 -- Resolve_String_Literal.
1857 pragma Assert
(Is_Standard_Character_Type
(Char_Type
));
1859 Str
: constant String_Id
:= Strval
(Expr
);
1860 Strlen
: constant Nat
:= String_Length
(Str
);
1863 if not Unconstrained_Array_Case
1864 and then Strlen
/= Nat
(Part_Id
'Last)
1866 Error_Msg_Uint_1
:= UI_From_Int
(Strlen
);
1867 Error_Msg_Uint_2
:= UI_From_Int
1868 (Int
(Part_Id
'Last));
1870 ("String literal length ^ does not match length" &
1871 " of statically constrained case selector ^",
1876 for Idx
in 1 .. Strlen
loop
1878 UI_From_CC
(Get_String_Char
(Str
, Idx
));
1879 Update_Result
((Low | High
=> Char_Val
));
1883 elsif Is_Discrete_Type
(Etype
(Expr
)) then
1884 if Nkind
(Expr
) in N_Has_Entity
1885 and then Present
(Entity
(Expr
))
1886 and then Is_Type
(Entity
(Expr
))
1889 Low
: constant Node_Id
:=
1890 Type_Low_Bound
(Entity
(Expr
));
1891 High
: constant Node_Id
:=
1892 Type_High_Bound
(Entity
(Expr
));
1894 Update_Result
((Low
=> Expr_Value
(Low
),
1895 High
=> Expr_Value
(High
)));
1898 pragma Assert
(Compile_Time_Known_Value
(Expr
));
1899 Update_Result
((Low | High
=> Expr_Value
(Expr
)));
1901 elsif Nkind
(Expr
) in N_Has_Entity
1902 and then Present
(Entity
(Expr
))
1903 and then Ekind
(Entity
(Expr
)) = E_Constant
1905 Traverse_Choice
(Expression
(Parent
(Entity
(Expr
))));
1906 elsif Nkind
(Original_Node
(Expr
))
1907 in N_Aggregate | N_String_Literal
1909 Traverse_Choice
(Original_Node
(Expr
));
1912 ("non-aggregate case choice (or subexpression thereof)"
1913 & " that is not of a discrete type not implemented",
1916 end Traverse_Choice
;
1918 -- Start of processing for Parse_Choice
1921 if Nkind
(Choice
) = N_Others_Choice
then
1922 return (Is_Others
=> True);
1925 if Unconstrained_Array_Case
then
1926 -- Treat length like a discriminant
1927 Update_Result
((Low | High
=>
1928 UI_From_Int
(Array_Choice_Length
(Choice
))));
1931 Traverse_Choice
(Choice
);
1933 if Unconstrained_Array_Case
then
1934 -- This is somewhat tricky. Suppose we are casing on String,
1935 -- the longest choice in the case statement is length 10, and
1936 -- the choice we are looking at now is of length 6. We fill
1937 -- in the trailing 4 slots here.
1938 while Next_Part
<= Part_Id
'Last loop
1939 Update_Result_For_Full_Coverage
1940 (Comp_Type
=> Component_Type
(Case_Expr_Type
));
1944 -- Avoid returning uninitialized garbage in error case
1945 if Next_Part
/= Part_Id
'Last + 1 then
1946 pragma Assert
(Serious_Errors_Detected
> 0);
1947 Result
.Ranges
:= (others => (Low
=> Uint_1
, High
=> Uint_0
));
1953 package body Case_Bindings
is
1955 type Binding
is record
1956 Comp_Assoc
: Node_Id
;
1961 type Binding_Index
is new Natural;
1963 package Case_Bindings_Table
is new Table
.Table
1964 (Table_Component_Type
=> Binding
,
1965 Table_Index_Type
=> Binding_Index
,
1966 Table_Low_Bound
=> 1,
1967 Table_Initial
=> 16,
1968 Table_Increment
=> 64,
1969 Table_Name
=> "Composite_Case_Ops.Case_Bindings");
1975 procedure Note_Binding
1976 (Comp_Assoc
: Node_Id
;
1981 Case_Bindings_Table
.Append
1982 ((Comp_Assoc
=> Comp_Assoc
,
1987 --------------------
1988 -- Check_Bindings --
1989 --------------------
1991 procedure Check_Bindings
1993 use Case_Bindings_Table
;
1996 -- no bindings to check
2002 renames Case_Bindings_Table
.Table
(1 .. Last
);
2004 function Same_Id
(Idx1
, Idx2
: Binding_Index
)
2006 Binding_Chars
(Tab
(Idx1
).Comp_Assoc
) =
2007 Binding_Chars
(Tab
(Idx2
).Comp_Assoc
));
2009 function Binding_Subtype
(Idx
: Binding_Index
)
2011 (Etype
(Nlists
.First
(Choices
(Tab
(Idx
).Comp_Assoc
))));
2013 -- Verify that elements with given choice or alt value
2014 -- are contiguous, and that elements with equal
2015 -- choice values have same alt value.
2017 for Idx1
in 2 .. Tab
'Last loop
2018 if Tab
(Idx1
- 1).Choice
/= Tab
(Idx1
).Choice
then
2020 (for all Idx2
in Idx1
+ 1 .. Tab
'Last =>
2021 Tab
(Idx2
).Choice
/= Tab
(Idx1
- 1).Choice
);
2023 pragma Assert
(Tab
(Idx1
- 1).Alt
= Tab
(Idx1
).Alt
);
2025 if Tab
(Idx1
- 1).Alt
/= Tab
(Idx1
).Alt
then
2027 (for all Idx2
in Idx1
+ 1 .. Tab
'Last =>
2028 Tab
(Idx2
).Alt
/= Tab
(Idx1
- 1).Alt
);
2032 -- Check for user errors:
2033 -- 1) Two choices for a given alternative shall define the
2034 -- same set of names. Can't have
2035 -- when (<X>, 0) | (0, <Y>) =>
2036 -- 2) A choice shall not define a name twice. Can't have
2037 -- when (A => <X>, B => <X>, C => 0) =>
2038 -- 3) Two definitions of a name within one alternative
2039 -- shall have statically matching component subtypes.
2041 -- type R is record Int : Integer;
2042 -- Nat : Natural; end record;
2044 -- when (<X>, 1) | (1, <X>) =>
2045 -- 4) A given binding shall match only one value.
2047 -- (Fld1 | Fld2 => (Fld => <X>))
2048 -- For now, this is enforced *very* conservatively
2049 -- with respect to arrays - a binding cannot match
2050 -- any part of an array. This is temporary.
2052 for Idx1
in Tab
'Range loop
2054 or else Tab
(Idx1
- 1).Alt
/= Tab
(Idx1
).Alt
2056 -- Process one alternative
2058 Alt_Start
: constant Binding_Index
:= Idx1
;
2059 Alt
: constant Node_Id
:= Tab
(Alt_Start
).Alt
;
2061 First_Choice
: constant Node_Id
:=
2062 Nlists
.First
(Discrete_Choices
(Alt
));
2063 First_Choice_Bindings
: Natural := 0;
2065 -- Check for duplicates within one choice,
2066 -- and for choices with no bindings.
2068 if First_Choice
/= Tab
(Alt_Start
).Choice
then
2069 Error_Msg_N
("binding(s) missing for choice",
2075 Current_Choice
: Node_Id
:= First_Choice
;
2076 Choice_Start
: Binding_Index
:= Alt_Start
;
2078 for Idx2
in Alt_Start
.. Tab
'Last loop
2079 exit when Tab
(Idx2
).Alt
/= Alt
;
2080 if Tab
(Idx2
).Choice
= Current_Choice
then
2081 for Idx3
in Choice_Start
.. Idx2
- 1 loop
2082 if Same_Id
(Idx2
, Idx3
)
2085 ("duplicate binding in choice",
2091 Next
(Current_Choice
);
2092 pragma Assert
(Present
(Current_Choice
));
2093 Choice_Start
:= Idx2
;
2095 if Tab
(Idx2
).Choice
/= Current_Choice
2098 ("binding(s) missing for choice",
2105 -- If we made it through all the bindings
2106 -- for this alternative but didn't make it
2107 -- to the last choice, then bindings are
2108 -- missing for all remaining choices.
2109 -- We only complain about the first one.
2111 if Present
(Next
(Current_Choice
)) then
2113 ("binding(s) missing for choice",
2114 Next
(Current_Choice
));
2119 -- Count bindings for first choice of alternative
2121 for FC_Idx
in Alt_Start
.. Tab
'Last loop
2122 exit when Tab
(FC_Idx
).Choice
/= First_Choice
;
2123 First_Choice_Bindings
:=
2124 First_Choice_Bindings
+ 1;
2128 Current_Choice
: Node_Id
:= First_Choice
;
2129 Current_Choice_Bindings
: Natural := 0;
2131 for Idx2
in Alt_Start
.. Tab
'Last loop
2132 exit when Tab
(Idx2
).Alt
/= Alt
;
2134 -- If starting a new choice
2136 if Tab
(Idx2
).Choice
/= Current_Choice
then
2138 -- Check count for choice just finished
2140 if Current_Choice_Bindings
2141 /= First_Choice_Bindings
2144 ("subsequent choice has different"
2145 & " number of bindings than first"
2146 & " choice", Current_Choice
);
2149 Current_Choice
:= Tab
(Idx2
).Choice
;
2150 Current_Choice_Bindings
:= 1;
2152 -- Remember that Alt has both one or more
2153 -- bindings and two or more choices; we'll
2154 -- need to know this during expansion.
2156 Set_Multidefined_Bindings
(Alt
, True);
2158 Current_Choice_Bindings
:=
2159 Current_Choice_Bindings
+ 1;
2162 -- Check that first choice has binding with
2163 -- matching name; check subtype consistency.
2166 Found
: Boolean := False;
2170 Alt_Start
+ Binding_Index
2171 (First_Choice_Bindings
- 1)
2173 if Same_Id
(Idx2
, FC_Idx
) then
2174 if not Subtypes_Statically_Match
2175 (Binding_Subtype
(Idx2
),
2176 Binding_Subtype
(FC_Idx
))
2179 ("subtype of binding in "
2180 & "subsequent choice does not "
2181 & "match that in first choice",
2182 Tab
(Idx2
).Comp_Assoc
);
2191 ("binding defined in subsequent "
2192 & "choice not defined in first "
2193 & "choice", Current_Choice
);
2197 -- Check for illegal repeated binding
2198 -- via an enclosing aggregate, as in
2199 -- (F1 | F2 => (F3 => Natural is X,
2201 -- where the inner aggregate would be ok.
2204 Rover
: Node_Id
:= Tab
(Idx2
).Comp_Assoc
;
2206 while Rover
/= Tab
(Idx2
).Choice
loop
2208 (if Is_List_Member
(Rover
) then
2209 Parent
(List_Containing
(Rover
))
2210 else Parent
(Rover
));
2211 pragma Assert
(Present
(Rover
));
2213 = N_Component_Association
2214 and then List_Length
(Choices
(Rover
))
2218 ("binding shared by multiple "
2219 & "enclosing components",
2220 Tab
(Idx2
).Comp_Assoc
);
2227 -- Construct the (unanalyzed) declarations for
2228 -- the current alternative. Then analyze them.
2230 if First_Choice_Bindings
> 0 then
2232 Loc
: constant Source_Ptr
:= Sloc
(Alt
);
2233 Declarations
: constant List_Id
:= New_List
;
2239 Binding_Index
(First_Choice_Bindings
- 1)
2241 Decl
:= Make_Object_Declaration
2243 Defining_Identifier
=>
2244 Make_Defining_Identifier
2247 (Tab
(FC_Idx
).Comp_Assoc
)),
2248 Object_Definition
=>
2250 (Binding_Subtype
(FC_Idx
), Loc
));
2252 Append_To
(Declarations
, Decl
);
2256 Old_Statements
: constant List_Id
:=
2258 New_Statements
: constant List_Id
:=
2261 Block_Statement
: constant Node_Id
:=
2262 Make_Block_Statement
(Sloc
=> Loc
,
2263 Declarations
=> Declarations
,
2264 Handled_Statement_Sequence
=>
2265 Make_Handled_Sequence_Of_Statements
2266 (Loc
, Old_Statements
),
2267 Has_Created_Identifier
=> True);
2270 (New_Statements
, Block_Statement
);
2272 Set_Statements
(Alt
, New_Statements
);
2283 function Choice_Bounds_Info
return Choices_Range_Info
;
2284 -- Returns mapping from any given Choice_Id value to that choice's
2285 -- component-to-range map.
2287 ------------------------
2288 -- Choice_Bounds_Info --
2289 ------------------------
2291 function Choice_Bounds_Info
return Choices_Range_Info
is
2292 Result
: Choices_Range_Info
;
2293 Alt
: Node_Id
:= First
(Alternatives
(Case_Statement
));
2294 C_Id
: Choice_Id
:= 1;
2296 while Present
(Alt
) loop
2298 Choice
: Node_Id
:= First
(Discrete_Choices
(Alt
));
2300 while Present
(Choice
) loop
2301 Result
(C_Id
) := Parse_Choice
(Choice
, Alt
=> Alt
);
2304 if C_Id
/= Choice_Id
'Last then
2312 pragma Assert
(C_Id
= Choice_Id
'Last);
2314 -- No more calls to Note_Binding, so time for checks.
2315 Case_Bindings
.Check_Bindings
;
2318 end Choice_Bounds_Info
;
2320 Choices_Bounds
: constant Choices_Range_Info
:= Choice_Bounds_Info
;
2322 package body Value_Sets
is
2325 function Hash
(Key
: Uint
) return Bucket_Range_Type
is
2327 (UI_To_Int
(Key
mod (Uint_2
** Uint_31
))));
2329 package Uint_Sets
is new GNAT
.Sets
.Membership_Sets
2332 type Representative_Values_Array
is
2333 array (Part_Id
) of Uint_Sets
.Membership_Set
;
2335 function Representative_Values_Init
2336 return Representative_Values_Array
;
2337 -- Select the representative values for each Part_Id value.
2338 -- This function is called exactly once, immediately after it
2341 --------------------------------
2342 -- Representative_Values_Init --
2343 --------------------------------
2345 function Representative_Values_Init
2346 return Representative_Values_Array
2348 -- For each range of each choice (as well as the range for the
2349 -- component subtype, which is handled in the first loop),
2350 -- insert the low bound of the range and the successor of
2351 -- the high bound into the corresponding R_V element.
2353 -- The idea we are trying to capture here is somewhat tricky.
2354 -- Given an arbitrary point P1 in the Cartesian product
2355 -- of the Component_Bounds sets, we want to be able
2356 -- to map that to a point P2 in the (smaller) Cartesian product
2357 -- of the Representative_Values sets that has the property
2358 -- that for every choice of the case statement, P1 matches
2359 -- the choice if and only if P2 also matches. Given that,
2360 -- we can implement the overlapping/containment/etc. rules
2361 -- safely by just looking at (using brute force enumeration)
2362 -- the (smaller) Cartesian product of the R_V sets.
2363 -- We are never going to actually perform this point-to-point
2364 -- mapping - just the fact that it exists is enough to ensure
2365 -- we can safely look at just the R_V sets.
2367 -- The desired mapping can be implemented by mapping a point
2368 -- P1 to a point P2 by reducing each of P1's coordinates down
2369 -- to the largest element of the corresponding R_V set that is
2370 -- less than or equal to the original coordinate value (such
2371 -- an element Y will always exist because the R_V set for a
2372 -- given component always includes the low bound of the
2373 -- component subtype). It then suffices to show that every
2374 -- choice in the case statement yields the same Boolean result
2375 -- for P1 as for P2.
2377 -- Suppose the contrary. Then there is some particular
2378 -- coordinate position X (i.e., a Part_Id value) and some
2379 -- choice C where exactly one of P1(X) and P2(X) belongs to
2380 -- the (contiguous) range associated with C(X); call that
2381 -- range L .. H. We know that P2(X) <= P1(X) because the
2382 -- mapping never increases coordinate values. Consider three
2383 -- cases: P1(X) lies within the L .. H range, or it is greater
2384 -- than H, or it is lower than L.
2385 -- The third case is impossible because reducing a value that
2386 -- is less than L can only produce another such value,
2387 -- violating the "exactly one" assumption. The second
2388 -- case is impossible because L belongs to the corresponding
2389 -- R_V set, so P2(X) >= L and both values belong to the
2390 -- range, again violating the "exactly one" assumption.
2391 -- Finally, the third case is impossible because H+1 belongs
2392 -- to the corresponding R_V set, so P2(X) > H, so neither
2393 -- value belongs to the range, again violating the "exactly
2394 -- one" assumption. So our initial supposition was wrong. QED.
2398 Result
: constant Representative_Values_Array
2399 := (others => Uint_Sets
.Create
(Initial_Size
=> 32));
2401 procedure Insert_Representative
(Value
: Uint
; P
: Part_Id
);
2402 -- Insert the given Value into the representative values set
2403 -- for the given component if it belongs to the component's
2404 -- subtype. Otherwise, do nothing.
2406 ---------------------------
2407 -- Insert_Representative --
2408 ---------------------------
2410 procedure Insert_Representative
(Value
: Uint
; P
: Part_Id
) is
2412 if Value
>= Component_Bounds
(P
).Low
and
2413 Value
<= Component_Bounds
(P
).High
2415 Insert
(Result
(P
), Value
);
2417 end Insert_Representative
;
2420 for P
in Part_Id
loop
2421 Insert_Representative
(Component_Bounds
(P
).Low
, P
);
2423 for C
of Choices_Bounds
loop
2424 if not C
.Is_Others
then
2425 for P
in Part_Id
loop
2426 if C
.Ranges
(P
).Low
<= C
.Ranges
(P
).High
then
2427 Insert_Representative
(C
.Ranges
(P
).Low
, P
);
2428 Insert_Representative
(C
.Ranges
(P
).High
+ 1, P
);
2434 end Representative_Values_Init
;
2436 Representative_Values
: constant Representative_Values_Array
2437 := Representative_Values_Init
;
2438 -- We want to avoid looking at every point in the Cartesian
2439 -- product of all component values. Instead we select, for each
2440 -- component, a set of representative values and then look only
2441 -- at the Cartesian product of those sets. A single value can
2442 -- safely represent a larger enclosing interval if every choice
2443 -- for that component either completely includes or completely
2444 -- excludes the interval. The elements of this array will be
2445 -- populated by a call to Initialize_Representative_Values and
2446 -- will remain constant after that.
2448 type Value_Index_Base
is new Natural;
2450 function Value_Index_Count
return Value_Index_Base
;
2451 -- Returns the product of the sizes of the Representative_Values
2452 -- sets (i.e., the size of the Cartesian product of the sets).
2453 -- May return zero if one of the sets is empty.
2454 -- This function is called exactly once, immediately after it
2457 -----------------------
2458 -- Value_Index_Count --
2459 -----------------------
2461 function Value_Index_Count
return Value_Index_Base
is
2462 Result
: Value_Index_Base
:= 1;
2464 for Set
of Representative_Values
loop
2465 Result
:= Result
* Value_Index_Base
(Uint_Sets
.Size
(Set
));
2469 when Constraint_Error
=>
2471 ("Capacity exceeded in compiling case statement with"
2472 & " composite selector type", Case_Statement
);
2474 end Value_Index_Count
;
2476 Max_Value_Index
: constant Value_Index_Base
:= Value_Index_Count
;
2478 subtype Value_Index
is Value_Index_Base
range 1 .. Max_Value_Index
;
2479 type Value_Index_Set
is array (Value_Index
) of Boolean;
2481 package Value_Index_Set_Table
is new Table
.Table
2482 (Table_Component_Type
=> Value_Index_Set
,
2483 Table_Index_Type
=> Value_Set
,
2484 Table_Low_Bound
=> 1,
2485 Table_Initial
=> 16,
2486 Table_Increment
=> 100,
2487 Table_Name
=> "Composite_Case_Ops.Value_Sets");
2488 -- A nonzero Value_Set value is an index into this table.
2490 function Indexed
(Index
: Value_Set
) return Value_Index_Set
2491 is (Value_Index_Set_Table
.Table
.all (Index
));
2493 function Allocate_Table_Element
(Initial_Value
: Value_Index_Set
)
2495 -- Allocate and initialize a new table element; return its index.
2497 ----------------------------
2498 -- Allocate_Table_Element --
2499 ----------------------------
2501 function Allocate_Table_Element
(Initial_Value
: Value_Index_Set
)
2504 use Value_Index_Set_Table
;
2506 Append
(Initial_Value
);
2508 end Allocate_Table_Element
;
2510 procedure Assign_Table_Element
(Index
: Value_Set
;
2511 Value
: Value_Index_Set
);
2512 -- Assign specified value to specified table element.
2514 --------------------------
2515 -- Assign_Table_Element --
2516 --------------------------
2518 procedure Assign_Table_Element
(Index
: Value_Set
;
2519 Value
: Value_Index_Set
)
2522 Value_Index_Set_Table
.Table
.all (Index
) := Value
;
2523 end Assign_Table_Element
;
2529 function Compare
(S1
, S2
: Value_Set
) return Set_Comparison
is
2531 if S1
= Empty
or S2
= Empty
then
2533 elsif Indexed
(S1
) = Indexed
(S2
) then
2537 Intersection
: constant Value_Index_Set
2538 := Indexed
(S1
) and Indexed
(S2
);
2540 if (for all Flag
of Intersection
=> not Flag
) then
2542 elsif Intersection
= Indexed
(S1
) then
2543 return Contained_By
;
2544 elsif Intersection
= Indexed
(S2
) then
2553 -------------------------
2554 -- Complement_Is_Empty --
2555 -------------------------
2557 function Complement_Is_Empty
(Set
: Value_Set
) return Boolean
2559 and then (for all Flag
of Indexed
(Set
) => Flag
));
2561 ---------------------
2562 -- Free_Value_Sets --
2563 ---------------------
2564 procedure Free_Value_Sets
is
2566 Value_Index_Set_Table
.Free
;
2567 end Free_Value_Sets
;
2573 procedure Union
(Target
: in out Value_Set
; Source
: Value_Set
) is
2575 if Source
/= Empty
then
2576 if Target
= Empty
then
2577 Target
:= Allocate_Table_Element
(Indexed
(Source
));
2579 Assign_Table_Element
2580 (Target
, Indexed
(Target
) or Indexed
(Source
));
2589 procedure Remove
(Target
: in out Value_Set
; Source
: Value_Set
) is
2591 if Source
/= Empty
and Target
/= Empty
then
2592 Assign_Table_Element
2593 (Target
, Indexed
(Target
) and not Indexed
(Source
));
2594 if (for all V
of Indexed
(Target
) => not V
) then
2600 ---------------------
2601 -- Matching_Values --
2602 ---------------------
2604 function Matching_Values
2605 (Info
: Composite_Range_Info
) return Value_Set
2607 Matches
: Value_Index_Set
;
2608 Next_Index
: Value_Index
:= 1;
2609 Done
: Boolean := False;
2610 Point
: array (Part_Id
) of Uint
;
2612 procedure Test_Point_For_Match
;
2613 -- Point identifies a point in the Cartesian product of the
2614 -- representative value sets. Record whether that Point
2615 -- belongs to the product-of-ranges specified by Info.
2617 --------------------------
2618 -- Test_Point_For_Match --
2619 --------------------------
2621 procedure Test_Point_For_Match
is
2622 function In_Range
(Val
: Uint
; Rang
: Discrete_Range_Info
)
2624 ((Rang
.Low
<= Val
) and then (Val
<= Rang
.High
));
2626 pragma Assert
(not Done
);
2627 Matches
(Next_Index
) :=
2628 (for all P
in Part_Id
=> In_Range
(Point
(P
), Info
(P
)));
2629 if Next_Index
= Matches
'Last then
2632 Next_Index
:= Next_Index
+ 1;
2634 end Test_Point_For_Match
;
2636 procedure Test_Points
(P
: Part_Id
);
2637 -- Iterate over the Cartesian product of the representative
2638 -- value sets, calling Test_Point_For_Match for each point.
2644 procedure Test_Points
(P
: Part_Id
) is
2646 Iter
: Iterator
:= Iterate
(Representative_Values
(P
));
2648 -- We could traverse here in sorted order, as opposed to
2649 -- whatever order the set iterator gives us.
2650 -- No need for that as long as every iteration over
2651 -- a given representative values set yields the same order.
2652 -- Not sorting is more efficient, but it makes it harder to
2653 -- interpret a Value_Index_Set bit vector when debugging.
2655 while Has_Next
(Iter
) loop
2656 Next
(Iter
, Point
(P
));
2658 -- If we have finished building up a Point value, then
2659 -- test it for matching. Otherwise, recurse to continue
2660 -- building up a point value.
2662 if P
= Part_Id
'Last then
2663 Test_Point_For_Match
;
2665 Test_Points
(P
+ 1);
2672 if (for all Flag
of Matches
=> not Flag
) then
2675 return Allocate_Table_Element
(Matches
);
2676 end Matching_Values
;
2684 function Analysis
return Choices_Info
is
2685 Result
: Choices_Info
;
2686 Alt
: Node_Id
:= First
(Alternatives
(Case_Statement
));
2687 A_Id
: Alternative_Id
:= 1;
2688 C_Id
: Choice_Id
:= 1;
2690 while Present
(Alt
) loop
2692 Choice
: Node_Id
:= First
(Discrete_Choices
(Alt
));
2694 while Present
(Choice
) loop
2695 if Nkind
(Choice
) = N_Others_Choice
then
2696 pragma Assert
(Choices_Bounds
(C_Id
).Is_Others
);
2698 (Alternative
=> A_Id
,
2702 (Alternative
=> A_Id
,
2704 Matches
=> Value_Sets
.Matching_Values
2705 (Choices_Bounds
(C_Id
).Ranges
));
2708 if C_Id
/= Choice_Id
'Last then
2715 if A_Id
/= Alternative_Id
'Last then
2720 pragma Assert
(A_Id
= Alternative_Id
'Last);
2721 pragma Assert
(C_Id
= Choice_Id
'Last);
2726 end Choice_Analysis
;
2728 end Composite_Case_Ops
;
2730 --------------------------
2731 -- Expand_Others_Choice --
2732 --------------------------
2734 procedure Expand_Others_Choice
2735 (Case_Table
: Choice_Table_Type
;
2736 Others_Choice
: Node_Id
;
2737 Choice_Type
: Entity_Id
)
2739 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
2740 Choice_List
: constant List_Id
:= New_List
;
2748 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
2749 -- Builds a node representing the missing choices given by Value1 and
2750 -- Value2. A N_Range node is built if there is more than one literal
2751 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
2752 -- or N_Character_Literal is built depending on what Choice_Type is.
2754 function Lit_Of
(Value
: Uint
) return Node_Id
;
2755 -- Returns the Node_Id for the enumeration literal corresponding to the
2756 -- position given by Value within the enumeration type Choice_Type. The
2757 -- returned value has its Is_Static_Expression flag set to true.
2763 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
2768 -- If there is only one choice value missing between Value1 and
2769 -- Value2, build an integer or enumeration literal to represent it.
2771 if Value1
= Value2
then
2772 if Is_Integer_Type
(Choice_Type
) then
2773 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
2774 Set_Etype
(Lit_Node
, Choice_Type
);
2775 Set_Is_Static_Expression
(Lit_Node
);
2777 Lit_Node
:= Lit_Of
(Value1
);
2780 -- Otherwise is more that one choice value that is missing between
2781 -- Value1 and Value2, therefore build a N_Range node of either
2782 -- integer or enumeration literals.
2785 if Is_Integer_Type
(Choice_Type
) then
2786 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
2787 Set_Etype
(Lo
, Choice_Type
);
2788 Set_Is_Static_Expression
(Lo
);
2789 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
2790 Set_Etype
(Hi
, Choice_Type
);
2791 Set_Is_Static_Expression
(Hi
);
2800 Low_Bound
=> Lit_Of
(Value1
),
2801 High_Bound
=> Lit_Of
(Value2
));
2812 function Lit_Of
(Value
: Uint
) return Node_Id
is
2816 -- In the case where the literal is of type Character, there needs
2817 -- to be some special handling since there is no explicit chain
2818 -- of literals to search. Instead, a N_Character_Literal node
2819 -- is created with the appropriate Char_Code and Chars fields.
2821 if Is_Standard_Character_Type
(Choice_Type
) then
2822 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
2824 Make_Character_Literal
(Loc
,
2826 Char_Literal_Value
=> Value
);
2827 Set_Etype
(Lit
, Choice_Type
);
2828 Set_Is_Static_Expression
(Lit
, True);
2831 -- Otherwise, iterate through the literals list of Choice_Type
2832 -- "Value" number of times until the desired literal is reached
2833 -- and then return an occurrence of it.
2836 Lit
:= First_Literal
(Choice_Type
);
2837 for J
in 1 .. UI_To_Int
(Value
) loop
2841 return New_Occurrence_Of
(Lit
, Loc
);
2845 -- Start of processing for Expand_Others_Choice
2848 if Case_Table
'Last = 0 then
2850 -- Special case: only an others case is present. The others case
2851 -- covers the full range of the type.
2853 if Is_OK_Static_Subtype
(Choice_Type
) then
2854 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
2856 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
2859 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
2863 -- Establish the bound values for the choice depending upon whether the
2864 -- type of the case statement is static or not.
2866 if Is_OK_Static_Subtype
(Choice_Type
) then
2867 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
2868 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
2870 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
2871 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
2874 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
2875 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
2876 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
2878 -- Build the node for any missing choices that are smaller than any
2879 -- explicit choices given in the case.
2881 if Expr_Value
(Exp_Lo
) < Lo
then
2882 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
2885 -- Build the nodes representing any missing choices that lie between
2886 -- the explicit ones given in the case.
2888 for J
in 2 .. Case_Table
'Last loop
2889 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
2890 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
2892 if Lo
/= (Previous_Hi
+ 1) then
2893 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
2899 -- Build the node for any missing choices that are greater than any
2900 -- explicit choices given in the case.
2902 if Expr_Value
(Exp_Hi
) > Hi
then
2903 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
2906 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
2908 -- Warn on null others list if warning option set
2910 if Warn_On_Redundant_Constructs
2911 and then Comes_From_Source
(Others_Choice
)
2912 and then Is_Empty_List
(Choice_List
)
2914 Error_Msg_N
("?r?OTHERS choice is redundant", Others_Choice
);
2915 Error_Msg_N
("\?r?previous choices cover all values", Others_Choice
);
2917 end Expand_Others_Choice
;
2923 procedure No_OP
(C
: Node_Id
) is
2925 if Nkind
(C
) = N_Range
and then Warn_On_Redundant_Constructs
then
2926 Error_Msg_N
("choice is an empty range?r?", C
);
2930 -----------------------------
2931 -- Generic_Analyze_Choices --
2932 -----------------------------
2934 package body Generic_Analyze_Choices
is
2936 -- The following type is used to gather the entries for the choice
2937 -- table, so that we can then allocate the right length.
2940 type Link_Ptr
is access all Link
;
2943 Val
: Choice_Bounds
;
2947 ---------------------
2948 -- Analyze_Choices --
2949 ---------------------
2951 procedure Analyze_Choices
2952 (Alternatives
: List_Id
;
2955 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
2956 -- The actual type against which the discrete choices are resolved.
2957 -- Note that this type is always the base type not the subtype of the
2958 -- ruling expression, index or discriminant.
2960 Expected_Type
: Entity_Id
;
2961 -- The expected type of each choice. Equal to Choice_Type, except if
2962 -- the expression is universal, in which case the choices can be of
2963 -- any integer type.
2966 -- A case statement alternative or a variant in a record type
2971 -- The node kind of the current Choice
2974 -- Set Expected type (= choice type except for universal integer,
2975 -- where we accept any integer type as a choice).
2977 if Choice_Type
= Universal_Integer
then
2978 Expected_Type
:= Any_Integer
;
2980 Expected_Type
:= Choice_Type
;
2983 -- Now loop through the case alternatives or record variants
2985 Alt
:= First
(Alternatives
);
2986 while Present
(Alt
) loop
2988 -- If pragma, just analyze it
2990 if Nkind
(Alt
) = N_Pragma
then
2993 -- Otherwise we have an alternative. In most cases the semantic
2994 -- processing leaves the list of choices unchanged
2996 -- Check each choice against its base type
2999 Choice
:= First
(Discrete_Choices
(Alt
));
3000 while Present
(Choice
) loop
3002 Kind
:= Nkind
(Choice
);
3004 -- Choice is a Range
3007 or else (Kind
= N_Attribute_Reference
3008 and then Attribute_Name
(Choice
) = Name_Range
)
3010 Resolve
(Choice
, Expected_Type
);
3012 -- Choice is a subtype name, nothing further to do now
3014 elsif Is_Entity_Name
(Choice
)
3015 and then Is_Type
(Entity
(Choice
))
3019 -- Choice is a subtype indication
3021 elsif Kind
= N_Subtype_Indication
then
3022 Resolve_Discrete_Subtype_Indication
3023 (Choice
, Expected_Type
);
3025 -- Others choice, no analysis needed
3027 elsif Kind
= N_Others_Choice
then
3030 -- Only other possibility is an expression
3033 Resolve
(Choice
, Expected_Type
);
3036 -- Move to next choice
3041 Process_Associated_Node
(Alt
);
3046 end Analyze_Choices
;
3048 end Generic_Analyze_Choices
;
3050 ---------------------------
3051 -- Generic_Check_Choices --
3052 ---------------------------
3054 package body Generic_Check_Choices
is
3056 -- The following type is used to gather the entries for the choice
3057 -- table, so that we can then allocate the right length.
3060 type Link_Ptr
is access all Link
;
3063 Val
: Choice_Bounds
;
3067 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
3073 procedure Check_Choices
3075 Alternatives
: List_Id
;
3077 Others_Present
: out Boolean)
3081 Raises_CE
: Boolean;
3082 -- Set True if one of the bounds of a choice raises CE
3085 -- This is where we post error messages for bounds out of range
3087 Choice_List
: Link_Ptr
:= null;
3088 -- Gather list of choices
3090 Num_Choices
: Nat
:= 0;
3091 -- Number of entries in Choice_List
3093 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
3094 -- The actual type against which the discrete choices are resolved.
3095 -- Note that this type is always the base type not the subtype of the
3096 -- ruling expression, index or discriminant.
3098 Bounds_Type
: Entity_Id
;
3099 -- The type from which are derived the bounds of the values covered
3100 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
3101 -- specifies a value outside of these bounds we have an error.
3105 -- The actual bounds of the above type
3107 Expected_Type
: Entity_Id
;
3108 -- The expected type of each choice. Equal to Choice_Type, except if
3109 -- the expression is universal, in which case the choices can be of
3110 -- any integer type.
3113 -- A case statement alternative or a variant in a record type
3118 -- The node kind of the current Choice
3120 Others_Choice
: Node_Id
:= Empty
;
3121 -- Remember others choice if it is present (empty otherwise)
3123 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
3124 -- Checks the validity of the bounds of a choice. When the bounds
3125 -- are static and no error occurred the bounds are collected for
3126 -- later entry into the choices table so that they can be sorted
3129 procedure Check_Case_Pattern_Choices
;
3130 -- Check choices validity for the Ada extension case where the
3131 -- selecting expression is not of a discrete type and so the
3132 -- choices are patterns.
3134 procedure Check_Composite_Case_Selector
;
3135 -- Check that the (non-discrete) type of the expression being
3136 -- cased on is suitable.
3138 procedure Handle_Static_Predicate
3142 -- If the type of the alternative has predicates, we must examine
3143 -- each subset of the predicate rather than the bounds of the type
3144 -- itself. This is relevant when the choice is a subtype mark or a
3145 -- subtype indication.
3151 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
3156 -- First check if an error was already detected on either bounds
3158 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
3161 -- Do not insert non static choices in the table to be sorted
3163 elsif not Is_OK_Static_Expression
(Lo
)
3165 not Is_OK_Static_Expression
(Hi
)
3167 Process_Non_Static_Choice
(Choice
);
3170 -- Ignore range which raise constraint error
3172 elsif Raises_Constraint_Error
(Lo
)
3173 or else Raises_Constraint_Error
(Hi
)
3178 -- AI05-0188 : Within an instance the non-others choices do not
3179 -- have to belong to the actual subtype.
3181 elsif Ada_Version
>= Ada_2012
and then In_Instance
then
3184 -- Otherwise we have an OK static choice
3187 Lo_Val
:= Expr_Value
(Lo
);
3188 Hi_Val
:= Expr_Value
(Hi
);
3190 -- Do not insert null ranges in the choices table
3192 if Lo_Val
> Hi_Val
then
3193 Process_Empty_Choice
(Choice
);
3198 -- Check for low bound out of range
3200 if Lo_Val
< Bounds_Lo
then
3202 -- If the choice is an entity name, then it is a type, and we
3203 -- want to post the message on the reference to this entity.
3204 -- Otherwise post it on the lower bound of the range.
3206 if Is_Entity_Name
(Choice
) then
3212 -- Specialize message for integer/enum type
3214 if Is_Integer_Type
(Bounds_Type
) then
3215 Error_Msg_Uint_1
:= Bounds_Lo
;
3216 Error_Msg_N
("minimum allowed choice value is^", Enode
);
3218 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
3219 Error_Msg_N
("minimum allowed choice value is%", Enode
);
3223 -- Check for high bound out of range
3225 if Hi_Val
> Bounds_Hi
then
3227 -- If the choice is an entity name, then it is a type, and we
3228 -- want to post the message on the reference to this entity.
3229 -- Otherwise post it on the upper bound of the range.
3231 if Is_Entity_Name
(Choice
) then
3237 -- Specialize message for integer/enum type
3239 if Is_Integer_Type
(Bounds_Type
) then
3240 Error_Msg_Uint_1
:= Bounds_Hi
;
3241 Error_Msg_N
("maximum allowed choice value is^", Enode
);
3243 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
3244 Error_Msg_N
("maximum allowed choice value is%", Enode
);
3248 -- Collect bounds in the list
3250 -- Note: we still store the bounds, even if they are out of range,
3251 -- since this may prevent unnecessary cascaded errors for values
3252 -- that are covered by such an excessive range.
3255 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
3256 Num_Choices := Num_Choices + 1;
3259 --------------------------------
3260 -- Check_Case_Pattern_Choices --
3261 --------------------------------
3263 procedure Check_Case_Pattern_Choices is
3264 -- ??? Need to Free/Finalize value sets allocated here.
3266 package Ops is new Composite_Case_Ops.Choice_Analysis
3267 (Case_Statement => N);
3271 Empty : Value_Set renames Value_Sets.Empty;
3272 -- Cope with hiding due to multiple use clauses
3274 Info : constant Choices_Info := Analysis;
3275 Others_Seen : Boolean := False;
3279 Matches : array (Alternative_Id) of Value_Sets.Value_Set :=
3282 Flag_Overlapping_Within_One_Alternative : constant Boolean :=
3284 -- We may want to flag overlapping (perhaps with only a
3285 -- warning) if the pattern binds an identifier, as in
3286 -- when (Positive, <X>) | (Integer, <X>) =>
3288 Covered : Value_Set := Empty;
3289 -- The union of all alternatives seen so far
3292 for Choice of Info loop
3293 if Choice.Is_Others then
3294 Others_Seen := True;
3296 if Flag_Overlapping_Within_One_Alternative
3297 and then (Compare (Matches (Choice.Alternative),
3298 Choice.Matches) /= Disjoint)
3301 ("bad overlapping within one alternative", N);
3304 Union (Target => Matches (Choice.Alternative),
3305 Source => Choice.Matches);
3309 for A1 in Alternative_Id loop
3310 for A2 in Alternative_Id
3311 range A1 + 1 .. Alternative_Id'Last
3313 case Compare (Matches (A1), Matches (A2)) is
3314 when Disjoint | Contained_By =>
3318 Uncovered_1, Uncovered_2 : Value_Set := Empty;
3320 Union (Uncovered_1, Matches (A1));
3321 Remove (Uncovered_1, Covered);
3322 Union (Uncovered_2, Matches (A2));
3323 Remove (Uncovered_2, Covered);
3325 -- Recheck for overlap after removing choices
3326 -- covered by earlier alternatives.
3328 case Compare (Uncovered_1, Uncovered_2) is
3329 when Disjoint | Contained_By =>
3331 when Contains | Overlaps | Equal =>
3333 ("bad alternative overlapping", N);
3338 Error_Msg_N ("alternatives match same values", N);
3340 Error_Msg_N ("alternatives in wrong order", N);
3344 Union (Target => Covered, Source => Matches (A1));
3347 if (not Others_Seen) and then not Complement_Is_Empty (Covered)
3349 Error_Msg_N ("not all values are covered", N);
3353 Ops.Value_Sets.Free_Value_Sets;
3354 end Check_Case_Pattern_Choices;
3356 -----------------------------------
3357 -- Check_Composite_Case_Selector --
3358 -----------------------------------
3360 procedure Check_Composite_Case_Selector is
3362 if not Is_Composite_Type (Subtyp) then
3364 ("case selector type neither discrete nor composite", N);
3365 elsif Is_Limited_Type (Subtyp) then
3366 Error_Msg_N ("case selector type is limited", N);
3367 elsif Is_Class_Wide_Type (Subtyp) then
3368 Error_Msg_N ("case selector type is class-wide", N);
3370 end Check_Composite_Case_Selector;
3372 -----------------------------
3373 -- Handle_Static_Predicate --
3374 -----------------------------
3376 procedure Handle_Static_Predicate
3385 -- Loop through entries in predicate list, checking each entry.
3386 -- Note that if the list is empty, corresponding to a False
3387 -- predicate, then no choices are checked. If the choice comes
3388 -- from a subtype indication, the given range may have bounds
3389 -- that narrow the predicate choices themselves, so we must
3390 -- consider only those entries within the range of the given
3391 -- subtype indication..
3393 P := First (Static_Discrete_Predicate (Typ));
3394 while Present (P) loop
3396 -- Check that part of the predicate choice is included in the
3399 if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
3400 and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
3403 Set_Sloc (C, Sloc (Choice));
3404 Set_Original_Node (C, Choice);
3406 if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
3407 Set_Low_Bound (C, Lo);
3410 if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then
3411 Set_High_Bound (C, Hi);
3414 Check (C, Low_Bound (C), High_Bound (C));
3420 Set_Has_SP_Choice (Alt);
3421 end Handle_Static_Predicate;
3423 -- Start of processing for Check_Choices
3427 Others_Present := False;
3429 -- If Subtyp is not a discrete type or there was some other error,
3430 -- then don't try any semantic checking on the choices since we have
3433 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
3435 -- Hold on, maybe it isn't a complete mess after all.
3437 if Extensions_Allowed and then Subtyp /= Any_Type then
3438 Check_Composite_Case_Selector;
3439 Check_Case_Pattern_Choices;
3445 -- If Subtyp is not a static subtype Ada 95 requires then we use the
3446 -- bounds of its base type to determine the values covered by the
3447 -- discrete choices.
3449 -- In Ada 2012, if the subtype has a nonstatic predicate the full
3450 -- range of the base type must be covered as well.
3452 if Is_OK_Static_Subtype (Subtyp) then
3453 if not Has_Predicates (Subtyp)
3454 or else Has_Static_Predicate (Subtyp)
3456 Bounds_Type := Subtyp;
3458 Bounds_Type := Choice_Type;
3462 Bounds_Type := Choice_Type;
3465 -- Obtain static bounds of type, unless this is a generic formal
3466 -- discrete type for which all choices will be nonstatic.
3468 if not Is_Generic_Type (Root_Type (Bounds_Type))
3469 or else Ekind (Bounds_Type) /= E_Enumeration_Type
3471 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
3472 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
3475 if Choice_Type = Universal_Integer then
3476 Expected_Type := Any_Integer;
3478 Expected_Type := Choice_Type;
3481 -- Now loop through the case alternatives or record variants
3483 Alt := First (Alternatives);
3484 while Present (Alt) loop
3486 -- If pragma, just analyze it
3488 if Nkind (Alt) = N_Pragma then
3491 -- Otherwise we have an alternative. In most cases the semantic
3492 -- processing leaves the list of choices unchanged
3494 -- Check each choice against its base type
3497 Choice := First (Discrete_Choices (Alt));
3498 while Present (Choice) loop
3499 Kind := Nkind (Choice);
3501 -- Choice is a Range
3504 or else (Kind = N_Attribute_Reference
3505 and then Attribute_Name (Choice) = Name_Range)
3507 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
3509 -- Choice is a subtype name
3511 elsif Is_Entity_Name (Choice)
3512 and then Is_Type (Entity (Choice))
3514 -- Check for inappropriate type
3516 if not Covers (Expected_Type, Etype (Choice)) then
3517 Wrong_Type (Choice, Choice_Type);
3519 -- Type is OK, so check further
3522 E := Entity (Choice);
3524 -- Case of predicated subtype
3526 if Has_Predicates (E) then
3528 -- Use of nonstatic predicate is an error
3530 if not Is_Discrete_Type (E)
3531 or else not Has_Static_Predicate (E)
3532 or else Has_Dynamic_Predicate_Aspect (E)
3534 Bad_Predicated_Subtype_Use
3535 ("cannot use subtype& with non-static "
3536 & "predicate as case alternative",
3537 Choice, E, Suggest_Static => True);
3539 -- Static predicate case. The bounds are those of
3540 -- the given subtype.
3543 Handle_Static_Predicate (E,
3544 Type_Low_Bound (E), Type_High_Bound (E));
3547 -- Not predicated subtype case
3549 elsif not Is_OK_Static_Subtype (E) then
3550 Process_Non_Static_Choice (Choice);
3553 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
3557 -- Choice is a subtype indication
3559 elsif Kind = N_Subtype_Indication then
3560 Resolve_Discrete_Subtype_Indication
3561 (Choice, Expected_Type);
3563 if Etype (Choice) /= Any_Type then
3565 C : constant Node_Id := Constraint (Choice);
3566 R : constant Node_Id := Range_Expression (C);
3567 L : constant Node_Id := Low_Bound (R);
3568 H : constant Node_Id := High_Bound (R);
3571 E := Entity (Subtype_Mark (Choice));
3573 if not Is_OK_Static_Subtype (E) then
3574 Process_Non_Static_Choice (Choice);
3577 if Is_OK_Static_Expression (L)
3579 Is_OK_Static_Expression (H)
3581 if Expr_Value (L) > Expr_Value (H) then
3582 Process_Empty_Choice (Choice);
3584 if Is_Out_Of_Range (L, E) then
3585 Apply_Compile_Time_Constraint_Error
3586 (L, "static value out of range",
3587 CE_Range_Check_Failed);
3590 if Is_Out_Of_Range (H, E) then
3591 Apply_Compile_Time_Constraint_Error
3592 (H, "static value out of range",
3593 CE_Range_Check_Failed);
3598 -- Check applicable predicate values within the
3599 -- bounds of the given range.
3601 if Has_Static_Predicate (E) then
3602 Handle_Static_Predicate (E, L, H);
3605 Check (Choice, L, H);
3611 -- The others choice is only allowed for the last
3612 -- alternative and as its only choice.
3614 elsif Kind = N_Others_Choice then
3615 if not (Choice = First (Discrete_Choices (Alt))
3616 and then Choice = Last (Discrete_Choices (Alt))
3617 and then Alt = Last (Alternatives))
3620 ("the choice OTHERS must appear alone and last",
3625 Others_Present := True;
3626 Others_Choice := Choice;
3628 -- Only other possibility is an expression
3631 Check (Choice, Choice, Choice);
3634 -- Move to next choice
3639 Process_Associated_Node (Alt);
3645 -- Now we can create the Choice_Table, since we know how long
3646 -- it needs to be so we can allocate exactly the right length.
3649 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
3652 -- Now copy the items we collected in the linked list into this
3653 -- newly allocated table (leave entry 0 unused for sorting).
3658 for J in 1 .. Num_Choices loop
3660 Choice_List := T.Nxt;
3661 Choice_Table (J) := T.Val;
3670 Others_Present or else (Choice_Type = Universal_Integer),
3673 -- If no others choice we are all done, otherwise we have one more
3674 -- step, which is to set the Others_Discrete_Choices field of the
3675 -- others choice (to contain all otherwise unspecified choices).
3676 -- Skip this if CE is known to be raised.
3678 if Others_Present and not Raises_CE then
3679 Expand_Others_Choice
3680 (Case_Table => Choice_Table,
3681 Others_Choice => Others_Choice,
3682 Choice_Type => Bounds_Type);
3687 end Generic_Check_Choices;
3689 -----------------------------------------
3690 -- Has_Static_Discriminant_Constraint --
3691 -----------------------------------------
3693 function Has_Static_Discriminant_Constraint
3694 (Subtyp : Entity_Id) return Boolean
3697 if Has_Discriminants (Subtyp) and then Is_Constrained (Subtyp) then
3699 DC_Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Subtyp));
3701 while Present (DC_Elmt) loop
3702 if not All_Composite_Constraints_Static (Node (DC_Elmt)) then
3705 Next_Elmt (DC_Elmt);
3711 end Has_Static_Discriminant_Constraint;
3713 ----------------------------
3714 -- Is_Case_Choice_Pattern --
3715 ----------------------------
3717 function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is
3718 E : Node_Id := Expr;
3720 if not Extensions_Allowed then
3726 when N_Case_Statement_Alternative
3727 | N_Case_Expression_Alternative
3729 -- We could return False if selecting expression is discrete,
3730 -- but this doesn't seem to be worth the bother.
3734 | N_Statement_Other_Than_Procedure_Call
3735 | N_Procedure_Call_Statement
3744 end Is_Case_Choice_Pattern;