1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2023, 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
;
51 with Warnsw
; use Warnsw
;
53 with Ada
.Unchecked_Deallocation
;
55 with GNAT
.Heap_Sort_G
;
58 package body Sem_Case
is
60 type Choice_Bounds
is record
65 -- Represent one choice bounds entry with Lo and Hi values, Node points
66 -- to the choice node itself.
68 type Choice_Table_Type
is array (Nat
range <>) of Choice_Bounds
;
69 -- Table type used to sort the choices present in a case statement or
70 -- record variant. The actual entries are stored in 1 .. Last, but we
71 -- have a 0 entry for use in sorting.
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 procedure Check_Choice_Set
78 (Choice_Table
: in out Choice_Table_Type
;
79 Bounds_Type
: Entity_Id
;
81 Others_Present
: Boolean;
83 -- This is the procedure which verifies that a set of case alternatives
84 -- or record variant choices has no duplicates, and covers the range
85 -- specified by Bounds_Type. Choice_Table contains the discrete choices
86 -- to check. These must start at position 1.
88 -- Furthermore Choice_Table (0) must exist. This element is used by
89 -- the sorting algorithm as a temporary. Others_Present is a flag
90 -- indicating whether or not an Others choice is present. Finally
91 -- Msg_Sloc gives the source location of the construct containing the
92 -- choices in the Choice_Table.
94 -- Bounds_Type is the type whose range must be covered by the alternatives
96 -- Subtyp is the subtype of the expression. If its bounds are nonstatic
97 -- the alternatives must cover its base type.
99 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
;
100 -- Given a Pos value of enumeration type Ctype, returns the name
101 -- ID of an appropriate string to be used in error message output.
103 function Has_Static_Discriminant_Constraint
104 (Subtyp
: Entity_Id
) return Boolean;
105 -- Returns True if the given subtype is subject to a discriminant
106 -- constraint and at least one of the constraint values is nonstatic.
108 package Composite_Case_Ops
is
110 Simplified_Composite_Coverage_Rules
: constant Boolean := True;
111 -- Indicates that, as a temporary stopgap, we implement
112 -- simpler coverage-checking rules when casing on a
113 -- composite selector:
114 -- 1) Require that an Others choice must be given, regardless
115 -- of whether all possible values are covered explicitly.
116 -- 2) No legality checks regarding overlapping choices.
118 function Box_Value_Required
(Subtyp
: Entity_Id
) return Boolean;
119 -- If result is True, then the only allowed value (in a choice
120 -- aggregate) for a component of this (sub)type is a box. This rule
121 -- means that such a component can be ignored in case alternative
122 -- selection. This in turn implies that it is ok if the component
123 -- type doesn't meet the usual restrictions, such as not being an
124 -- access/task/protected type, since nobody is going to look
127 function Choice_Count
(Alternatives
: List_Id
) return Nat
;
128 -- The sum of the number of choices for each alternative in the given
131 function Normalized_Case_Expr_Type
132 (Case_Statement
: Node_Id
) return Entity_Id
;
133 -- Usually returns the Etype of the selector expression of the
134 -- case statement. However, in the case of a constrained composite
135 -- subtype with a nonstatic constraint, returns the unconstrained
138 function Scalar_Part_Count
(Subtyp
: Entity_Id
) return Nat
;
139 -- Given the composite type Subtyp of a case selector, returns the
140 -- number of scalar parts in an object of this type. This is the
141 -- dimensionality of the associated Cartesian product space.
143 package Array_Case_Ops
is
144 function Array_Choice_Length
(Choice
: Node_Id
) return Nat
;
145 -- Given a choice expression of an array type, returns its length.
147 function Unconstrained_Array_Effective_Length
148 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
;
149 -- If the nominal subtype of the case selector is unconstrained,
150 -- then use the length of the longest choice of the case statement.
151 -- Components beyond that index value will not influence the case
152 -- selection decision.
154 function Unconstrained_Array_Scalar_Part_Count
155 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
;
156 -- Same as Scalar_Part_Count except that the value used for the
157 -- "length" of the array subtype being cased on is determined by
158 -- calling Unconstrained_Array_Effective_Length.
162 Case_Statement
: Node_Id
;
163 package Choice_Analysis
is
167 type Alternative_Id
is
168 new Int
range 1 .. List_Length
(Alternatives
(Case_Statement
));
170 new Int
range 1 .. Choice_Count
(Alternatives
(Case_Statement
));
172 Case_Expr_Type
: constant Entity_Id
:=
173 Normalized_Case_Expr_Type
(Case_Statement
);
175 Unconstrained_Array_Case
: constant Boolean :=
176 Is_Array_Type
(Case_Expr_Type
)
177 and then not Is_Constrained
(Case_Expr_Type
);
179 -- If Unconstrained_Array_Case is True, choice lengths may differ:
180 -- when "Aaa" | "Bb" | "C" | "" =>
182 -- Strictly speaking, the name "Unconstrained_Array_Case" is
183 -- slightly imprecise; a subtype with a nonstatic constraint is
184 -- also treated as unconstrained (see Normalize_Case_Expr_Type).
186 type Part_Id
is new Int
range
187 1 .. (if Unconstrained_Array_Case
188 then Unconstrained_Array_Scalar_Part_Count
189 (Case_Expr_Type
, Case_Statement
)
190 else Scalar_Part_Count
(Case_Expr_Type
));
192 type Discrete_Range_Info
is
196 function "=" (X
, Y
: Discrete_Range_Info
) return Boolean is abstract;
197 -- Here (and below), we don't use "=", which is a good thing,
198 -- because it wouldn't work, because the user-defined "=" on
199 -- Uint does not compose according to Ada rules.
201 type Composite_Range_Info
is array (Part_Id
) of Discrete_Range_Info
;
202 function "=" (X
, Y
: Composite_Range_Info
) return Boolean is abstract;
204 type Choice_Range_Info
(Is_Others
: Boolean := False) is
208 Ranges
: Composite_Range_Info
;
213 pragma Annotate
(CodePeer
, False_Positive
, "raise exception",
214 "function is abstract, hence never called");
215 function "=" (X
, Y
: Choice_Range_Info
) return Boolean is abstract;
217 type Choices_Range_Info
is array (Choice_Id
) of Choice_Range_Info
;
219 package Value_Sets
is
221 type Value_Set
is private;
222 -- A set of points in the Cartesian product space defined
223 -- by the composite type of the case selector.
224 -- Implemented as an access type.
226 type Set_Comparison
is
227 (Disjoint
, Equal
, Contains
, Contained_By
, Overlaps
);
229 function Compare
(S1
, S2
: Value_Set
) return Set_Comparison
;
230 -- If either argument (or both) is empty, result is Disjoint.
231 -- Otherwise, result is Equal if the two sets are equal.
233 Empty
: constant Value_Set
;
235 function Matching_Values
236 (Info
: Composite_Range_Info
) return Value_Set
;
237 -- The Cartesian product of the given array of ranges
238 -- (excluding any values outside the Cartesian product of the
239 -- component ranges).
241 procedure Union
(Target
: in out Value_Set
; Source
: Value_Set
);
242 -- Add elements of Source into Target
244 procedure Remove
(Target
: in out Value_Set
; Source
: Value_Set
);
245 -- Remove elements of Source from Target
247 function Complement_Is_Empty
(Set
: Value_Set
) return Boolean;
248 -- Return True iff the set is "maximal", in the sense that it
249 -- includes every value in the Cartesian product of the
252 procedure Free_Value_Sets
;
253 -- Reclaim storage associated with implementation of this package.
256 type Value_Set
is new Natural;
257 -- An index for a table that will be declared in the package body.
259 Empty
: constant Value_Set
:= 0;
263 type Single_Choice_Info
(Is_Others
: Boolean := False) is
265 Alternative
: Alternative_Id
;
268 Matches
: Value_Sets
.Value_Set
;
274 type Choices_Info
is array (Choice_Id
) of Single_Choice_Info
;
276 function Analysis
return Choices_Info
;
277 -- Parse the case choices in order to determine the set of
278 -- matching values associated with each choice.
280 type Bound_Values
is array (Positive range <>) of Node_Id
;
283 end Composite_Case_Ops
;
285 procedure Expand_Others_Choice
286 (Case_Table
: Choice_Table_Type
;
287 Others_Choice
: Node_Id
;
288 Choice_Type
: Entity_Id
);
289 -- The case table is the table generated by a call to Check_Choices
290 -- (with just 1 .. Last_Choice entries present). Others_Choice is a
291 -- pointer to the N_Others_Choice node (this routine is only called if
292 -- an others choice is present), and Choice_Type is the discrete type
293 -- of the bounds. The effect of this call is to analyze the cases and
294 -- determine the set of values covered by others. This choice list is
295 -- set in the Others_Discrete_Choices field of the N_Others_Choice node.
297 ----------------------
298 -- Check_Choice_Set --
299 ----------------------
301 procedure Check_Choice_Set
302 (Choice_Table
: in out Choice_Table_Type
;
303 Bounds_Type
: Entity_Id
;
305 Others_Present
: Boolean;
308 Predicate_Error
: Boolean := False;
309 -- Flag to prevent cascaded errors when a static predicate is known to
310 -- be violated by one choice.
312 Num_Choices
: constant Nat
:= Choice_Table
'Last;
314 procedure Check_Against_Predicate
315 (Pred
: in out Node_Id
;
316 Choice
: Choice_Bounds
;
317 Prev_Lo
: in out Uint
;
318 Prev_Hi
: in out Uint
;
319 Error
: in out Boolean);
320 -- Determine whether a choice covers legal values as defined by a static
321 -- predicate set. Pred is a static predicate range. Choice is the choice
322 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
323 -- choice that covered a predicate set. Error denotes whether the check
324 -- found an illegal intersection.
326 procedure Check_Duplicates
;
327 -- Check for duplicate choices, and call Dup_Choice if there are any
328 -- such errors. Note that predicates are irrelevant here.
330 procedure Dup_Choice
(Lo
, Hi
: Uint
; C
: Node_Id
);
331 -- Post message "duplication of choice value(s) bla bla at xx". Message
332 -- is posted at location C. Caller sets Error_Msg_Sloc for xx.
334 procedure Explain_Non_Static_Bound
;
335 -- Called when we find a nonstatic bound, requiring the base type to
336 -- be covered. Provides where possible a helpful explanation of why the
337 -- bounds are nonstatic, since this is not always obvious.
339 function Lt_Choice
(C1
, C2
: Natural) return Boolean;
340 -- Comparison routine for comparing Choice_Table entries. Use the lower
341 -- bound of each Choice as the key.
343 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
);
344 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
);
345 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
);
346 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
);
347 -- Issue an error message indicating that there are missing choices,
348 -- followed by the image of the missing choices themselves which lie
349 -- between Value1 and Value2 inclusive.
351 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
);
352 -- Emit an error message for each non-covered static predicate set.
353 -- Prev_Hi denotes the upper bound of the last choice covering a set.
355 procedure Move_Choice
(From
: Natural; To
: Natural);
356 -- Move routine for sorting the Choice_Table
358 package Sorting
is new GNAT
.Heap_Sort_G
(Move_Choice
, Lt_Choice
);
360 -----------------------------
361 -- Check_Against_Predicate --
362 -----------------------------
364 procedure Check_Against_Predicate
365 (Pred
: in out Node_Id
;
366 Choice
: Choice_Bounds
;
367 Prev_Lo
: in out Uint
;
368 Prev_Hi
: in out Uint
;
369 Error
: in out Boolean)
371 procedure Illegal_Range
375 -- Emit an error message regarding a choice that clashes with the
376 -- legal static predicate sets. Loc is the location of the choice
377 -- that introduced the illegal range. Lo .. Hi is the range.
379 function Inside_Range
382 Val
: Uint
) return Boolean;
383 -- Determine whether position Val within a discrete type is within
384 -- the range Lo .. Hi inclusive.
390 procedure Illegal_Range
396 Error_Msg_Name_1
:= Chars
(Bounds_Type
);
401 if Is_Integer_Type
(Bounds_Type
) then
402 Error_Msg_Uint_1
:= Lo
;
403 Error_Msg
("static predicate on % excludes value ^!", Loc
);
405 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
406 Error_Msg
("static predicate on % excludes value %!", Loc
);
412 if Is_Integer_Type
(Bounds_Type
) then
413 Error_Msg_Uint_1
:= Lo
;
414 Error_Msg_Uint_2
:= Hi
;
416 ("static predicate on % excludes range ^ .. ^!", Loc
);
418 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
419 Error_Msg_Name_3
:= Choice_Image
(Hi
, Bounds_Type
);
421 ("static predicate on % excludes range % .. %!", Loc
);
430 function Inside_Range
433 Val
: Uint
) return Boolean
436 return Lo
<= Val
and then Val
<= Hi
;
441 Choice_Hi
: constant Uint
:= Expr_Value
(Choice
.Hi
);
442 Choice_Lo
: constant Uint
:= Expr_Value
(Choice
.Lo
);
450 -- Start of processing for Check_Against_Predicate
453 -- Find the proper error message location
455 if Present
(Choice
.Node
) then
463 if Present
(Pred
) then
464 Pred_Lo
:= Expr_Value
(Low_Bound
(Pred
));
465 Pred_Hi
:= Expr_Value
(High_Bound
(Pred
));
467 -- Previous choices managed to satisfy all static predicate sets
470 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
475 -- Step 1: Ignore duplicate choices, other than to set the flag,
476 -- because these were already detected by Check_Duplicates.
478 if Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Lo
)
479 or else Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Hi
)
483 -- Step 2: Detect full coverage
485 -- Choice_Lo Choice_Hi
489 elsif Choice_Lo
= Pred_Lo
and then Choice_Hi
= Pred_Hi
then
490 Prev_Lo
:= Choice_Lo
;
491 Prev_Hi
:= Choice_Hi
;
494 -- Step 3: Detect all cases where a choice mentions values that are
495 -- not part of the static predicate sets.
497 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
498 -- +-----------+ . . . . . +=========+
501 elsif Choice_Lo
< Pred_Lo
and then Choice_Hi
< Pred_Lo
then
502 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
505 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
506 -- +-----------+=========+===========+
509 elsif Choice_Lo
< Pred_Lo
510 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Hi
)
512 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
515 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
516 -- +=========+ . . . . +-----------+
519 elsif Pred_Lo
< Choice_Lo
and then Pred_Hi
< Choice_Lo
then
520 if Others_Present
then
522 -- Current predicate set is covered by others clause.
527 Missing_Choice
(Pred_Lo
, Pred_Hi
);
531 -- There may be several static predicate sets between the current
532 -- one and the choice. Inspect the next static predicate set.
535 Check_Against_Predicate
542 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
543 -- +=========+===========+-----------+
546 elsif Pred_Hi
< Choice_Hi
547 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Lo
)
551 -- The choice may fall in a static predicate set. If this is the
552 -- case, avoid mentioning legal values in the error message.
554 if Present
(Pred
) then
555 Next_Lo
:= Expr_Value
(Low_Bound
(Pred
));
556 Next_Hi
:= Expr_Value
(High_Bound
(Pred
));
558 -- The next static predicate set is to the right of the choice
560 if Choice_Hi
< Next_Lo
and then Choice_Hi
< Next_Hi
then
561 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
563 Illegal_Range
(Loc
, Pred_Hi
+ 1, Next_Lo
- 1);
566 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
571 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
572 -- +-----------+=========+-----------+
573 -- ^ illegal ^ ^ illegal ^
575 -- Emit an error on the low gap, disregard the upper gap
577 elsif Choice_Lo
< Pred_Lo
and then Pred_Hi
< Choice_Hi
then
578 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
581 -- Step 4: Detect all cases of partial or missing coverage
583 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
584 -- +=========+==========+===========+
588 -- An "others" choice covers all gaps
590 if Others_Present
then
591 Prev_Lo
:= Choice_Lo
;
592 Prev_Hi
:= Choice_Hi
;
594 -- Check whether predicate set is fully covered by choice
596 if Pred_Hi
= Choice_Hi
then
600 -- Choice_Lo Choice_Hi Pred_Hi
601 -- +===========+===========+
604 -- The upper gap may be covered by a subsequent choice
606 elsif Pred_Lo
= Choice_Lo
then
607 Prev_Lo
:= Choice_Lo
;
608 Prev_Hi
:= Choice_Hi
;
610 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
611 -- +===========+=========+===========+===========+
612 -- ^ covered ^ ^ gap ^
614 else pragma Assert
(Pred_Lo
< Choice_Lo
);
616 -- A previous choice covered the gap up to the current choice
618 if Prev_Hi
= Choice_Lo
- 1 then
619 Prev_Lo
:= Choice_Lo
;
620 Prev_Hi
:= Choice_Hi
;
622 if Choice_Hi
= Pred_Hi
then
626 -- The previous choice did not intersect with the current
627 -- static predicate set.
629 elsif Prev_Hi
< Pred_Lo
then
630 Missing_Choice
(Pred_Lo
, Choice_Lo
- 1);
633 -- The previous choice covered part of the static predicate set
634 -- but there is a gap after Prev_Hi.
637 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
642 end Check_Against_Predicate
;
644 ----------------------
645 -- Check_Duplicates --
646 ----------------------
648 procedure Check_Duplicates
is
652 Prev_Choice
: Node_Id
:= Empty
;
656 Prev_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
658 for Outer_Index
in 2 .. Num_Choices
loop
659 Choice_Lo
:= Expr_Value
(Choice_Table
(Outer_Index
).Lo
);
660 Choice_Hi
:= Expr_Value
(Choice_Table
(Outer_Index
).Hi
);
662 -- Choices overlap; this is an error
664 if Choice_Lo
<= Prev_Hi
then
665 Choice
:= Choice_Table
(Outer_Index
).Node
;
667 -- Find first previous choice that overlaps
669 for Inner_Index
in 1 .. Outer_Index
- 1 loop
671 Expr_Value
(Choice_Table
(Inner_Index
).Hi
)
673 Prev_Choice
:= Choice_Table
(Inner_Index
).Node
;
678 pragma Assert
(Present
(Prev_Choice
));
680 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
681 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
682 Dup_Choice
(Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Choice
);
684 Error_Msg_Sloc
:= Sloc
(Choice
);
686 (Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Prev_Choice
);
690 if Choice_Hi
> Prev_Hi
then
691 Prev_Hi
:= Choice_Hi
;
694 end Check_Duplicates
;
700 procedure Dup_Choice
(Lo
, Hi
: Uint
; C
: Node_Id
) is
702 -- In some situations, we call this with a null range, and obviously
703 -- we don't want to complain in this case.
709 -- Case of only one value that is duplicated
715 if Is_Integer_Type
(Bounds_Type
) then
717 -- We have an integer value, Lo, but if the given choice
718 -- placement is a constant with that value, then use the
719 -- name of that constant instead in the message:
721 if Nkind
(C
) = N_Identifier
722 and then Compile_Time_Known_Value
(C
)
723 and then Expr_Value
(C
) = Lo
726 ("duplication of choice value: &#!", Original_Node
(C
));
728 -- Not that special case, so just output the integer value
731 Error_Msg_Uint_1
:= Lo
;
733 ("duplication of choice value: ^#!", Original_Node
(C
));
739 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
741 ("duplication of choice value: %#!", Original_Node
(C
));
744 -- More than one choice value, so print range of values
749 if Is_Integer_Type
(Bounds_Type
) then
751 -- Similar to the above, if C is a range of known values which
752 -- match Lo and Hi, then use the names. We have to go to the
753 -- original nodes, since the values will have been rewritten
754 -- to their integer values.
756 if Nkind
(C
) = N_Range
757 and then Nkind
(Original_Node
(Low_Bound
(C
))) = N_Identifier
758 and then Nkind
(Original_Node
(High_Bound
(C
))) = N_Identifier
759 and then Compile_Time_Known_Value
(Low_Bound
(C
))
760 and then Compile_Time_Known_Value
(High_Bound
(C
))
761 and then Expr_Value
(Low_Bound
(C
)) = Lo
762 and then Expr_Value
(High_Bound
(C
)) = Hi
764 Error_Msg_Node_2
:= Original_Node
(High_Bound
(C
));
766 ("duplication of choice values: & .. &#!",
767 Original_Node
(Low_Bound
(C
)));
769 -- Not that special case, output integer values
772 Error_Msg_Uint_1
:= Lo
;
773 Error_Msg_Uint_2
:= Hi
;
775 ("duplication of choice values: ^ .. ^#!",
782 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
783 Error_Msg_Name_2
:= Choice_Image
(Hi
, Bounds_Type
);
785 ("duplication of choice values: % .. %#!", Original_Node
(C
));
790 ------------------------------
791 -- Explain_Non_Static_Bound --
792 ------------------------------
794 procedure Explain_Non_Static_Bound
is
798 if Nkind
(Case_Node
) = N_Variant_Part
then
799 Expr
:= Name
(Case_Node
);
801 Expr
:= Expression
(Case_Node
);
804 if Bounds_Type
/= Subtyp
then
806 -- If the case is a variant part, the expression is given by the
807 -- discriminant itself, and the bounds are the culprits.
809 if Nkind
(Case_Node
) = N_Variant_Part
then
811 ("bounds of & are not static, "
812 & "alternatives must cover base type!", Expr
, Expr
);
814 -- If this is a case statement, the expression may be nonstatic
815 -- or else the subtype may be at fault.
817 elsif Is_Entity_Name
(Expr
) then
819 ("bounds of & are not static, "
820 & "alternatives must cover base type!", Expr
, Expr
);
824 ("subtype of expression is not static, "
825 & "alternatives must cover base type!", Expr
);
828 -- Otherwise the expression is not static, even if the bounds of the
829 -- type are, or else there are missing alternatives. If both, the
830 -- additional information may be redundant but harmless. Examine
831 -- whether original node is an entity, because it may have been
832 -- constant-folded to a literal if value is known.
834 elsif not Is_Entity_Name
(Original_Node
(Expr
)) then
836 ("subtype of expression is not static, "
837 & "alternatives must cover base type!", Expr
);
839 end Explain_Non_Static_Bound
;
845 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
848 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
850 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
857 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
) is
859 Missing_Choice
(Expr_Value
(Value1
), Expr_Value
(Value2
));
862 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
) is
864 Missing_Choice
(Expr_Value
(Value1
), Value2
);
867 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
) is
869 Missing_Choice
(Value1
, Expr_Value
(Value2
));
876 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
) is
878 -- AI05-0188 : within an instance the non-others choices do not have
879 -- to belong to the actual subtype.
881 if Ada_Version
>= Ada_2012
and then In_Instance
then
884 -- In some situations, we call this with a null range, and obviously
885 -- we don't want to complain in this case.
887 elsif Value1
> Value2
then
890 -- If predicate is already known to be violated, do not check for
891 -- coverage error, to prevent cascaded messages.
893 elsif Predicate_Error
then
897 -- Case of only one value that is missing
899 if Value1
= Value2
then
900 if Is_Integer_Type
(Bounds_Type
) then
901 Error_Msg_Uint_1
:= Value1
;
902 Error_Msg_N
("missing case value: ^!", Case_Node
);
904 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
905 Error_Msg_N
("missing case value: %!", Case_Node
);
908 -- More than one choice value, so print range of values
911 if Is_Integer_Type
(Bounds_Type
) then
912 Error_Msg_Uint_1
:= Value1
;
913 Error_Msg_Uint_2
:= Value2
;
914 Error_Msg_N
("missing case values: ^ .. ^!", Case_Node
);
916 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
917 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
918 Error_Msg_N
("missing case values: % .. %!", Case_Node
);
923 ---------------------
924 -- Missing_Choices --
925 ---------------------
927 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
) is
934 while Present
(Set
) loop
935 Lo
:= Expr_Value
(Low_Bound
(Set
));
936 Hi
:= Expr_Value
(High_Bound
(Set
));
938 -- A choice covered part of a static predicate set
940 if Lo
<= Prev_Hi
and then Prev_Hi
< Hi
then
941 Missing_Choice
(Prev_Hi
+ 1, Hi
);
944 Missing_Choice
(Lo
, Hi
);
955 procedure Move_Choice
(From
: Natural; To
: Natural) is
957 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
962 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
963 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
964 Has_Predicate
: constant Boolean :=
965 Is_OK_Static_Subtype
(Bounds_Type
)
966 and then Has_Static_Predicate
(Bounds_Type
);
974 -- Start of processing for Check_Choice_Set
977 -- If the case is part of a predicate aspect specification, do not
978 -- recheck it against itself.
980 if Present
(Parent
(Case_Node
))
981 and then Nkind
(Parent
(Case_Node
)) = N_Aspect_Specification
986 -- Choice_Table must start at 0 which is an unused location used by the
987 -- sorting algorithm. However the first valid position for a discrete
990 pragma Assert
(Choice_Table
'First = 0);
992 -- The choices do not cover the base range. Emit an error if "others" is
993 -- not available and return as there is no need for further processing.
995 if Num_Choices
= 0 then
996 if not Others_Present
then
997 Missing_Choice
(Bounds_Lo
, Bounds_Hi
);
1003 Sorting
.Sort
(Positive (Choice_Table
'Last));
1005 -- First check for duplicates. This involved the choices; predicates, if
1006 -- any, are irrelevant.
1010 -- Then check for overlaps
1012 -- If the subtype has a static predicate, the predicate defines subsets
1013 -- of legal values and requires finer-grained analysis.
1015 -- Note that in GNAT the predicate is considered static if the predicate
1016 -- expression is static, independently of whether the aspect mentions
1017 -- Static explicitly.
1019 if Has_Predicate
then
1020 Pred
:= First
(Static_Discrete_Predicate
(Bounds_Type
));
1022 -- Make initial value smaller than 'First of type, so that first
1023 -- range comparison succeeds. This applies both to integer types
1024 -- and to enumeration types.
1026 Prev_Lo
:= Expr_Value
(Type_Low_Bound
(Bounds_Type
)) - 1;
1030 Error
: Boolean := False;
1032 for Index
in 1 .. Num_Choices
loop
1033 Check_Against_Predicate
1035 Choice
=> Choice_Table
(Index
),
1040 -- The analysis detected an illegal intersection between a
1041 -- choice and a static predicate set. Do not examine other
1042 -- choices unless all errors are requested.
1045 Predicate_Error
:= True;
1047 if not All_Errors_Mode
then
1054 if Predicate_Error
then
1058 -- The choices may legally cover some of the static predicate sets,
1059 -- but not all. Emit an error for each non-covered set.
1061 if not Others_Present
then
1062 Missing_Choices
(Pred
, Prev_Hi
);
1068 Choice_Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
1069 Choice_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
1070 Prev_Hi
:= Choice_Hi
;
1072 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Choice_Lo
then
1073 Missing_Choice
(Bounds_Lo
, Choice_Lo
- 1);
1075 -- If values are missing outside of the subtype, add explanation.
1076 -- No additional message if only one value is missing.
1078 if Expr_Value
(Bounds_Lo
) < Choice_Lo
- 1 then
1079 Explain_Non_Static_Bound
;
1083 for Index
in 2 .. Num_Choices
loop
1084 Choice_Lo
:= Expr_Value
(Choice_Table
(Index
).Lo
);
1085 Choice_Hi
:= Expr_Value
(Choice_Table
(Index
).Hi
);
1087 if Choice_Lo
> Prev_Hi
+ 1 and then not Others_Present
then
1088 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
1091 if Choice_Hi
> Prev_Hi
then
1092 Prev_Hi
:= Choice_Hi
;
1096 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Prev_Hi
then
1097 Missing_Choice
(Prev_Hi
+ 1, Bounds_Hi
);
1099 if Expr_Value
(Bounds_Hi
) > Prev_Hi
+ 1 then
1100 Explain_Non_Static_Bound
;
1104 end Check_Choice_Set
;
1110 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
1111 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
1116 -- For character, or wide [wide] character. If 7-bit ASCII graphic
1117 -- range, then build and return appropriate character literal name
1119 if Is_Standard_Character_Type
(Ctype
) then
1120 C
:= UI_To_Int
(Value
);
1122 if C
in 16#
20#
.. 16#
7E#
then
1123 Set_Character_Literal_Name
(UI_To_CC
(Value
));
1127 -- For user defined enumeration type, find enum/char literal
1130 Lit
:= First_Literal
(Rtp
);
1132 for J
in 1 .. UI_To_Int
(Value
) loop
1136 -- If enumeration literal, just return its value
1138 if Nkind
(Lit
) = N_Defining_Identifier
then
1141 -- For character literal, get the name and use it if it is
1142 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
1145 Get_Decoded_Name_String
(Chars
(Lit
));
1148 and then Name_Buffer
(2) in
1149 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
1156 -- If we fall through, we have a character literal which is not in
1157 -- the 7-bit ASCII graphic set. For such cases, we construct the
1158 -- name "type'val(nnn)" where type is the choice type, and nnn is
1159 -- the pos value passed as an argument to Choice_Image.
1161 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
1163 Add_Str_To_Name_Buffer
("'val(");
1165 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
1166 Add_Char_To_Name_Buffer
(')');
1170 package body Composite_Case_Ops
is
1172 function Static_Array_Length
(Subtyp
: Entity_Id
) return Nat
;
1173 -- Given a one-dimensional constrained array subtype with
1174 -- statically known bounds, return its length.
1176 -------------------------
1177 -- Static_Array_Length --
1178 -------------------------
1180 function Static_Array_Length
(Subtyp
: Entity_Id
) return Nat
is
1181 pragma Assert
(Is_Constrained
(Subtyp
));
1182 pragma Assert
(Number_Dimensions
(Subtyp
) = 1);
1183 Index
: constant Node_Id
:= First_Index
(Subtyp
);
1184 pragma Assert
(Is_OK_Static_Range
(Index
));
1185 Lo
: constant Uint
:= Expr_Value
(Low_Bound
(Index
));
1186 Hi
: constant Uint
:= Expr_Value
(High_Bound
(Index
));
1187 Len
: constant Uint
:= UI_Max
(0, (Hi
- Lo
) + 1);
1189 return UI_To_Int
(Len
);
1190 end Static_Array_Length
;
1192 ------------------------
1193 -- Box_Value_Required --
1194 ------------------------
1196 function Box_Value_Required
(Subtyp
: Entity_Id
) return Boolean is
1197 -- Some of these restrictions will be relaxed eventually, but best
1198 -- to initially err in the direction of being too restrictive.
1200 if Has_Predicates
(Subtyp
) then
1202 elsif Is_Discrete_Type
(Subtyp
) then
1203 if not Is_Static_Subtype
(Subtyp
) then
1205 elsif Is_Enumeration_Type
(Subtyp
)
1206 and then Has_Enumeration_Rep_Clause
(Subtyp
)
1207 -- Maybe enumeration rep clauses can be ignored here?
1211 elsif Is_Array_Type
(Subtyp
) then
1212 if Number_Dimensions
(Subtyp
) /= 1 then
1214 elsif not Is_Constrained
(Subtyp
) then
1215 if not Is_Static_Subtype
(Etype
(First_Index
(Subtyp
))) then
1218 elsif not Is_OK_Static_Range
(First_Index
(Subtyp
)) then
1221 elsif Is_Record_Type
(Subtyp
) then
1222 if Has_Discriminants
(Subtyp
)
1223 and then Is_Constrained
(Subtyp
)
1224 and then not Has_Static_Discriminant_Constraint
(Subtyp
)
1226 -- Perhaps treat differently the case where Subtyp is the
1227 -- subtype of the top-level selector expression, as opposed
1228 -- to the subtype of some subcomponent thereof.
1232 -- Return True for any type that is not a discrete type,
1233 -- a record type, or an array type.
1238 end Box_Value_Required
;
1244 function Choice_Count
(Alternatives
: List_Id
) return Nat
is
1246 Alt
: Node_Id
:= First
(Alternatives
);
1248 while Present
(Alt
) loop
1249 Result
:= Result
+ List_Length
(Discrete_Choices
(Alt
));
1255 -------------------------------
1256 -- Normalized_Case_Expr_Type --
1257 -------------------------------
1259 function Normalized_Case_Expr_Type
1260 (Case_Statement
: Node_Id
) return Entity_Id
1262 Unnormalized
: constant Entity_Id
:=
1263 Etype
(Expression
(Case_Statement
));
1265 Is_Dynamically_Constrained_Array
: constant Boolean :=
1266 Is_Array_Type
(Unnormalized
)
1267 and then Is_Constrained
(Unnormalized
)
1268 and then not Has_Static_Array_Bounds
(Unnormalized
);
1270 Is_Dynamically_Constrained_Record
: constant Boolean :=
1271 Is_Record_Type
(Unnormalized
)
1272 and then Has_Discriminants
(Unnormalized
)
1273 and then Is_Constrained
(Unnormalized
)
1274 and then not Has_Static_Discriminant_Constraint
(Unnormalized
);
1276 if Is_Dynamically_Constrained_Array
1277 or Is_Dynamically_Constrained_Record
1279 return Base_Type
(Unnormalized
);
1281 return Unnormalized
;
1283 end Normalized_Case_Expr_Type
;
1285 -----------------------
1286 -- Scalar_Part_Count --
1287 -----------------------
1289 function Scalar_Part_Count
(Subtyp
: Entity_Id
) return Nat
is
1291 if Box_Value_Required
(Subtyp
) then
1292 return 0; -- component does not participate in case selection
1293 elsif Is_Scalar_Type
(Subtyp
) then
1295 elsif Is_Array_Type
(Subtyp
) then
1296 return Static_Array_Length
(Subtyp
)
1297 * Scalar_Part_Count
(Component_Type
(Subtyp
));
1298 elsif Is_Record_Type
(Subtyp
) then
1301 Comp
: Entity_Id
:= First_Component_Or_Discriminant
1302 (Base_Type
(Subtyp
));
1304 while Present
(Comp
) loop
1305 Result
:= Result
+ Scalar_Part_Count
(Etype
(Comp
));
1306 Next_Component_Or_Discriminant
(Comp
);
1311 pragma Assert
(Serious_Errors_Detected
> 0);
1314 end Scalar_Part_Count
;
1316 package body Array_Case_Ops
is
1318 -------------------------
1319 -- Array_Choice_Length --
1320 -------------------------
1322 function Array_Choice_Length
(Choice
: Node_Id
) return Nat
is
1324 case Nkind
(Choice
) is
1325 when N_String_Literal
=>
1326 return String_Length
(Strval
(Choice
));
1329 Bounds
: constant Node_Id
:=
1330 Aggregate_Bounds
(Choice
);
1331 pragma Assert
(Is_OK_Static_Range
(Bounds
));
1332 Lo
: constant Uint
:=
1333 Expr_Value
(Low_Bound
(Bounds
));
1334 Hi
: constant Uint
:=
1335 Expr_Value
(High_Bound
(Bounds
));
1336 Len
: constant Uint
:= (Hi
- Lo
) + 1;
1338 return UI_To_Int
(Len
);
1340 when N_Has_Entity
=>
1341 if Present
(Entity
(Choice
))
1342 and then Ekind
(Entity
(Choice
)) = E_Constant
1344 return Array_Choice_Length
1345 (Expression
(Parent
(Entity
(Choice
))));
1347 when N_Others_Choice
=>
1353 if Nkind
(Original_Node
(Choice
))
1354 in N_String_Literal | N_Aggregate
1356 return Array_Choice_Length
(Original_Node
(Choice
));
1359 Error_Msg_N
("Unsupported case choice", Choice
);
1361 end Array_Choice_Length
;
1363 ------------------------------------------
1364 -- Unconstrained_Array_Effective_Length --
1365 ------------------------------------------
1367 function Unconstrained_Array_Effective_Length
1368 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
1370 pragma Assert
(Is_Array_Type
(Array_Type
));
1371 -- Array_Type is otherwise unreferenced for now.
1374 Alt
: Node_Id
:= First
(Alternatives
(Case_Statement
));
1376 while Present
(Alt
) loop
1378 Choice
: Node_Id
:= First
(Discrete_Choices
(Alt
));
1380 while Present
(Choice
) loop
1381 Result
:= Nat
'Max (Result
, Array_Choice_Length
(Choice
));
1389 end Unconstrained_Array_Effective_Length
;
1391 -------------------------------------------
1392 -- Unconstrained_Array_Scalar_Part_Count --
1393 -------------------------------------------
1395 function Unconstrained_Array_Scalar_Part_Count
1396 (Array_Type
: Entity_Id
; Case_Statement
: Node_Id
) return Nat
1399 -- Add one for the length, which is treated like a discriminant
1401 return 1 + (Unconstrained_Array_Effective_Length
1402 (Array_Type
=> Array_Type
,
1403 Case_Statement
=> Case_Statement
)
1404 * Scalar_Part_Count
(Component_Type
(Array_Type
)));
1405 end Unconstrained_Array_Scalar_Part_Count
;
1409 package body Choice_Analysis
is
1411 function Component_Bounds_Info
return Composite_Range_Info
;
1412 -- Returns the (statically known) bounds for each component.
1413 -- The selector expression value (or any other value of the type
1414 -- of the selector expression) can be thought of as a point in the
1415 -- Cartesian product of these sets.
1417 function Parse_Choice
(Choice
: Node_Id
;
1418 Alt
: Node_Id
) return Choice_Range_Info
;
1419 -- Extract Choice_Range_Info from a Choice node
1421 ---------------------------
1422 -- Component_Bounds_Info --
1423 ---------------------------
1425 function Component_Bounds_Info
return Composite_Range_Info
is
1426 Result
: Composite_Range_Info
;
1427 Next
: Part_Id
:= 1;
1428 Done
: Boolean := False;
1430 procedure Update_Result
(Info
: Discrete_Range_Info
);
1431 -- Initialize first remaining uninitialized element of Result.
1432 -- Also set Next and Done.
1438 procedure Update_Result
(Info
: Discrete_Range_Info
) is
1440 Result
(Next
) := Info
;
1441 if Next
/= Part_Id
'Last then
1444 pragma Assert
(not Done
);
1449 procedure Traverse_Discrete_Parts
(Subtyp
: Entity_Id
);
1450 -- Traverse the given subtype, looking for discrete parts.
1451 -- For an array subtype of length N, the element subtype
1452 -- is traversed N times. For a record subtype, traverse
1453 -- each component's subtype (once). When a discrete part is
1454 -- found, call Update_Result.
1456 -----------------------------
1457 -- Traverse_Discrete_Parts --
1458 -----------------------------
1460 procedure Traverse_Discrete_Parts
(Subtyp
: Entity_Id
) is
1462 if Box_Value_Required
(Subtyp
) then
1466 if Is_Discrete_Type
(Subtyp
) then
1468 ((Low
=> Expr_Value
(Type_Low_Bound
(Subtyp
)),
1469 High
=> Expr_Value
(Type_High_Bound
(Subtyp
))));
1470 elsif Is_Array_Type
(Subtyp
) then
1474 if Is_Constrained
(Subtyp
) then
1475 Len
:= Static_Array_Length
(Subtyp
);
1477 -- Length will be treated like a discriminant;
1478 -- We could compute High more precisely as
1479 -- 1 + Index_Subtype'Last - Index_Subtype'First
1480 -- (we currently require that those bounds be
1481 -- static, so this is an option), but only downside of
1482 -- overshooting is if somebody wants to omit a
1483 -- "when others" choice and exhaustively cover all
1484 -- possibilities explicitly.
1487 High
=> Uint_2
** Uint_32
));
1489 Len
:= Unconstrained_Array_Effective_Length
1490 (Array_Type
=> Subtyp
,
1491 Case_Statement
=> Case_Statement
);
1493 for I
in 1 .. Len
loop
1494 Traverse_Discrete_Parts
(Component_Type
(Subtyp
));
1497 elsif Is_Record_Type
(Subtyp
) then
1498 if Has_Static_Discriminant_Constraint
(Subtyp
) then
1500 -- The component range for a constrained discriminant
1501 -- is a single value.
1503 Dc_Elmt
: Elmt_Id
:=
1504 First_Elmt
(Discriminant_Constraint
(Subtyp
));
1507 while Present
(Dc_Elmt
) loop
1508 Dc_Value
:= Expr_Value
(Node
(Dc_Elmt
));
1509 Update_Result
((Low
=> Dc_Value
,
1512 Next_Elmt
(Dc_Elmt
);
1516 -- Generate ranges for nondiscriminant components.
1518 Comp
: Entity_Id
:= First_Component
1519 (Base_Type
(Subtyp
));
1521 while Present
(Comp
) loop
1522 Traverse_Discrete_Parts
(Etype
(Comp
));
1523 Next_Component
(Comp
);
1527 -- Generate ranges for all components
1530 First_Component_Or_Discriminant
1531 (Base_Type
(Subtyp
));
1533 while Present
(Comp
) loop
1534 Traverse_Discrete_Parts
(Etype
(Comp
));
1535 Next_Component_Or_Discriminant
(Comp
);
1541 ("case selector type having a non-discrete non-record"
1542 & " non-array subcomponent type not implemented",
1543 Expression
(Case_Statement
));
1545 end Traverse_Discrete_Parts
;
1548 Traverse_Discrete_Parts
(Case_Expr_Type
);
1549 pragma Assert
(Done
or else Serious_Errors_Detected
> 0);
1551 end Component_Bounds_Info
;
1553 Component_Bounds
: constant Composite_Range_Info
1554 := Component_Bounds_Info
;
1556 package Case_Bindings
is
1558 procedure Note_Binding
1559 (Comp_Assoc
: Node_Id
;
1562 -- Note_Binding is called once for each component association
1563 -- that defines a binding (using either "A => B is X" or
1564 -- "A => <X>" syntax);
1566 procedure Check_Bindings
;
1567 -- After all calls to Note_Binding, check that bindings are
1568 -- ok (e.g., check consistency among different choices of
1569 -- one alternative).
1573 procedure Refresh_Binding_Info
(Aggr
: Node_Id
);
1574 -- The parser records binding-related info in the tree.
1575 -- The choice nodes that we see here might not be (will never be?)
1576 -- the original nodes that were produced by the parser. The info
1577 -- recorded by the parser is missing in that case, so this
1578 -- procedure recovers it.
1580 -- There are bugs here. In some cases involving nested aggregates,
1581 -- the path back to the parser-created nodes is lost. In particular,
1582 -- we may fail to detect an illegal case like
1583 -- when (F1 | F2 => (Aa => Natural, Bb => Natural is X)) =>
1584 -- This should be rejected because it is binding X to both the
1585 -- F1.Bb and to the F2.Bb subcomponents of the case selector.
1586 -- It would be nice if the not-specific-to-pattern-matching
1587 -- aggregate-processing code could remain unaware of the existence
1588 -- of this binding-related info but perhaps that isn't possible.
1590 --------------------------
1591 -- Refresh_Binding_Info --
1592 --------------------------
1594 procedure Refresh_Binding_Info
(Aggr
: Node_Id
) is
1595 Orig_Aggr
: constant Node_Id
:= Original_Node
(Aggr
);
1596 Orig_Comp
: Node_Id
:= First
(Component_Associations
(Orig_Aggr
));
1598 if Aggr
= Orig_Aggr
then
1602 while Present
(Orig_Comp
) loop
1603 if Nkind
(Orig_Comp
) = N_Component_Association
1604 and then Binding_Chars
(Orig_Comp
) /= No_Name
1606 if List_Length
(Choices
(Orig_Comp
)) /= 1 then
1607 -- Conceivably this could be checked during parsing,
1608 -- but checking is easier here.
1611 ("binding shared by multiple components", Orig_Comp
);
1616 Orig_Name
: constant Name_Id
:=
1617 Chars
(First
(Choices
(Orig_Comp
)));
1618 Comp
: Node_Id
:= First
(Component_Associations
(Aggr
));
1619 Matching_Comp
: Node_Id
:= Empty
;
1621 while Present
(Comp
) loop
1622 if Chars
(First
(Choices
(Comp
))) = Orig_Name
then
1623 pragma Assert
(No
(Matching_Comp
));
1624 Matching_Comp
:= Comp
;
1630 pragma Assert
(Present
(Matching_Comp
));
1634 Binding_Chars
(Orig_Comp
));
1640 end Refresh_Binding_Info
;
1646 function Parse_Choice
(Choice
: Node_Id
;
1647 Alt
: Node_Id
) return Choice_Range_Info
1649 Result
: Choice_Range_Info
(Is_Others
=> False);
1650 Ranges
: Composite_Range_Info
renames Result
.Ranges
;
1651 Next_Part
: Part_Id
'Base range 1 .. Part_Id
'Last + 1 := 1;
1653 procedure Traverse_Choice
(Expr
: Node_Id
);
1654 -- Traverse a legal choice expression, looking for
1655 -- values/ranges of discrete parts. Call Update_Result
1658 procedure Update_Result
(Discrete_Range
: Discrete_Range_Info
);
1659 -- Initialize first remaining uninitialized element of Ranges.
1660 -- Also set Next_Part.
1662 procedure Update_Result_For_Full_Coverage
(Comp_Type
: Entity_Id
);
1663 -- For each scalar part of the given component type, call
1664 -- Update_Result with the full range for that scalar part.
1665 -- This is used for both box components in aggregates and
1666 -- for any inactive-variant components that do not appear in
1667 -- a given aggregate.
1673 procedure Update_Result
(Discrete_Range
: Discrete_Range_Info
) is
1675 Ranges
(Next_Part
) := Discrete_Range
;
1676 Next_Part
:= Next_Part
+ 1;
1679 -------------------------------------
1680 -- Update_Result_For_Full_Coverage --
1681 -------------------------------------
1683 procedure Update_Result_For_Full_Coverage
(Comp_Type
: Entity_Id
)
1686 for Counter
in 1 .. Scalar_Part_Count
(Comp_Type
) loop
1687 Update_Result
(Component_Bounds
(Next_Part
));
1689 end Update_Result_For_Full_Coverage
;
1691 ---------------------
1692 -- Traverse_Choice --
1693 ---------------------
1695 procedure Traverse_Choice
(Expr
: Node_Id
) is
1697 if Nkind
(Expr
) = N_Qualified_Expression
then
1698 Traverse_Choice
(Expression
(Expr
));
1700 elsif Nkind
(Expr
) = N_Type_Conversion
1701 and then not Comes_From_Source
(Expr
)
1703 if Expr
/= Original_Node
(Expr
) then
1704 Traverse_Choice
(Original_Node
(Expr
));
1706 Traverse_Choice
(Expression
(Expr
));
1709 elsif Nkind
(Expr
) = N_Aggregate
then
1710 if Is_Record_Type
(Etype
(Expr
)) then
1711 Refresh_Binding_Info
(Aggr
=> Expr
);
1714 Comp_Assoc
: Node_Id
:=
1715 First
(Component_Associations
(Expr
));
1716 -- Aggregate has been normalized (components in
1717 -- order, only one component per choice, etc.).
1719 Comp_From_Type
: Node_Id
:=
1720 First_Component_Or_Discriminant
1721 (Base_Type
(Etype
(Expr
)));
1723 Saved_Next_Part
: constant Part_Id
:= Next_Part
;
1725 while Present
(Comp_Assoc
) loop
1727 (List_Length
(Choices
(Comp_Assoc
)) = 1);
1730 Comp
: constant Node_Id
:=
1731 Entity
(First
(Choices
(Comp_Assoc
)));
1732 Comp_Seen
: Boolean := False;
1735 if Original_Record_Component
(Comp
) =
1736 Original_Record_Component
(Comp_From_Type
)
1740 -- We have an aggregate of a type that
1741 -- has a variant part (or has a
1742 -- subcomponent type that has a variant
1743 -- part) and we have to deal with a
1744 -- component that is present in the type
1745 -- but not in the aggregate (because the
1746 -- component is in an inactive variant).
1748 Update_Result_For_Full_Coverage
1749 (Comp_Type
=> Etype
(Comp_From_Type
));
1753 Next_Component_Or_Discriminant
1756 exit when Comp_Seen
;
1761 Comp_Type
: constant Entity_Id
:=
1762 Etype
(First
(Choices
(Comp_Assoc
)));
1764 if Box_Value_Required
(Comp_Type
) then
1765 -- This component is not allowed to
1766 -- influence which alternative is
1767 -- chosen; case choice must be box.
1769 -- For example, component might be
1770 -- of a real type or of an access type
1771 -- or of a non-static discrete subtype.
1772 if not Box_Present
(Comp_Assoc
) then
1774 ("Non-box case choice component value" &
1775 " of unsupported type/subtype",
1776 Expression
(Comp_Assoc
));
1778 elsif Box_Present
(Comp_Assoc
) then
1779 -- Box matches all values
1780 Update_Result_For_Full_Coverage
1781 (Etype
(First
(Choices
(Comp_Assoc
))));
1783 Traverse_Choice
(Expression
(Comp_Assoc
));
1787 if Binding_Chars
(Comp_Assoc
) /= No_Name
1789 Case_Bindings
.Note_Binding
1790 (Comp_Assoc
=> Comp_Assoc
,
1798 while Present
(Comp_From_Type
) loop
1799 -- Deal with any trailing inactive-variant
1802 -- See earlier commment about calling
1803 -- Update_Result_For_Full_Coverage for such
1806 Update_Result_For_Full_Coverage
1807 (Comp_Type
=> Etype
(Comp_From_Type
));
1810 Next_Component_Or_Discriminant
(Comp_From_Type
);
1814 Expr_Type
: Entity_Id
:= Etype
(Expr
);
1816 if Has_Discriminants
(Expr_Type
) then
1817 -- Avoid nonstatic choice expr types,
1818 -- for which Scalar_Part_Count returns 0.
1819 Expr_Type
:= Base_Type
(Expr_Type
);
1823 (Nat
(Next_Part
- Saved_Next_Part
)
1824 = Scalar_Part_Count
(Expr_Type
));
1827 elsif Is_Array_Type
(Etype
(Expr
)) then
1828 if Is_Non_Empty_List
(Component_Associations
(Expr
)) then
1830 ("non-positional array aggregate as/within case "
1831 & "choice not implemented", Expr
);
1834 if not Unconstrained_Array_Case
1835 and then List_Length
(Expressions
(Expr
))
1836 /= Nat
(Part_Id
'Last)
1838 Error_Msg_Uint_1
:= UI_From_Int
1839 (List_Length
(Expressions
(Expr
)));
1840 Error_Msg_Uint_2
:= UI_From_Int
(Int
(Part_Id
'Last));
1842 ("array aggregate length ^ does not match length " &
1843 "of statically constrained case selector ^", Expr
);
1848 Subexpr
: Node_Id
:= First
(Expressions
(Expr
));
1850 while Present
(Subexpr
) loop
1851 Traverse_Choice
(Subexpr
);
1856 raise Program_Error
;
1858 elsif Nkind
(Expr
) = N_String_Literal
then
1859 if not Is_Array_Type
(Etype
(Expr
)) then
1861 ("User-defined string literal not allowed as/within"
1862 & "case choice", Expr
);
1865 Char_Type
: constant Entity_Id
:=
1866 Root_Type
(Component_Type
(Etype
(Expr
)));
1868 -- If the component type is not a standard character
1869 -- type then this string lit should have already been
1870 -- transformed into an aggregate in
1871 -- Resolve_String_Literal.
1873 pragma Assert
(Is_Standard_Character_Type
(Char_Type
));
1875 Str
: constant String_Id
:= Strval
(Expr
);
1876 Strlen
: constant Nat
:= String_Length
(Str
);
1879 if not Unconstrained_Array_Case
1880 and then Strlen
/= Nat
(Part_Id
'Last)
1882 Error_Msg_Uint_1
:= UI_From_Int
(Strlen
);
1883 Error_Msg_Uint_2
:= UI_From_Int
1884 (Int
(Part_Id
'Last));
1886 ("String literal length ^ does not match length" &
1887 " of statically constrained case selector ^",
1892 for Idx
in 1 .. Strlen
loop
1894 UI_From_CC
(Get_String_Char
(Str
, Idx
));
1895 Update_Result
((Low | High
=> Char_Val
));
1899 elsif Is_Discrete_Type
(Etype
(Expr
)) then
1900 if Nkind
(Expr
) in N_Has_Entity
1901 and then Present
(Entity
(Expr
))
1902 and then Is_Type
(Entity
(Expr
))
1905 Low
: constant Node_Id
:=
1906 Type_Low_Bound
(Entity
(Expr
));
1907 High
: constant Node_Id
:=
1908 Type_High_Bound
(Entity
(Expr
));
1910 Update_Result
((Low
=> Expr_Value
(Low
),
1911 High
=> Expr_Value
(High
)));
1914 pragma Assert
(Compile_Time_Known_Value
(Expr
));
1915 Update_Result
((Low | High
=> Expr_Value
(Expr
)));
1917 elsif Nkind
(Expr
) in N_Has_Entity
1918 and then Present
(Entity
(Expr
))
1919 and then Ekind
(Entity
(Expr
)) = E_Constant
1921 Traverse_Choice
(Expression
(Parent
(Entity
(Expr
))));
1922 elsif Nkind
(Original_Node
(Expr
))
1923 in N_Aggregate | N_String_Literal
1925 Traverse_Choice
(Original_Node
(Expr
));
1928 ("non-aggregate case choice (or subexpression thereof)"
1929 & " that is not of a discrete type not implemented",
1932 end Traverse_Choice
;
1934 -- Start of processing for Parse_Choice
1937 if Nkind
(Choice
) = N_Others_Choice
then
1938 return (Is_Others
=> True);
1941 if Unconstrained_Array_Case
then
1942 -- Treat length like a discriminant
1943 Update_Result
((Low | High
=>
1944 UI_From_Int
(Array_Choice_Length
(Choice
))));
1947 Traverse_Choice
(Choice
);
1949 if Unconstrained_Array_Case
then
1950 -- This is somewhat tricky. Suppose we are casing on String,
1951 -- the longest choice in the case statement is length 10, and
1952 -- the choice we are looking at now is of length 6. We fill
1953 -- in the trailing 4 slots here.
1954 while Next_Part
<= Part_Id
'Last loop
1955 Update_Result_For_Full_Coverage
1956 (Comp_Type
=> Component_Type
(Case_Expr_Type
));
1960 -- Avoid returning uninitialized garbage in error case
1961 if Next_Part
/= Part_Id
'Last + 1 then
1962 pragma Assert
(Serious_Errors_Detected
> 0);
1963 Result
.Ranges
:= (others => (Low
=> Uint_1
, High
=> Uint_0
));
1969 package body Case_Bindings
is
1971 type Binding
is record
1972 Comp_Assoc
: Node_Id
;
1977 type Binding_Index
is new Natural;
1979 package Case_Bindings_Table
is new Table
.Table
1980 (Table_Component_Type
=> Binding
,
1981 Table_Index_Type
=> Binding_Index
,
1982 Table_Low_Bound
=> 1,
1983 Table_Initial
=> 16,
1984 Table_Increment
=> 64,
1985 Table_Name
=> "Composite_Case_Ops.Case_Bindings");
1991 procedure Note_Binding
1992 (Comp_Assoc
: Node_Id
;
1997 Case_Bindings_Table
.Append
1998 ((Comp_Assoc
=> Comp_Assoc
,
2003 --------------------
2004 -- Check_Bindings --
2005 --------------------
2007 procedure Check_Bindings
2009 use Case_Bindings_Table
;
2011 function Binding_Subtype
(Idx
: Binding_Index
;
2014 (Etype
(Nlists
.First
(Choices
(Tab
(Idx
).Comp_Assoc
))));
2016 procedure Declare_Binding_Objects
2017 (Alt_Start
: Binding_Index
;
2019 First_Choice_Bindings
: Natural;
2021 -- Declare the binding objects for a given alternative
2023 ------------------------------
2024 -- Declare_Binding_Objects --
2025 ------------------------------
2027 procedure Declare_Binding_Objects
2028 (Alt_Start
: Binding_Index
;
2030 First_Choice_Bindings
: Natural;
2033 Loc
: constant Source_Ptr
:= Sloc
(Alt
);
2034 Declarations
: constant List_Id
:= New_List
;
2036 Obj_Type
: Entity_Id
;
2039 for FC_Idx
in Alt_Start
..
2040 Alt_Start
+ Binding_Index
(First_Choice_Bindings
- 1)
2042 Obj_Type
:= Binding_Subtype
(FC_Idx
, Tab
);
2043 Def_Id
:= Make_Defining_Identifier
2045 Binding_Chars
(Tab
(FC_Idx
).Comp_Assoc
));
2047 -- Either make a copy or rename the original. At a
2048 -- minimum, we do not want a copy if it would need
2049 -- finalization. Copies may also introduce problems
2050 -- if default init can have side effects (although we
2051 -- could suppress such default initialization).
2052 -- We have to make a copy in any cases where
2053 -- Unrestricted_Access doesn't work.
2055 -- This is where the copy-or-rename decision is made.
2056 -- In many cases either way would work and so we have
2057 -- some flexibility here.
2059 if not Is_By_Copy_Type
(Obj_Type
) then
2062 -- is access constant Obj_Type;
2063 -- Ptr : Ref := <some bogus value>;
2064 -- Obj : Obj_Type renames Ptr.all;
2066 -- Initialization of Ptr will be generated later
2067 -- during expansion.
2070 Ptr_Type
: constant Entity_Id
:=
2071 Make_Temporary
(Loc
, 'P');
2073 Ptr_Type_Def
: constant Node_Id
:=
2074 Make_Access_To_Object_Definition
(Loc
,
2075 All_Present
=> True,
2076 Subtype_Indication
=>
2077 New_Occurrence_Of
(Obj_Type
, Loc
));
2079 Ptr_Type_Decl
: constant Node_Id
:=
2080 Make_Full_Type_Declaration
(Loc
,
2082 Type_Definition
=> Ptr_Type_Def
);
2084 Ptr_Obj
: constant Entity_Id
:=
2085 Make_Temporary
(Loc
, 'T');
2087 -- We will generate initialization code for this
2088 -- object later (during expansion) but in the
2089 -- meantime we don't want the dereference that
2090 -- is generated a few lines below here to be
2091 -- transformed into a Raise_C_E. To prevent this,
2092 -- we provide a bogus initial value here; this
2093 -- initial value will be removed later during
2096 Ptr_Obj_Decl
: constant Node_Id
:=
2097 Make_Object_Declaration
2099 Object_Definition
=>
2100 New_Occurrence_Of
(Ptr_Type
, Loc
),
2102 Unchecked_Convert_To
2104 Make_Integer_Literal
(Loc
, 5432)));
2106 Mutate_Ekind
(Ptr_Type
, E_Access_Type
);
2108 -- in effect, Storage_Size => 0
2109 Set_No_Pool_Assigned
(Ptr_Type
);
2111 Set_Is_Access_Constant
(Ptr_Type
);
2113 -- We could set Ptr_Type'Alignment here if that
2114 -- ever turns out to be needed for renaming a
2115 -- misaligned subcomponent.
2117 Mutate_Ekind
(Ptr_Obj
, E_Variable
);
2118 Set_Etype
(Ptr_Obj
, Ptr_Type
);
2121 Make_Object_Renaming_Declaration
2124 New_Occurrence_Of
(Obj_Type
, Loc
),
2126 Make_Explicit_Dereference
2127 (Loc
, New_Occurrence_Of
(Ptr_Obj
, Loc
)));
2129 Append_To
(Declarations
, Ptr_Type_Decl
);
2130 Append_To
(Declarations
, Ptr_Obj_Decl
);
2133 Decl
:= Make_Object_Declaration
2135 Defining_Identifier
=> Def_Id
,
2136 Object_Definition
=>
2137 New_Occurrence_Of
(Obj_Type
, Loc
));
2139 Append_To
(Declarations
, Decl
);
2143 Old_Statements
: constant List_Id
:= Statements
(Alt
);
2144 New_Statements
: constant List_Id
:= New_List
;
2146 Block_Statement
: constant Node_Id
:=
2147 Make_Block_Statement
(Sloc
=> Loc
,
2148 Declarations
=> Declarations
,
2149 Handled_Statement_Sequence
=>
2150 Make_Handled_Sequence_Of_Statements
2151 (Loc
, Old_Statements
),
2152 Has_Created_Identifier
=> True);
2154 Append_To
(New_Statements
, Block_Statement
);
2155 Set_Statements
(Alt
, New_Statements
);
2157 end Declare_Binding_Objects
;
2160 -- no bindings to check
2166 renames Case_Bindings_Table
.Table
(1 .. Last
);
2168 function Same_Id
(Idx1
, Idx2
: Binding_Index
)
2170 Binding_Chars
(Tab
(Idx1
).Comp_Assoc
) =
2171 Binding_Chars
(Tab
(Idx2
).Comp_Assoc
));
2173 -- Verify that elements with given choice or alt value
2174 -- are contiguous, and that elements with equal
2175 -- choice values have same alt value.
2177 for Idx1
in 2 .. Tab
'Last loop
2178 if Tab
(Idx1
- 1).Choice
/= Tab
(Idx1
).Choice
then
2180 (for all Idx2
in Idx1
+ 1 .. Tab
'Last =>
2181 Tab
(Idx2
).Choice
/= Tab
(Idx1
- 1).Choice
);
2183 pragma Assert
(Tab
(Idx1
- 1).Alt
= Tab
(Idx1
).Alt
);
2185 if Tab
(Idx1
- 1).Alt
/= Tab
(Idx1
).Alt
then
2187 (for all Idx2
in Idx1
+ 1 .. Tab
'Last =>
2188 Tab
(Idx2
).Alt
/= Tab
(Idx1
- 1).Alt
);
2192 -- Check for user errors:
2193 -- 1) Two choices for a given alternative shall define the
2194 -- same set of names. Can't have
2195 -- when (<X>, 0) | (0, <Y>) =>
2196 -- 2) A choice shall not define a name twice. Can't have
2197 -- when (A => <X>, B => <X>, C => 0) =>
2198 -- 3) Two definitions of a name within one alternative
2199 -- shall have statically matching component subtypes.
2201 -- type R is record Int : Integer;
2202 -- Nat : Natural; end record;
2204 -- when (<X>, 1) | (1, <X>) =>
2205 -- 4) A given binding shall match only one value.
2207 -- (Fld1 | Fld2 => (Fld => <X>))
2208 -- For now, this is enforced *very* conservatively
2209 -- with respect to arrays - a binding cannot match
2210 -- any part of an array. This is temporary.
2212 for Idx1
in Tab
'Range loop
2214 or else Tab
(Idx1
- 1).Alt
/= Tab
(Idx1
).Alt
2216 -- Process one alternative
2218 Alt_Start
: constant Binding_Index
:= Idx1
;
2219 Alt
: constant Node_Id
:= Tab
(Alt_Start
).Alt
;
2221 First_Choice
: constant Node_Id
:=
2222 Nlists
.First
(Discrete_Choices
(Alt
));
2223 First_Choice_Bindings
: Natural := 0;
2225 -- Check for duplicates within one choice,
2226 -- and for choices with no bindings.
2228 if First_Choice
/= Tab
(Alt_Start
).Choice
then
2229 Error_Msg_N
("binding(s) missing for choice",
2235 Current_Choice
: Node_Id
:= First_Choice
;
2236 Choice_Start
: Binding_Index
:= Alt_Start
;
2238 for Idx2
in Alt_Start
.. Tab
'Last loop
2239 exit when Tab
(Idx2
).Alt
/= Alt
;
2240 if Tab
(Idx2
).Choice
= Current_Choice
then
2241 for Idx3
in Choice_Start
.. Idx2
- 1 loop
2242 if Same_Id
(Idx2
, Idx3
)
2245 ("duplicate binding in choice",
2251 Next
(Current_Choice
);
2252 pragma Assert
(Present
(Current_Choice
));
2253 Choice_Start
:= Idx2
;
2255 if Tab
(Idx2
).Choice
/= Current_Choice
2258 ("binding(s) missing for choice",
2265 -- If we made it through all the bindings
2266 -- for this alternative but didn't make it
2267 -- to the last choice, then bindings are
2268 -- missing for all remaining choices.
2269 -- We only complain about the first one.
2271 if Present
(Next
(Current_Choice
)) then
2273 ("binding(s) missing for choice",
2274 Next
(Current_Choice
));
2279 -- Count bindings for first choice of alternative
2281 for FC_Idx
in Alt_Start
.. Tab
'Last loop
2282 exit when Tab
(FC_Idx
).Choice
/= First_Choice
;
2283 First_Choice_Bindings
:=
2284 First_Choice_Bindings
+ 1;
2288 Current_Choice
: Node_Id
:= First_Choice
;
2289 Current_Choice_Bindings
: Natural := 0;
2291 for Idx2
in Alt_Start
.. Tab
'Last loop
2292 exit when Tab
(Idx2
).Alt
/= Alt
;
2294 -- If starting a new choice
2296 if Tab
(Idx2
).Choice
/= Current_Choice
then
2298 -- Check count for choice just finished
2300 if Current_Choice_Bindings
2301 /= First_Choice_Bindings
2304 ("subsequent choice has different"
2305 & " number of bindings than first"
2306 & " choice", Current_Choice
);
2309 Current_Choice
:= Tab
(Idx2
).Choice
;
2310 Current_Choice_Bindings
:= 1;
2312 -- Remember that Alt has both one or more
2313 -- bindings and two or more choices; we'll
2314 -- need to know this during expansion.
2316 Set_Multidefined_Bindings
(Alt
, True);
2318 Current_Choice_Bindings
:=
2319 Current_Choice_Bindings
+ 1;
2322 -- Check that first choice has binding with
2323 -- matching name; check subtype consistency.
2326 Found
: Boolean := False;
2330 Alt_Start
+ Binding_Index
2331 (First_Choice_Bindings
- 1)
2333 if Same_Id
(Idx2
, FC_Idx
) then
2334 if not Subtypes_Statically_Match
2335 (Binding_Subtype
(Idx2
, Tab
),
2336 Binding_Subtype
(FC_Idx
, Tab
))
2339 ("subtype of binding in "
2340 & "subsequent choice does not "
2341 & "match that in first choice",
2342 Tab
(Idx2
).Comp_Assoc
);
2351 ("binding defined in subsequent "
2352 & "choice not defined in first "
2353 & "choice", Current_Choice
);
2357 -- Check for illegal repeated binding
2358 -- via an enclosing aggregate, as in
2359 -- (F1 | F2 => (F3 => Natural is X,
2361 -- where the inner aggregate would be ok.
2364 Rover
: Node_Id
:= Tab
(Idx2
).Comp_Assoc
;
2366 while Rover
/= Tab
(Idx2
).Choice
loop
2368 (if Is_List_Member
(Rover
) then
2369 Parent
(List_Containing
(Rover
))
2370 else Parent
(Rover
));
2371 pragma Assert
(Present
(Rover
));
2373 = N_Component_Association
2374 and then List_Length
(Choices
(Rover
))
2378 ("binding shared by multiple "
2379 & "enclosing components",
2380 Tab
(Idx2
).Comp_Assoc
);
2387 -- Construct the (unanalyzed) declarations for
2388 -- the current alternative. Then analyze them.
2390 if First_Choice_Bindings
> 0 then
2391 Declare_Binding_Objects
2392 (Alt_Start
=> Alt_Start
,
2394 First_Choice_Bindings
=>
2395 First_Choice_Bindings
,
2405 function Choice_Bounds_Info
return Choices_Range_Info
;
2406 -- Returns mapping from any given Choice_Id value to that choice's
2407 -- component-to-range map.
2409 ------------------------
2410 -- Choice_Bounds_Info --
2411 ------------------------
2413 function Choice_Bounds_Info
return Choices_Range_Info
is
2414 Result
: Choices_Range_Info
;
2415 Alt
: Node_Id
:= First
(Alternatives
(Case_Statement
));
2416 C_Id
: Choice_Id
:= 1;
2418 while Present
(Alt
) loop
2420 Choice
: Node_Id
:= First
(Discrete_Choices
(Alt
));
2422 while Present
(Choice
) loop
2423 Result
(C_Id
) := Parse_Choice
(Choice
, Alt
=> Alt
);
2426 if C_Id
/= Choice_Id
'Last then
2434 pragma Assert
(C_Id
= Choice_Id
'Last);
2436 -- No more calls to Note_Binding, so time for checks.
2437 Case_Bindings
.Check_Bindings
;
2440 end Choice_Bounds_Info
;
2442 Choices_Bounds
: constant Choices_Range_Info
:= Choice_Bounds_Info
;
2444 package body Value_Sets
is
2447 function Hash
(Key
: Uint
) return Bucket_Range_Type
is
2449 (UI_To_Int
(Key
mod (Uint_2
** Uint_31
))));
2451 package Uint_Sets
is new GNAT
.Sets
.Membership_Sets
2454 type Representative_Values_Array
is
2455 array (Part_Id
) of Uint_Sets
.Membership_Set
;
2457 function Representative_Values_Init
2458 return Representative_Values_Array
;
2459 -- Select the representative values for each Part_Id value.
2460 -- This function is called exactly once, immediately after it
2463 --------------------------------
2464 -- Representative_Values_Init --
2465 --------------------------------
2467 function Representative_Values_Init
2468 return Representative_Values_Array
2470 -- For each range of each choice (as well as the range for the
2471 -- component subtype, which is handled in the first loop),
2472 -- insert the low bound of the range and the successor of
2473 -- the high bound into the corresponding R_V element.
2475 -- The idea we are trying to capture here is somewhat tricky.
2476 -- Given an arbitrary point P1 in the Cartesian product
2477 -- of the Component_Bounds sets, we want to be able
2478 -- to map that to a point P2 in the (smaller) Cartesian product
2479 -- of the Representative_Values sets that has the property
2480 -- that for every choice of the case statement, P1 matches
2481 -- the choice if and only if P2 also matches. Given that,
2482 -- we can implement the overlapping/containment/etc. rules
2483 -- safely by just looking at (using brute force enumeration)
2484 -- the (smaller) Cartesian product of the R_V sets.
2485 -- We are never going to actually perform this point-to-point
2486 -- mapping - just the fact that it exists is enough to ensure
2487 -- we can safely look at just the R_V sets.
2489 -- The desired mapping can be implemented by mapping a point
2490 -- P1 to a point P2 by reducing each of P1's coordinates down
2491 -- to the largest element of the corresponding R_V set that is
2492 -- less than or equal to the original coordinate value (such
2493 -- an element Y will always exist because the R_V set for a
2494 -- given component always includes the low bound of the
2495 -- component subtype). It then suffices to show that every
2496 -- choice in the case statement yields the same Boolean result
2497 -- for P1 as for P2.
2499 -- Suppose the contrary. Then there is some particular
2500 -- coordinate position X (i.e., a Part_Id value) and some
2501 -- choice C where exactly one of P1(X) and P2(X) belongs to
2502 -- the (contiguous) range associated with C(X); call that
2503 -- range L .. H. We know that P2(X) <= P1(X) because the
2504 -- mapping never increases coordinate values. Consider three
2505 -- cases: P1(X) lies within the L .. H range, or it is greater
2506 -- than H, or it is lower than L.
2507 -- The third case is impossible because reducing a value that
2508 -- is less than L can only produce another such value,
2509 -- violating the "exactly one" assumption. The second
2510 -- case is impossible because L belongs to the corresponding
2511 -- R_V set, so P2(X) >= L and both values belong to the
2512 -- range, again violating the "exactly one" assumption.
2513 -- Finally, the third case is impossible because H+1 belongs
2514 -- to the corresponding R_V set, so P2(X) > H, so neither
2515 -- value belongs to the range, again violating the "exactly
2516 -- one" assumption. So our initial supposition was wrong. QED.
2520 Result
: constant Representative_Values_Array
2521 := (others => Uint_Sets
.Create
(Initial_Size
=> 32));
2523 procedure Insert_Representative
(Value
: Uint
; P
: Part_Id
);
2524 -- Insert the given Value into the representative values set
2525 -- for the given component if it belongs to the component's
2526 -- subtype. Otherwise, do nothing.
2528 ---------------------------
2529 -- Insert_Representative --
2530 ---------------------------
2532 procedure Insert_Representative
(Value
: Uint
; P
: Part_Id
) is
2534 if Value
>= Component_Bounds
(P
).Low
and
2535 Value
<= Component_Bounds
(P
).High
2537 Insert
(Result
(P
), Value
);
2539 end Insert_Representative
;
2542 for P
in Part_Id
loop
2543 Insert_Representative
(Component_Bounds
(P
).Low
, P
);
2546 if Simplified_Composite_Coverage_Rules
then
2547 -- Omit other representative values to avoid capacity
2548 -- problems building data structures only used in
2549 -- compile-time checks that will not be performed.
2553 for C
of Choices_Bounds
loop
2554 if not C
.Is_Others
then
2555 for P
in Part_Id
loop
2556 if C
.Ranges
(P
).Low
<= C
.Ranges
(P
).High
then
2557 Insert_Representative
(C
.Ranges
(P
).Low
, P
);
2558 Insert_Representative
(C
.Ranges
(P
).High
+ 1, P
);
2564 end Representative_Values_Init
;
2566 Representative_Values
: constant Representative_Values_Array
2567 := Representative_Values_Init
;
2568 -- We want to avoid looking at every point in the Cartesian
2569 -- product of all component values. Instead we select, for each
2570 -- component, a set of representative values and then look only
2571 -- at the Cartesian product of those sets. A single value can
2572 -- safely represent a larger enclosing interval if every choice
2573 -- for that component either completely includes or completely
2574 -- excludes the interval. The elements of this array will be
2575 -- populated by a call to Initialize_Representative_Values and
2576 -- will remain constant after that.
2578 type Value_Index_Base
is new Natural;
2580 function Value_Index_Count
return Value_Index_Base
;
2581 -- Returns the product of the sizes of the Representative_Values
2582 -- sets (i.e., the size of the Cartesian product of the sets).
2583 -- May return zero if one of the sets is empty.
2584 -- This function is called exactly once, immediately after it
2587 -----------------------
2588 -- Value_Index_Count --
2589 -----------------------
2591 function Value_Index_Count
return Value_Index_Base
is
2592 Result
: Value_Index_Base
:= 1;
2594 for Set
of Representative_Values
loop
2595 Result
:= Result
* Value_Index_Base
(Uint_Sets
.Size
(Set
));
2599 when Constraint_Error
=>
2601 ("Capacity exceeded in compiling case statement with"
2602 & " composite selector type", Case_Statement
);
2604 end Value_Index_Count
;
2606 Max_Value_Index
: constant Value_Index_Base
:= Value_Index_Count
;
2608 subtype Value_Index
is Value_Index_Base
range 1 .. Max_Value_Index
;
2609 type Value_Index_Set
is array (Value_Index
) of Boolean;
2611 package Value_Index_Set_Table
is new Table
.Table
2612 (Table_Component_Type
=> Value_Index_Set
,
2613 Table_Index_Type
=> Value_Set
,
2614 Table_Low_Bound
=> 1,
2615 Table_Initial
=> 16,
2616 Table_Increment
=> 100,
2617 Table_Name
=> "Composite_Case_Ops.Value_Sets");
2618 -- A nonzero Value_Set value is an index into this table.
2620 function Indexed
(Index
: Value_Set
) return Value_Index_Set
2621 is (Value_Index_Set_Table
.Table
.all (Index
));
2623 function Allocate_Table_Element
(Initial_Value
: Value_Index_Set
)
2625 -- Allocate and initialize a new table element; return its index.
2627 ----------------------------
2628 -- Allocate_Table_Element --
2629 ----------------------------
2631 function Allocate_Table_Element
(Initial_Value
: Value_Index_Set
)
2634 use Value_Index_Set_Table
;
2636 Append
(Initial_Value
);
2638 end Allocate_Table_Element
;
2640 procedure Assign_Table_Element
(Index
: Value_Set
;
2641 Value
: Value_Index_Set
);
2642 -- Assign specified value to specified table element.
2644 --------------------------
2645 -- Assign_Table_Element --
2646 --------------------------
2648 procedure Assign_Table_Element
(Index
: Value_Set
;
2649 Value
: Value_Index_Set
)
2652 Value_Index_Set_Table
.Table
.all (Index
) := Value
;
2653 end Assign_Table_Element
;
2659 function Compare
(S1
, S2
: Value_Set
) return Set_Comparison
is
2661 if S1
= Empty
or S2
= Empty
then
2663 elsif Indexed
(S1
) = Indexed
(S2
) then
2667 Intersection
: constant Value_Index_Set
2668 := Indexed
(S1
) and Indexed
(S2
);
2670 if (for all Flag
of Intersection
=> not Flag
) then
2672 elsif Intersection
= Indexed
(S1
) then
2673 return Contained_By
;
2674 elsif Intersection
= Indexed
(S2
) then
2683 -------------------------
2684 -- Complement_Is_Empty --
2685 -------------------------
2687 function Complement_Is_Empty
(Set
: Value_Set
) return Boolean
2689 and then (for all Flag
of Indexed
(Set
) => Flag
));
2691 ---------------------
2692 -- Free_Value_Sets --
2693 ---------------------
2695 procedure Free_Value_Sets
is
2697 Value_Index_Set_Table
.Free
;
2698 end Free_Value_Sets
;
2704 procedure Union
(Target
: in out Value_Set
; Source
: Value_Set
) is
2706 if Source
/= Empty
then
2707 if Target
= Empty
then
2708 Target
:= Allocate_Table_Element
(Indexed
(Source
));
2710 Assign_Table_Element
2711 (Target
, Indexed
(Target
) or Indexed
(Source
));
2720 procedure Remove
(Target
: in out Value_Set
; Source
: Value_Set
) is
2722 if Source
/= Empty
and Target
/= Empty
then
2723 Assign_Table_Element
2724 (Target
, Indexed
(Target
) and not Indexed
(Source
));
2725 if (for all V
of Indexed
(Target
) => not V
) then
2731 ---------------------
2732 -- Matching_Values --
2733 ---------------------
2735 function Matching_Values
2736 (Info
: Composite_Range_Info
) return Value_Set
2738 Matches
: Value_Index_Set
;
2739 Next_Index
: Value_Index
:= 1;
2740 Done
: Boolean := False;
2741 Point
: array (Part_Id
) of Uint
;
2743 procedure Test_Point_For_Match
;
2744 -- Point identifies a point in the Cartesian product of the
2745 -- representative value sets. Record whether that Point
2746 -- belongs to the product-of-ranges specified by Info.
2748 --------------------------
2749 -- Test_Point_For_Match --
2750 --------------------------
2752 procedure Test_Point_For_Match
is
2753 function In_Range
(Val
: Uint
; Rang
: Discrete_Range_Info
)
2755 (Rang
.Low
<= Val
and then Val
<= Rang
.High
);
2757 pragma Assert
(not Done
);
2758 Matches
(Next_Index
) :=
2759 (for all P
in Part_Id
=> In_Range
(Point
(P
), Info
(P
)));
2760 if Next_Index
= Matches
'Last then
2763 Next_Index
:= Next_Index
+ 1;
2765 end Test_Point_For_Match
;
2767 procedure Test_Points
(P
: Part_Id
);
2768 -- Iterate over the Cartesian product of the representative
2769 -- value sets, calling Test_Point_For_Match for each point.
2775 procedure Test_Points
(P
: Part_Id
) is
2777 Iter
: Iterator
:= Iterate
(Representative_Values
(P
));
2779 -- We could traverse here in sorted order, as opposed to
2780 -- whatever order the set iterator gives us.
2781 -- No need for that as long as every iteration over
2782 -- a given representative values set yields the same order.
2783 -- Not sorting is more efficient, but it makes it harder to
2784 -- interpret a Value_Index_Set bit vector when debugging.
2786 while Has_Next
(Iter
) loop
2787 Next
(Iter
, Point
(P
));
2789 -- If we have finished building up a Point value, then
2790 -- test it for matching. Otherwise, recurse to continue
2791 -- building up a point value.
2793 if P
= Part_Id
'Last then
2794 Test_Point_For_Match
;
2796 Test_Points
(P
+ 1);
2803 if (for all Flag
of Matches
=> not Flag
) then
2806 return Allocate_Table_Element
(Matches
);
2807 end Matching_Values
;
2815 function Analysis
return Choices_Info
is
2816 Result
: Choices_Info
;
2817 Alt
: Node_Id
:= First
(Alternatives
(Case_Statement
));
2818 A_Id
: Alternative_Id
:= 1;
2819 C_Id
: Choice_Id
:= 1;
2821 while Present
(Alt
) loop
2823 Choice
: Node_Id
:= First
(Discrete_Choices
(Alt
));
2825 while Present
(Choice
) loop
2826 if Nkind
(Choice
) = N_Others_Choice
then
2827 pragma Assert
(Choices_Bounds
(C_Id
).Is_Others
);
2829 (Alternative
=> A_Id
,
2833 (Alternative
=> A_Id
,
2835 Matches
=> Value_Sets
.Matching_Values
2836 (Choices_Bounds
(C_Id
).Ranges
));
2839 if C_Id
/= Choice_Id
'Last then
2846 if A_Id
/= Alternative_Id
'Last then
2851 pragma Assert
(A_Id
= Alternative_Id
'Last);
2852 pragma Assert
(C_Id
= Choice_Id
'Last);
2857 end Choice_Analysis
;
2859 end Composite_Case_Ops
;
2861 --------------------------
2862 -- Expand_Others_Choice --
2863 --------------------------
2865 procedure Expand_Others_Choice
2866 (Case_Table
: Choice_Table_Type
;
2867 Others_Choice
: Node_Id
;
2868 Choice_Type
: Entity_Id
)
2870 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
2871 Choice_List
: constant List_Id
:= New_List
;
2879 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
2880 -- Builds a node representing the missing choices given by Value1 and
2881 -- Value2. A N_Range node is built if there is more than one literal
2882 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
2883 -- or N_Character_Literal is built depending on what Choice_Type is.
2885 function Lit_Of
(Value
: Uint
) return Node_Id
;
2886 -- Returns the Node_Id for the enumeration literal corresponding to the
2887 -- position given by Value within the enumeration type Choice_Type. The
2888 -- returned value has its Is_Static_Expression flag set to true.
2894 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
2899 -- If there is only one choice value missing between Value1 and
2900 -- Value2, build an integer or enumeration literal to represent it.
2902 if Value1
= Value2
then
2903 if Is_Integer_Type
(Choice_Type
) then
2904 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
2905 Set_Etype
(Lit_Node
, Choice_Type
);
2906 Set_Is_Static_Expression
(Lit_Node
);
2908 Lit_Node
:= Lit_Of
(Value1
);
2911 -- Otherwise is more that one choice value that is missing between
2912 -- Value1 and Value2, therefore build a N_Range node of either
2913 -- integer or enumeration literals.
2916 if Is_Integer_Type
(Choice_Type
) then
2917 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
2918 Set_Etype
(Lo
, Choice_Type
);
2919 Set_Is_Static_Expression
(Lo
);
2920 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
2921 Set_Etype
(Hi
, Choice_Type
);
2922 Set_Is_Static_Expression
(Hi
);
2931 Low_Bound
=> Lit_Of
(Value1
),
2932 High_Bound
=> Lit_Of
(Value2
));
2943 function Lit_Of
(Value
: Uint
) return Node_Id
is
2947 -- In the case where the literal is of type Character, there needs
2948 -- to be some special handling since there is no explicit chain
2949 -- of literals to search. Instead, a N_Character_Literal node
2950 -- is created with the appropriate Char_Code and Chars fields.
2952 if Is_Standard_Character_Type
(Choice_Type
) then
2953 Set_Character_Literal_Name
(UI_To_CC
(Value
));
2955 Make_Character_Literal
(Loc
,
2957 Char_Literal_Value
=> Value
);
2958 Set_Etype
(Lit
, Choice_Type
);
2959 Set_Is_Static_Expression
(Lit
, True);
2962 -- Otherwise, iterate through the literals list of Choice_Type
2963 -- "Value" number of times until the desired literal is reached
2964 -- and then return an occurrence of it.
2967 Lit
:= First_Literal
(Choice_Type
);
2968 for J
in 1 .. UI_To_Int
(Value
) loop
2972 return New_Occurrence_Of
(Lit
, Loc
);
2976 -- Start of processing for Expand_Others_Choice
2979 if Case_Table
'Last = 0 then
2981 -- Special case: only an others case is present. The others case
2982 -- covers the full range of the type.
2984 if Is_OK_Static_Subtype
(Choice_Type
) then
2985 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
2987 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
2990 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
2994 -- Establish the bound values for the choice depending upon whether the
2995 -- type of the case statement is static or not.
2997 if Is_OK_Static_Subtype
(Choice_Type
) then
2998 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
2999 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
3001 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
3002 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
3005 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
3006 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
3007 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
3009 -- Build the node for any missing choices that are smaller than any
3010 -- explicit choices given in the case.
3012 if Expr_Value
(Exp_Lo
) < Lo
then
3013 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
3016 -- Build the nodes representing any missing choices that lie between
3017 -- the explicit ones given in the case.
3019 for J
in 2 .. Case_Table
'Last loop
3020 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
3021 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
3023 if Lo
/= (Previous_Hi
+ 1) then
3024 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
3030 -- Build the node for any missing choices that are greater than any
3031 -- explicit choices given in the case.
3033 if Expr_Value
(Exp_Hi
) > Hi
then
3034 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
3037 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
3039 -- Warn on null others list if warning option set
3041 if Warn_On_Redundant_Constructs
3042 and then Comes_From_Source
(Others_Choice
)
3043 and then Is_Empty_List
(Choice_List
)
3045 Error_Msg_N
("?r?OTHERS choice is redundant", Others_Choice
);
3046 Error_Msg_N
("\?r?previous choices cover all values", Others_Choice
);
3048 end Expand_Others_Choice
;
3054 procedure No_OP
(C
: Node_Id
) is
3056 if Nkind
(C
) = N_Range
and then Warn_On_Redundant_Constructs
then
3057 Error_Msg_N
("choice is an empty range?r?", C
);
3061 -----------------------------
3062 -- Generic_Analyze_Choices --
3063 -----------------------------
3065 package body Generic_Analyze_Choices
is
3067 -- The following type is used to gather the entries for the choice
3068 -- table, so that we can then allocate the right length.
3071 type Link_Ptr
is access all Link
;
3074 Val
: Choice_Bounds
;
3078 ---------------------
3079 -- Analyze_Choices --
3080 ---------------------
3082 procedure Analyze_Choices
3083 (Alternatives
: List_Id
;
3086 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
3087 -- The actual type against which the discrete choices are resolved.
3088 -- Note that this type is always the base type not the subtype of the
3089 -- ruling expression, index or discriminant.
3091 Expected_Type
: Entity_Id
;
3092 -- The expected type of each choice. Equal to Choice_Type, except if
3093 -- the expression is universal, in which case the choices can be of
3094 -- any integer type.
3097 -- A case statement alternative or a variant in a record type
3102 -- The node kind of the current Choice
3105 -- Set Expected type (= choice type except for universal integer,
3106 -- where we accept any integer type as a choice).
3108 if Choice_Type
= Universal_Integer
then
3109 Expected_Type
:= Any_Integer
;
3111 Expected_Type
:= Choice_Type
;
3114 -- Now loop through the case alternatives or record variants
3116 Alt
:= First
(Alternatives
);
3117 while Present
(Alt
) loop
3119 -- If pragma, just analyze it
3121 if Nkind
(Alt
) = N_Pragma
then
3124 -- Otherwise we have an alternative. In most cases the semantic
3125 -- processing leaves the list of choices unchanged
3127 -- Check each choice against its base type
3130 Choice
:= First
(Discrete_Choices
(Alt
));
3131 while Present
(Choice
) loop
3133 Kind
:= Nkind
(Choice
);
3135 -- Choice is a Range
3138 or else (Kind
= N_Attribute_Reference
3139 and then Attribute_Name
(Choice
) = Name_Range
)
3141 Resolve
(Choice
, Expected_Type
);
3143 -- Choice is a subtype name, nothing further to do now
3145 elsif Is_Entity_Name
(Choice
)
3146 and then Is_Type
(Entity
(Choice
))
3150 -- Choice is a subtype indication
3152 elsif Kind
= N_Subtype_Indication
then
3153 Resolve_Discrete_Subtype_Indication
3154 (Choice
, Expected_Type
);
3156 -- Others choice, no analysis needed
3158 elsif Kind
= N_Others_Choice
then
3161 -- Only other possibility is an expression
3164 Resolve
(Choice
, Expected_Type
);
3167 -- Move to next choice
3172 Process_Associated_Node
(Alt
);
3177 end Analyze_Choices
;
3179 end Generic_Analyze_Choices
;
3181 ---------------------------
3182 -- Generic_Check_Choices --
3183 ---------------------------
3185 package body Generic_Check_Choices
is
3187 -- The following type is used to gather the entries for the choice
3188 -- table, so that we can then allocate the right length.
3191 type Link_Ptr
is access all Link
;
3194 Val
: Choice_Bounds
;
3198 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
3204 procedure Check_Choices
3206 Alternatives
: List_Id
;
3208 Others_Present
: out Boolean)
3212 Raises_CE
: Boolean;
3213 -- Set True if one of the bounds of a choice raises CE
3216 -- This is where we post error messages for bounds out of range
3218 Choice_List
: Link_Ptr
:= null;
3219 -- Gather list of choices
3221 Num_Choices
: Nat
:= 0;
3222 -- Number of entries in Choice_List
3224 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
3225 -- The actual type against which the discrete choices are resolved.
3226 -- Note that this type is always the base type not the subtype of the
3227 -- ruling expression, index or discriminant.
3229 Bounds_Type
: Entity_Id
;
3230 -- The type from which are derived the bounds of the values covered
3231 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
3232 -- specifies a value outside of these bounds we have an error.
3236 -- The actual bounds of the above type
3238 Expected_Type
: Entity_Id
;
3239 -- The expected type of each choice. Equal to Choice_Type, except if
3240 -- the expression is universal, in which case the choices can be of
3241 -- any integer type.
3244 -- A case statement alternative or a variant in a record type
3249 -- The node kind of the current Choice
3251 Others_Choice
: Node_Id
:= Empty
;
3252 -- Remember others choice if it is present (empty otherwise)
3254 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
3255 -- Checks the validity of the bounds of a choice. When the bounds
3256 -- are static and no error occurred the bounds are collected for
3257 -- later entry into the choices table so that they can be sorted
3260 procedure Check_Case_Pattern_Choices
;
3261 -- Check choices validity for the Ada extension case where the
3262 -- selecting expression is not of a discrete type and so the
3263 -- choices are patterns.
3265 procedure Check_Composite_Case_Selector
;
3266 -- Check that the (non-discrete) type of the expression being
3267 -- cased on is suitable.
3269 procedure Handle_Static_Predicate
3273 -- If the type of the alternative has predicates, we must examine
3274 -- each subset of the predicate rather than the bounds of the type
3275 -- itself. This is relevant when the choice is a subtype mark or a
3276 -- subtype indication.
3282 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
3287 -- First check if an error was already detected on either bounds
3289 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
3292 -- Do not insert non static choices in the table to be sorted
3294 elsif not Is_OK_Static_Expression
(Lo
)
3296 not Is_OK_Static_Expression
(Hi
)
3298 Process_Non_Static_Choice
(Choice
);
3301 -- Ignore range which raise constraint error
3303 elsif Raises_Constraint_Error
(Lo
)
3304 or else Raises_Constraint_Error
(Hi
)
3309 -- AI05-0188 : Within an instance the non-others choices do not
3310 -- have to belong to the actual subtype.
3312 elsif Ada_Version
>= Ada_2012
and then In_Instance
then
3315 -- Otherwise we have an OK static choice
3318 Lo_Val
:= Expr_Value
(Lo
);
3319 Hi_Val
:= Expr_Value
(Hi
);
3321 -- Do not insert null ranges in the choices table
3323 if Lo_Val
> Hi_Val
then
3324 Process_Empty_Choice
(Choice
);
3329 -- Check for low bound out of range
3331 if Lo_Val
< Bounds_Lo
then
3333 -- If the choice is an entity name, then it is a type, and we
3334 -- want to post the message on the reference to this entity.
3335 -- Otherwise post it on the lower bound of the range.
3337 if Is_Entity_Name
(Choice
) then
3343 -- Specialize message for integer/enum type
3345 if Is_Integer_Type
(Bounds_Type
) then
3346 Error_Msg_Uint_1
:= Bounds_Lo
;
3347 Error_Msg_N
("minimum allowed choice value is^", Enode
);
3349 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
3350 Error_Msg_N
("minimum allowed choice value is%", Enode
);
3354 -- Check for high bound out of range
3356 if Hi_Val
> Bounds_Hi
then
3358 -- If the choice is an entity name, then it is a type, and we
3359 -- want to post the message on the reference to this entity.
3360 -- Otherwise post it on the upper bound of the range.
3362 if Is_Entity_Name
(Choice
) then
3368 -- Specialize message for integer/enum type
3370 if Is_Integer_Type
(Bounds_Type
) then
3371 Error_Msg_Uint_1
:= Bounds_Hi
;
3372 Error_Msg_N
("maximum allowed choice value is^", Enode
);
3374 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
3375 Error_Msg_N
("maximum allowed choice value is%", Enode
);
3379 -- Collect bounds in the list
3381 -- Note: we still store the bounds, even if they are out of range,
3382 -- since this may prevent unnecessary cascaded errors for values
3383 -- that are covered by such an excessive range.
3386 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
3387 Num_Choices := Num_Choices + 1;
3390 --------------------------------
3391 -- Check_Case_Pattern_Choices --
3392 --------------------------------
3394 procedure Check_Case_Pattern_Choices is
3395 package Ops is new Composite_Case_Ops.Choice_Analysis
3396 (Case_Statement => N);
3400 Empty : Value_Set renames Value_Sets.Empty;
3401 -- Cope with hiding due to multiple use clauses
3403 Info : constant Choices_Info := Analysis;
3404 Others_Seen : Boolean := False;
3408 Matches : array (Alternative_Id) of Value_Sets.Value_Set :=
3411 Flag_Overlapping_Within_One_Alternative : constant Boolean :=
3413 -- We may want to flag overlapping (perhaps with only a
3414 -- warning) if the pattern binds an identifier, as in
3415 -- when (Positive, <X>) | (Integer, <X>) =>
3417 Covered : Value_Set := Empty;
3418 -- The union of all alternatives seen so far
3420 if Composite_Case_Ops.Simplified_Composite_Coverage_Rules then
3421 if not (for some Choice of Info => Choice.Is_Others) then
3422 Error_Msg_N ("others choice required", N);
3427 for Choice of Info loop
3428 if Choice.Is_Others then
3429 Others_Seen := True;
3431 if Flag_Overlapping_Within_One_Alternative
3432 and then Compare (Matches (Choice.Alternative),
3433 Choice.Matches) /= Disjoint
3436 ("bad overlapping within one alternative", N);
3439 Union (Target => Matches (Choice.Alternative),
3440 Source => Choice.Matches);
3444 for A1 in Alternative_Id loop
3445 for A2 in Alternative_Id
3446 range A1 + 1 .. Alternative_Id'Last
3448 case Compare (Matches (A1), Matches (A2)) is
3449 when Disjoint | Contained_By =>
3453 Uncovered_1, Uncovered_2 : Value_Set := Empty;
3455 Union (Uncovered_1, Matches (A1));
3456 Remove (Uncovered_1, Covered);
3457 Union (Uncovered_2, Matches (A2));
3458 Remove (Uncovered_2, Covered);
3460 -- Recheck for overlap after removing choices
3461 -- covered by earlier alternatives.
3463 case Compare (Uncovered_1, Uncovered_2) is
3464 when Disjoint | Contained_By =>
3466 when Contains | Overlaps | Equal =>
3468 ("bad alternative overlapping", N);
3473 Error_Msg_N ("alternatives match same values", N);
3475 Error_Msg_N ("alternatives in wrong order", N);
3479 Union (Target => Covered, Source => Matches (A1));
3482 if not Others_Seen and then not Complement_Is_Empty (Covered)
3484 Error_Msg_N ("not all values are covered", N);
3488 Ops.Value_Sets.Free_Value_Sets;
3489 end Check_Case_Pattern_Choices;
3491 -----------------------------------
3492 -- Check_Composite_Case_Selector --
3493 -----------------------------------
3495 procedure Check_Composite_Case_Selector is
3497 if not Is_Composite_Type (Subtyp) then
3499 ("case selector type must be discrete or composite", N);
3500 elsif Is_Limited_Type (Subtyp) then
3501 Error_Msg_N ("case selector type must not be limited", N);
3502 elsif Is_Class_Wide_Type (Subtyp) then
3503 Error_Msg_N ("case selector type must not be class-wide", N);
3504 elsif Needs_Finalization (Subtyp)
3505 and then Is_Newly_Constructed
3506 (Expression (N), Context_Requires_NC => False)
3508 -- We could allow this case as long as there are no bindings.
3510 -- If there are bindings, then allowing this case will get
3511 -- messy because the selector expression will be finalized
3512 -- before the statements of the selected alternative are
3513 -- executed (unless we add an INOX-specific change to the
3514 -- accessibility rules to prevent this earlier-than-wanted
3515 -- finalization, but adding new INOX-specific accessibility
3516 -- complexity is probably not the direction we want to go).
3517 -- This early selector finalization would be ok if we made
3518 -- copies in this case (so that the bindings would not yield
3519 -- a view of a finalized object), but then we'd have to deal
3520 -- with finalizing those copies (which would necessarily
3521 -- include defining their accessibility level). So it gets
3522 -- messy either way.
3524 Error_Msg_N ("case selector must not require finalization", N);
3526 end Check_Composite_Case_Selector;
3528 -----------------------------
3529 -- Handle_Static_Predicate --
3530 -----------------------------
3532 procedure Handle_Static_Predicate
3541 -- Loop through entries in predicate list, checking each entry.
3542 -- Note that if the list is empty, corresponding to a False
3543 -- predicate, then no choices are checked. If the choice comes
3544 -- from a subtype indication, the given range may have bounds
3545 -- that narrow the predicate choices themselves, so we must
3546 -- consider only those entries within the range of the given
3547 -- subtype indication..
3549 P := First (Static_Discrete_Predicate (Typ));
3550 while Present (P) loop
3552 -- Check that part of the predicate choice is included in the
3555 if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
3556 and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
3559 Set_Sloc (C, Sloc (Choice));
3560 Set_Original_Node (C, Choice);
3562 if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
3563 Set_Low_Bound (C, Lo);
3566 if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then
3567 Set_High_Bound (C, Hi);
3570 Check (C, Low_Bound (C), High_Bound (C));
3576 Set_Has_SP_Choice (Alt);
3577 end Handle_Static_Predicate;
3579 -- Start of processing for Check_Choices
3583 Others_Present := False;
3585 -- If Subtyp is not a discrete type or there was some other error,
3586 -- then don't try any semantic checking on the choices since we have
3589 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
3591 -- Hold on, maybe it isn't a complete mess after all.
3593 if Core_Extensions_Allowed and then Subtyp /= Any_Type then
3594 Check_Composite_Case_Selector;
3595 Check_Case_Pattern_Choices;
3601 -- If Subtyp is not a static subtype Ada 95 requires then we use the
3602 -- bounds of its base type to determine the values covered by the
3603 -- discrete choices.
3605 -- In Ada 2012, if the subtype has a nonstatic predicate the full
3606 -- range of the base type must be covered as well.
3608 if Is_OK_Static_Subtype (Subtyp) then
3609 if not Has_Predicates (Subtyp)
3610 or else Has_Static_Predicate (Subtyp)
3612 Bounds_Type := Subtyp;
3614 Bounds_Type := Choice_Type;
3618 Bounds_Type := Choice_Type;
3621 -- Obtain static bounds of type, unless this is a generic formal
3622 -- discrete type for which all choices will be nonstatic.
3624 if not Is_Generic_Type (Root_Type (Bounds_Type))
3625 or else Ekind (Bounds_Type) /= E_Enumeration_Type
3627 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
3628 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
3631 if Choice_Type = Universal_Integer then
3632 Expected_Type := Any_Integer;
3634 Expected_Type := Choice_Type;
3637 -- Now loop through the case alternatives or record variants
3639 Alt := First (Alternatives);
3640 while Present (Alt) loop
3642 -- If pragma, just analyze it
3644 if Nkind (Alt) = N_Pragma then
3647 -- Otherwise we have an alternative. In most cases the semantic
3648 -- processing leaves the list of choices unchanged
3650 -- Check each choice against its base type
3653 Choice := First (Discrete_Choices (Alt));
3654 while Present (Choice) loop
3655 Kind := Nkind (Choice);
3657 -- Choice is a Range
3660 or else (Kind = N_Attribute_Reference
3661 and then Attribute_Name (Choice) = Name_Range)
3663 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
3665 -- Choice is a subtype name
3667 elsif Is_Entity_Name (Choice)
3668 and then Is_Type (Entity (Choice))
3670 -- Check for inappropriate type
3672 if not Covers (Expected_Type, Etype (Choice)) then
3673 Wrong_Type (Choice, Choice_Type);
3675 -- Type is OK, so check further
3678 E := Entity (Choice);
3680 -- Case of predicated subtype
3682 if Has_Predicates (E) then
3684 -- Use of nonstatic predicate is an error
3686 if not Is_Discrete_Type (E)
3687 or else not Has_Static_Predicate (E)
3688 or else Has_Dynamic_Predicate_Aspect (E)
3689 or else Has_Ghost_Predicate_Aspect (E)
3691 Bad_Predicated_Subtype_Use
3692 ("cannot use subtype& with non-static "
3693 & "predicate as case alternative",
3694 Choice, E, Suggest_Static => True);
3696 -- Static predicate case. The bounds are those of
3697 -- the given subtype.
3700 Handle_Static_Predicate (E,
3701 Type_Low_Bound (E), Type_High_Bound (E));
3704 -- Not predicated subtype case
3706 elsif not Is_OK_Static_Subtype (E) then
3707 Process_Non_Static_Choice (Choice);
3710 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
3714 -- Choice is a subtype indication
3716 elsif Kind = N_Subtype_Indication then
3717 Resolve_Discrete_Subtype_Indication
3718 (Choice, Expected_Type);
3720 if Etype (Choice) /= Any_Type then
3722 C : constant Node_Id := Constraint (Choice);
3723 R : constant Node_Id := Range_Expression (C);
3724 L : constant Node_Id := Low_Bound (R);
3725 H : constant Node_Id := High_Bound (R);
3728 E := Entity (Subtype_Mark (Choice));
3730 if not Is_OK_Static_Subtype (E) then
3731 Process_Non_Static_Choice (Choice);
3734 if Is_OK_Static_Expression (L)
3736 Is_OK_Static_Expression (H)
3738 if Expr_Value (L) > Expr_Value (H) then
3739 Process_Empty_Choice (Choice);
3741 if Is_Out_Of_Range (L, E) then
3742 Apply_Compile_Time_Constraint_Error
3743 (L, "static value out of range",
3744 CE_Range_Check_Failed);
3747 if Is_Out_Of_Range (H, E) then
3748 Apply_Compile_Time_Constraint_Error
3749 (H, "static value out of range",
3750 CE_Range_Check_Failed);
3755 -- Check applicable predicate values within the
3756 -- bounds of the given range.
3758 if Has_Static_Predicate (E) then
3759 Handle_Static_Predicate (E, L, H);
3762 Check (Choice, L, H);
3768 -- The others choice is only allowed for the last
3769 -- alternative and as its only choice.
3771 elsif Kind = N_Others_Choice then
3772 if not (Choice = First (Discrete_Choices (Alt))
3773 and then Choice = Last (Discrete_Choices (Alt))
3774 and then Alt = Last (Alternatives))
3777 ("the choice OTHERS must appear alone and last",
3782 Others_Present := True;
3783 Others_Choice := Choice;
3785 -- Only other possibility is an expression
3788 Check (Choice, Choice, Choice);
3791 -- Move to next choice
3796 Process_Associated_Node (Alt);
3802 -- Now we can create the Choice_Table, since we know how long
3803 -- it needs to be so we can allocate exactly the right length.
3806 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
3809 -- Now copy the items we collected in the linked list into this
3810 -- newly allocated table (leave entry 0 unused for sorting).
3815 for J in 1 .. Num_Choices loop
3817 Choice_List := T.Nxt;
3818 Choice_Table (J) := T.Val;
3827 Others_Present or else Choice_Type = Universal_Integer,
3830 -- If no others choice we are all done, otherwise we have one more
3831 -- step, which is to set the Others_Discrete_Choices field of the
3832 -- others choice (to contain all otherwise unspecified choices).
3833 -- Skip this if CE is known to be raised.
3835 if Others_Present and not Raises_CE then
3836 Expand_Others_Choice
3837 (Case_Table => Choice_Table,
3838 Others_Choice => Others_Choice,
3839 Choice_Type => Bounds_Type);
3844 end Generic_Check_Choices;
3846 -----------------------------------------
3847 -- Has_Static_Discriminant_Constraint --
3848 -----------------------------------------
3850 function Has_Static_Discriminant_Constraint
3851 (Subtyp : Entity_Id) return Boolean
3854 if Has_Discriminants (Subtyp) and then Is_Constrained (Subtyp) then
3856 DC_Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Subtyp));
3858 while Present (DC_Elmt) loop
3859 if not All_Composite_Constraints_Static (Node (DC_Elmt)) then
3862 Next_Elmt (DC_Elmt);
3868 end Has_Static_Discriminant_Constraint;
3870 ----------------------------
3871 -- Is_Case_Choice_Pattern --
3872 ----------------------------
3874 function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is
3875 E : Node_Id := Expr;
3877 if not Core_Extensions_Allowed then
3883 when N_Case_Statement_Alternative
3884 | N_Case_Expression_Alternative
3886 -- We could return False if selecting expression is discrete,
3887 -- but this doesn't seem to be worth the bother.
3891 | N_Statement_Other_Than_Procedure_Call
3892 | N_Procedure_Call_Statement
3901 end Is_Case_Choice_Pattern;