?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* lto.c (do_stream_out): Add PART parameter; open dump file.
[official-gcc.git] / gcc / ada / sem_case.adb
blob7aef8fac5b6cfe259e315d1e5a666bf4893795c0
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C A S E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-2018, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Errout; use Errout;
29 with Namet; use Namet;
30 with Nlists; use Nlists;
31 with Nmake; use Nmake;
32 with Opt; use Opt;
33 with Sem; use Sem;
34 with Sem_Aux; use Sem_Aux;
35 with Sem_Eval; use Sem_Eval;
36 with Sem_Res; use Sem_Res;
37 with Sem_Util; use Sem_Util;
38 with Sem_Type; use Sem_Type;
39 with Snames; use Snames;
40 with Stand; use Stand;
41 with Sinfo; use Sinfo;
42 with Tbuild; use Tbuild;
43 with Uintp; use Uintp;
44
45 with Ada.Unchecked_Deallocation;
46
47 with GNAT.Heap_Sort_G;
48
49 package body Sem_Case is
50
51 type Choice_Bounds is record
52 Lo : Node_Id;
53 Hi : Node_Id;
54 Node : Node_Id;
55 end record;
56 -- Represent one choice bounds entry with Lo and Hi values, Node points
57 -- to the choice node itself.
58
59 type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
60 -- Table type used to sort the choices present in a case statement or
61 -- record variant. The actual entries are stored in 1 .. Last, but we
62 -- have a 0 entry for use in sorting.
63
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
67
68 procedure Check_Choice_Set
69 (Choice_Table : in out Choice_Table_Type;
70 Bounds_Type : Entity_Id;
71 Subtyp : Entity_Id;
72 Others_Present : Boolean;
73 Case_Node : Node_Id);
74 -- This is the procedure which verifies that a set of case alternatives
75 -- or record variant choices has no duplicates, and covers the range
76 -- specified by Bounds_Type. Choice_Table contains the discrete choices
77 -- to check. These must start at position 1.
78 --
79 -- Furthermore Choice_Table (0) must exist. This element is used by
80 -- the sorting algorithm as a temporary. Others_Present is a flag
81 -- indicating whether or not an Others choice is present. Finally
82 -- Msg_Sloc gives the source location of the construct containing the
83 -- choices in the Choice_Table.
84 --
85 -- Bounds_Type is the type whose range must be covered by the alternatives
86 --
87 -- Subtyp is the subtype of the expression. If its bounds are non-static
88 -- the alternatives must cover its base type.
89
90 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
91 -- Given a Pos value of enumeration type Ctype, returns the name
92 -- ID of an appropriate string to be used in error message output.
93
94 procedure Expand_Others_Choice
95 (Case_Table : Choice_Table_Type;
96 Others_Choice : Node_Id;
97 Choice_Type : Entity_Id);
98 -- The case table is the table generated by a call to Check_Choices
99 -- (with just 1 .. Last_Choice entries present). Others_Choice is a
100 -- pointer to the N_Others_Choice node (this routine is only called if
101 -- an others choice is present), and Choice_Type is the discrete type
102 -- of the bounds. The effect of this call is to analyze the cases and
103 -- determine the set of values covered by others. This choice list is
104 -- set in the Others_Discrete_Choices field of the N_Others_Choice node.
105
106 ----------------------
107 -- Check_Choice_Set --
108 ----------------------
109
110 procedure Check_Choice_Set
111 (Choice_Table : in out Choice_Table_Type;
112 Bounds_Type : Entity_Id;
113 Subtyp : Entity_Id;
114 Others_Present : Boolean;
115 Case_Node : Node_Id)
116 is
117 Predicate_Error : Boolean := False;
118 -- Flag to prevent cascaded errors when a static predicate is known to
119 -- be violated by one choice.
120
121 Num_Choices : constant Nat := Choice_Table'Last;
122
123 procedure Check_Against_Predicate
124 (Pred : in out Node_Id;
125 Choice : Choice_Bounds;
126 Prev_Lo : in out Uint;
127 Prev_Hi : in out Uint;
128 Error : in out Boolean);
129 -- Determine whether a choice covers legal values as defined by a static
130 -- predicate set. Pred is a static predicate range. Choice is the choice
131 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
132 -- choice that covered a predicate set. Error denotes whether the check
133 -- found an illegal intersection.
134
135 procedure Check_Duplicates;
136 -- Check for duplicate choices, and call Dup_Choice if there are any
137 -- such errors. Note that predicates are irrelevant here.
138
139 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
140 -- Post message "duplication of choice value(s) bla bla at xx". Message
141 -- is posted at location C. Caller sets Error_Msg_Sloc for xx.
142
143 procedure Explain_Non_Static_Bound;
144 -- Called when we find a non-static bound, requiring the base type to
145 -- be covered. Provides where possible a helpful explanation of why the
146 -- bounds are non-static, since this is not always obvious.
147
148 function Lt_Choice (C1, C2 : Natural) return Boolean;
149 -- Comparison routine for comparing Choice_Table entries. Use the lower
150 -- bound of each Choice as the key.
151
152 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id);
153 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint);
154 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id);
155 procedure Missing_Choice (Value1 : Uint; Value2 : Uint);
156 -- Issue an error message indicating that there are missing choices,
157 -- followed by the image of the missing choices themselves which lie
158 -- between Value1 and Value2 inclusive.
159
160 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint);
161 -- Emit an error message for each non-covered static predicate set.
162 -- Prev_Hi denotes the upper bound of the last choice covering a set.
163
164 procedure Move_Choice (From : Natural; To : Natural);
165 -- Move routine for sorting the Choice_Table
166
167 package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice);
168
169 -----------------------------
170 -- Check_Against_Predicate --
171 -----------------------------
172
173 procedure Check_Against_Predicate
174 (Pred : in out Node_Id;
175 Choice : Choice_Bounds;
176 Prev_Lo : in out Uint;
177 Prev_Hi : in out Uint;
178 Error : in out Boolean)
179 is
180 procedure Illegal_Range
181 (Loc : Source_Ptr;
182 Lo : Uint;
183 Hi : Uint);
184 -- Emit an error message regarding a choice that clashes with the
185 -- legal static predicate sets. Loc is the location of the choice
186 -- that introduced the illegal range. Lo .. Hi is the range.
187
188 function Inside_Range
189 (Lo : Uint;
190 Hi : Uint;
191 Val : Uint) return Boolean;
192 -- Determine whether position Val within a discrete type is within
193 -- the range Lo .. Hi inclusive.
194
195 -------------------
196 -- Illegal_Range --
197 -------------------
198
199 procedure Illegal_Range
200 (Loc : Source_Ptr;
201 Lo : Uint;
202 Hi : Uint)
203 is
204 begin
205 Error_Msg_Name_1 := Chars (Bounds_Type);
206
207 -- Single value
208
209 if Lo = Hi then
210 if Is_Integer_Type (Bounds_Type) then
211 Error_Msg_Uint_1 := Lo;
212 Error_Msg ("static predicate on % excludes value ^!", Loc);
213 else
214 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
215 Error_Msg ("static predicate on % excludes value %!", Loc);
216 end if;
217
218 -- Range
219
220 else
221 if Is_Integer_Type (Bounds_Type) then
222 Error_Msg_Uint_1 := Lo;
223 Error_Msg_Uint_2 := Hi;
224 Error_Msg
225 ("static predicate on % excludes range ^ .. ^!", Loc);
226 else
227 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
228 Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type);
229 Error_Msg
230 ("static predicate on % excludes range % .. %!", Loc);
231 end if;
232 end if;
233 end Illegal_Range;
234
235 ------------------
236 -- Inside_Range --
237 ------------------
238
239 function Inside_Range
240 (Lo : Uint;
241 Hi : Uint;
242 Val : Uint) return Boolean
243 is
244 begin
245 return Lo <= Val and then Val <= Hi;
246 end Inside_Range;
247
248 -- Local variables
249
250 Choice_Hi : constant Uint := Expr_Value (Choice.Hi);
251 Choice_Lo : constant Uint := Expr_Value (Choice.Lo);
252 Loc : Source_Ptr;
253 LocN : Node_Id;
254 Next_Hi : Uint;
255 Next_Lo : Uint;
256 Pred_Hi : Uint;
257 Pred_Lo : Uint;
258
259 -- Start of processing for Check_Against_Predicate
260
261 begin
262 -- Find the proper error message location
263
264 if Present (Choice.Node) then
265 LocN := Choice.Node;
266 else
267 LocN := Case_Node;
268 end if;
269
270 Loc := Sloc (LocN);
271
272 if Present (Pred) then
273 Pred_Lo := Expr_Value (Low_Bound (Pred));
274 Pred_Hi := Expr_Value (High_Bound (Pred));
275
276 -- Previous choices managed to satisfy all static predicate sets
277
278 else
279 Illegal_Range (Loc, Choice_Lo, Choice_Hi);
280 Error := True;
281 return;
282 end if;
283
284 -- Step 1: Ignore duplicate choices, other than to set the flag,
285 -- because these were already detected by Check_Duplicates.
286
287 if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
288 or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
289 then
290 Error := True;
291
292 -- Step 2: Detect full coverage
293
294 -- Choice_Lo Choice_Hi
295 -- +============+
296 -- Pred_Lo Pred_Hi
297
298 elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then
299 Prev_Lo := Choice_Lo;
300 Prev_Hi := Choice_Hi;
301 Next (Pred);
302
303 -- Step 3: Detect all cases where a choice mentions values that are
304 -- not part of the static predicate sets.
305
306 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
307 -- +-----------+ . . . . . +=========+
308 -- ^ illegal ^
309
310 elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then
311 Illegal_Range (Loc, Choice_Lo, Choice_Hi);
312 Error := True;
313
314 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
315 -- +-----------+=========+===========+
316 -- ^ illegal ^
317
318 elsif Choice_Lo < Pred_Lo
319 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi)
320 then
321 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
322 Error := True;
323
324 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
325 -- +=========+ . . . . +-----------+
326 -- ^ illegal ^
327
328 elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then
329 if Others_Present then
330
331 -- Current predicate set is covered by others clause.
332
333 null;
334
335 else
336 Missing_Choice (Pred_Lo, Pred_Hi);
337 Error := True;
338 end if;
339
340 -- There may be several static predicate sets between the current
341 -- one and the choice. Inspect the next static predicate set.
342
343 Next (Pred);
344 Check_Against_Predicate
345 (Pred => Pred,
346 Choice => Choice,
347 Prev_Lo => Prev_Lo,
348 Prev_Hi => Prev_Hi,
349 Error => Error);
350
351 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
352 -- +=========+===========+-----------+
353 -- ^ illegal ^
354
355 elsif Pred_Hi < Choice_Hi
356 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo)
357 then
358 Next (Pred);
359
360 -- The choice may fall in a static predicate set. If this is the
361 -- case, avoid mentioning legal values in the error message.
362
363 if Present (Pred) then
364 Next_Lo := Expr_Value (Low_Bound (Pred));
365 Next_Hi := Expr_Value (High_Bound (Pred));
366
367 -- The next static predicate set is to the right of the choice
368
369 if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then
370 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
371 else
372 Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1);
373 end if;
374 else
375 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
376 end if;
377
378 Error := True;
379
380 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
381 -- +-----------+=========+-----------+
382 -- ^ illegal ^ ^ illegal ^
383
384 -- Emit an error on the low gap, disregard the upper gap
385
386 elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then
387 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
388 Error := True;
389
390 -- Step 4: Detect all cases of partial or missing coverage
391
392 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
393 -- +=========+==========+===========+
394 -- ^ gap ^ ^ gap ^
395
396 else
397 -- An "others" choice covers all gaps
398
399 if Others_Present then
400 Prev_Lo := Choice_Lo;
401 Prev_Hi := Choice_Hi;
402
403 -- Check whether predicate set is fully covered by choice
404
405 if Pred_Hi = Choice_Hi then
406 Next (Pred);
407 end if;
408
409 -- Choice_Lo Choice_Hi Pred_Hi
410 -- +===========+===========+
411 -- Pred_Lo ^ gap ^
412
413 -- The upper gap may be covered by a subsequent choice
414
415 elsif Pred_Lo = Choice_Lo then
416 Prev_Lo := Choice_Lo;
417 Prev_Hi := Choice_Hi;
418
419 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
420 -- +===========+=========+===========+===========+
421 -- ^ covered ^ ^ gap ^
422
423 else pragma Assert (Pred_Lo < Choice_Lo);
424
425 -- A previous choice covered the gap up to the current choice
426
427 if Prev_Hi = Choice_Lo - 1 then
428 Prev_Lo := Choice_Lo;
429 Prev_Hi := Choice_Hi;
430
431 if Choice_Hi = Pred_Hi then
432 Next (Pred);
433 end if;
434
435 -- The previous choice did not intersect with the current
436 -- static predicate set.
437
438 elsif Prev_Hi < Pred_Lo then
439 Missing_Choice (Pred_Lo, Choice_Lo - 1);
440 Error := True;
441
442 -- The previous choice covered part of the static predicate set
443 -- but there is a gap after Prev_Hi.
444
445 else
446 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
447 Error := True;
448 end if;
449 end if;
450 end if;
451 end Check_Against_Predicate;
452
453 ----------------------
454 -- Check_Duplicates --
455 ----------------------
456
457 procedure Check_Duplicates is
458 Choice : Node_Id;
459 Choice_Hi : Uint;
460 Choice_Lo : Uint;
461 Prev_Choice : Node_Id;
462 pragma Warnings (Off, Prev_Choice);
463 Prev_Hi : Uint;
464
465 begin
466 Prev_Hi := Expr_Value (Choice_Table (1).Hi);
467
468 for Outer_Index in 2 .. Num_Choices loop
469 Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
470 Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
471
472 -- Choices overlap; this is an error
473
474 if Choice_Lo <= Prev_Hi then
475 Choice := Choice_Table (Outer_Index).Node;
476
477 -- Find first previous choice that overlaps
478
479 for Inner_Index in 1 .. Outer_Index - 1 loop
480 if Choice_Lo <=
481 Expr_Value (Choice_Table (Inner_Index).Hi)
482 then
483 Prev_Choice := Choice_Table (Inner_Index).Node;
484 exit;
485 end if;
486 end loop;
487
488 if Sloc (Prev_Choice) <= Sloc (Choice) then
489 Error_Msg_Sloc := Sloc (Prev_Choice);
490 Dup_Choice (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
491 else
492 Error_Msg_Sloc := Sloc (Choice);
493 Dup_Choice
494 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
495 end if;
496 end if;
497
498 if Choice_Hi > Prev_Hi then
499 Prev_Hi := Choice_Hi;
500 end if;
501 end loop;
502 end Check_Duplicates;
503
504 ----------------
505 -- Dup_Choice --
506 ----------------
507
508 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is
509 begin
510 -- In some situations, we call this with a null range, and obviously
511 -- we don't want to complain in this case.
512
513 if Lo > Hi then
514 return;
515 end if;
516
517 -- Case of only one value that is duplicated
518
519 if Lo = Hi then
520
521 -- Integer type
522
523 if Is_Integer_Type (Bounds_Type) then
524
525 -- We have an integer value, Lo, but if the given choice
526 -- placement is a constant with that value, then use the
527 -- name of that constant instead in the message:
528
529 if Nkind (C) = N_Identifier
530 and then Compile_Time_Known_Value (C)
531 and then Expr_Value (C) = Lo
532 then
533 Error_Msg_N ("duplication of choice value: &#!", C);
534
535 -- Not that special case, so just output the integer value
536
537 else
538 Error_Msg_Uint_1 := Lo;
539 Error_Msg_N ("duplication of choice value: ^#!", C);
540 end if;
541
542 -- Enumeration type
543
544 else
545 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
546 Error_Msg_N ("duplication of choice value: %#!", C);
547 end if;
548
549 -- More than one choice value, so print range of values
550
551 else
552 -- Integer type
553
554 if Is_Integer_Type (Bounds_Type) then
555
556 -- Similar to the above, if C is a range of known values which
557 -- match Lo and Hi, then use the names. We have to go to the
558 -- original nodes, since the values will have been rewritten
559 -- to their integer values.
560
561 if Nkind (C) = N_Range
562 and then Nkind (Original_Node (Low_Bound (C))) = N_Identifier
563 and then Nkind (Original_Node (High_Bound (C))) = N_Identifier
564 and then Compile_Time_Known_Value (Low_Bound (C))
565 and then Compile_Time_Known_Value (High_Bound (C))
566 and then Expr_Value (Low_Bound (C)) = Lo
567 and then Expr_Value (High_Bound (C)) = Hi
568 then
569 Error_Msg_Node_2 := Original_Node (High_Bound (C));
570 Error_Msg_N
571 ("duplication of choice values: & .. &#!",
572 Original_Node (Low_Bound (C)));
573
574 -- Not that special case, output integer values
575
576 else
577 Error_Msg_Uint_1 := Lo;
578 Error_Msg_Uint_2 := Hi;
579 Error_Msg_N ("duplication of choice values: ^ .. ^#!", C);
580 end if;
581
582 -- Enumeration type
583
584 else
585 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
586 Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type);
587 Error_Msg_N ("duplication of choice values: % .. %#!", C);
588 end if;
589 end if;
590 end Dup_Choice;
591
592 ------------------------------
593 -- Explain_Non_Static_Bound --
594 ------------------------------
595
596 procedure Explain_Non_Static_Bound is
597 Expr : Node_Id;
598
599 begin
600 if Nkind (Case_Node) = N_Variant_Part then
601 Expr := Name (Case_Node);
602 else
603 Expr := Expression (Case_Node);
604 end if;
605
606 if Bounds_Type /= Subtyp then
607
608 -- If the case is a variant part, the expression is given by the
609 -- discriminant itself, and the bounds are the culprits.
610
611 if Nkind (Case_Node) = N_Variant_Part then
612 Error_Msg_NE
613 ("bounds of & are not static, "
614 & "alternatives must cover base type!", Expr, Expr);
615
616 -- If this is a case statement, the expression may be non-static
617 -- or else the subtype may be at fault.
618
619 elsif Is_Entity_Name (Expr) then
620 Error_Msg_NE
621 ("bounds of & are not static, "
622 & "alternatives must cover base type!", Expr, Expr);
623
624 else
625 Error_Msg_N
626 ("subtype of expression is not static, "
627 & "alternatives must cover base type!", Expr);
628 end if;
629
630 -- Otherwise the expression is not static, even if the bounds of the
631 -- type are, or else there are missing alternatives. If both, the
632 -- additional information may be redundant but harmless. Examine
633 -- whether original node is an entity, because it may have been
634 -- constant-folded to a literal if value is known.
635
636 elsif not Is_Entity_Name (Original_Node (Expr)) then
637 Error_Msg_N
638 ("subtype of expression is not static, "
639 & "alternatives must cover base type!", Expr);
640 end if;
641 end Explain_Non_Static_Bound;
642
643 ---------------
644 -- Lt_Choice --
645 ---------------
646
647 function Lt_Choice (C1, C2 : Natural) return Boolean is
648 begin
649 return
650 Expr_Value (Choice_Table (Nat (C1)).Lo)
651 <
652 Expr_Value (Choice_Table (Nat (C2)).Lo);
653 end Lt_Choice;
654
655 --------------------
656 -- Missing_Choice --
657 --------------------
658
659 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is
660 begin
661 Missing_Choice (Expr_Value (Value1), Expr_Value (Value2));
662 end Missing_Choice;
663
664 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is
665 begin
666 Missing_Choice (Expr_Value (Value1), Value2);
667 end Missing_Choice;
668
669 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is
670 begin
671 Missing_Choice (Value1, Expr_Value (Value2));
672 end Missing_Choice;
673
674 --------------------
675 -- Missing_Choice --
676 --------------------
677
678 procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is
679 Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
680
681 begin
682 -- AI05-0188 : within an instance the non-others choices do not have
683 -- to belong to the actual subtype.
684
685 if Ada_Version >= Ada_2012 and then In_Instance then
686 return;
687
688 -- In some situations, we call this with a null range, and obviously
689 -- we don't want to complain in this case.
690
691 elsif Value1 > Value2 then
692 return;
693
694 -- If predicate is already known to be violated, do no check for
695 -- coverage error, to prevent cascaded messages.
696
697 elsif Predicate_Error then
698 return;
699 end if;
700
701 -- Case of only one value that is missing
702
703 if Value1 = Value2 then
704 if Is_Integer_Type (Bounds_Type) then
705 Error_Msg_Uint_1 := Value1;
706 Error_Msg ("missing case value: ^!", Msg_Sloc);
707 else
708 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
709 Error_Msg ("missing case value: %!", Msg_Sloc);
710 end if;
711
712 -- More than one choice value, so print range of values
713
714 else
715 if Is_Integer_Type (Bounds_Type) then
716 Error_Msg_Uint_1 := Value1;
717 Error_Msg_Uint_2 := Value2;
718 Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
719 else
720 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
721 Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
722 Error_Msg ("missing case values: % .. %!", Msg_Sloc);
723 end if;
724 end if;
725 end Missing_Choice;
726
727 ---------------------
728 -- Missing_Choices --
729 ---------------------
730
731 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is
732 Hi : Uint;
733 Lo : Uint;
734 Set : Node_Id;
735
736 begin
737 Set := Pred;
738 while Present (Set) loop
739 Lo := Expr_Value (Low_Bound (Set));
740 Hi := Expr_Value (High_Bound (Set));
741
742 -- A choice covered part of a static predicate set
743
744 if Lo <= Prev_Hi and then Prev_Hi < Hi then
745 Missing_Choice (Prev_Hi + 1, Hi);
746
747 else
748 Missing_Choice (Lo, Hi);
749 end if;
750
751 Next (Set);
752 end loop;
753 end Missing_Choices;
754
755 -----------------
756 -- Move_Choice --
757 -----------------
758
759 procedure Move_Choice (From : Natural; To : Natural) is
760 begin
761 Choice_Table (Nat (To)) := Choice_Table (Nat (From));
762 end Move_Choice;
763
764 -- Local variables
765
766 Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
767 Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
768 Has_Predicate : constant Boolean :=
769 Is_OK_Static_Subtype (Bounds_Type)
770 and then Has_Static_Predicate (Bounds_Type);
771
772 Choice_Hi : Uint;
773 Choice_Lo : Uint;
774 Pred : Node_Id;
775 Prev_Lo : Uint;
776 Prev_Hi : Uint;
777
778 -- Start of processing for Check_Choice_Set
779
780 begin
781 -- If the case is part of a predicate aspect specification, do not
782 -- recheck it against itself.
783
784 if Present (Parent (Case_Node))
785 and then Nkind (Parent (Case_Node)) = N_Aspect_Specification
786 then
787 return;
788 end if;
789
790 -- Choice_Table must start at 0 which is an unused location used by the
791 -- sorting algorithm. However the first valid position for a discrete
792 -- choice is 1.
793
794 pragma Assert (Choice_Table'First = 0);
795
796 -- The choices do not cover the base range. Emit an error if "others" is
797 -- not available and return as there is no need for further processing.
798
799 if Num_Choices = 0 then
800 if not Others_Present then
801 Missing_Choice (Bounds_Lo, Bounds_Hi);
802 end if;
803
804 return;
805 end if;
806
807 Sorting.Sort (Positive (Choice_Table'Last));
808
809 -- First check for duplicates. This involved the choices; predicates, if
810 -- any, are irrelevant.
811
812 Check_Duplicates;
813
814 -- Then check for overlaps
815
816 -- If the subtype has a static predicate, the predicate defines subsets
817 -- of legal values and requires finer-grained analysis.
818
819 -- Note that in GNAT the predicate is considered static if the predicate
820 -- expression is static, independently of whether the aspect mentions
821 -- Static explicitly.
822
823 if Has_Predicate then
824 Pred := First (Static_Discrete_Predicate (Bounds_Type));
825
826 -- Make initial value smaller than 'First of type, so that first
827 -- range comparison succeeds. This applies both to integer types
828 -- and to enumeration types.
829
830 Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
831 Prev_Hi := Prev_Lo;
832
833 declare
834 Error : Boolean := False;
835 begin
836 for Index in 1 .. Num_Choices loop
837 Check_Against_Predicate
838 (Pred => Pred,
839 Choice => Choice_Table (Index),
840 Prev_Lo => Prev_Lo,
841 Prev_Hi => Prev_Hi,
842 Error => Error);
843
844 -- The analysis detected an illegal intersection between a
845 -- choice and a static predicate set. Do not examine other
846 -- choices unless all errors are requested.
847
848 if Error then
849 Predicate_Error := True;
850
851 if not All_Errors_Mode then
852 return;
853 end if;
854 end if;
855 end loop;
856 end;
857
858 if Predicate_Error then
859 return;
860 end if;
861
862 -- The choices may legally cover some of the static predicate sets,
863 -- but not all. Emit an error for each non-covered set.
864
865 if not Others_Present then
866 Missing_Choices (Pred, Prev_Hi);
867 end if;
868
869 -- Default analysis
870
871 else
872 Choice_Lo := Expr_Value (Choice_Table (1).Lo);
873 Choice_Hi := Expr_Value (Choice_Table (1).Hi);
874 Prev_Hi := Choice_Hi;
875
876 if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then
877 Missing_Choice (Bounds_Lo, Choice_Lo - 1);
878
879 -- If values are missing outside of the subtype, add explanation.
880 -- No additional message if only one value is missing.
881
882 if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then
883 Explain_Non_Static_Bound;
884 end if;
885 end if;
886
887 for Index in 2 .. Num_Choices loop
888 Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
889 Choice_Hi := Expr_Value (Choice_Table (Index).Hi);
890
891 if Choice_Lo > Prev_Hi + 1 and then not Others_Present then
892 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
893 end if;
894
895 if Choice_Hi > Prev_Hi then
896 Prev_Hi := Choice_Hi;
897 end if;
898 end loop;
899
900 if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then
901 Missing_Choice (Prev_Hi + 1, Bounds_Hi);
902
903 if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then
904 Explain_Non_Static_Bound;
905 end if;
906 end if;
907 end if;
908 end Check_Choice_Set;
909
910 ------------------
911 -- Choice_Image --
912 ------------------
913
914 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
915 Rtp : constant Entity_Id := Root_Type (Ctype);
916 Lit : Entity_Id;
917 C : Int;
918
919 begin
920 -- For character, or wide [wide] character. If 7-bit ASCII graphic
921 -- range, then build and return appropriate character literal name
922
923 if Is_Standard_Character_Type (Ctype) then
924 C := UI_To_Int (Value);
925
926 if C in 16#20# .. 16#7E# then
927 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
928 return Name_Find;
929 end if;
930
931 -- For user defined enumeration type, find enum/char literal
932
933 else
934 Lit := First_Literal (Rtp);
935
936 for J in 1 .. UI_To_Int (Value) loop
937 Next_Literal (Lit);
938 end loop;
939
940 -- If enumeration literal, just return its value
941
942 if Nkind (Lit) = N_Defining_Identifier then
943 return Chars (Lit);
944
945 -- For character literal, get the name and use it if it is
946 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
947
948 else
949 Get_Decoded_Name_String (Chars (Lit));
950
951 if Name_Len = 3
952 and then Name_Buffer (2) in
953 Character'Val (16#20#) .. Character'Val (16#7E#)
954 then
955 return Chars (Lit);
956 end if;
957 end if;
958 end if;
959
960 -- If we fall through, we have a character literal which is not in
961 -- the 7-bit ASCII graphic set. For such cases, we construct the
962 -- name "type'val(nnn)" where type is the choice type, and nnn is
963 -- the pos value passed as an argument to Choice_Image.
964
965 Get_Name_String (Chars (First_Subtype (Ctype)));
966
967 Add_Str_To_Name_Buffer ("'val(");
968 UI_Image (Value);
969 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
970 Add_Char_To_Name_Buffer (')');
971 return Name_Find;
972 end Choice_Image;
973
974 --------------------------
975 -- Expand_Others_Choice --
976 --------------------------
977
978 procedure Expand_Others_Choice
979 (Case_Table : Choice_Table_Type;
980 Others_Choice : Node_Id;
981 Choice_Type : Entity_Id)
982 is
983 Loc : constant Source_Ptr := Sloc (Others_Choice);
984 Choice_List : constant List_Id := New_List;
985 Choice : Node_Id;
986 Exp_Lo : Node_Id;
987 Exp_Hi : Node_Id;
988 Hi : Uint;
989 Lo : Uint;
990 Previous_Hi : Uint;
991
992 function Build_Choice (Value1, Value2 : Uint) return Node_Id;
993 -- Builds a node representing the missing choices given by Value1 and
994 -- Value2. A N_Range node is built if there is more than one literal
995 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
996 -- or N_Character_Literal is built depending on what Choice_Type is.
997
998 function Lit_Of (Value : Uint) return Node_Id;
999 -- Returns the Node_Id for the enumeration literal corresponding to the
1000 -- position given by Value within the enumeration type Choice_Type.
1001
1002 ------------------
1003 -- Build_Choice --
1004 ------------------
1005
1006 function Build_Choice (Value1, Value2 : Uint) return Node_Id is
1007 Lit_Node : Node_Id;
1008 Lo, Hi : Node_Id;
1009
1010 begin
1011 -- If there is only one choice value missing between Value1 and
1012 -- Value2, build an integer or enumeration literal to represent it.
1013
1014 if (Value2 - Value1) = 0 then
1015 if Is_Integer_Type (Choice_Type) then
1016 Lit_Node := Make_Integer_Literal (Loc, Value1);
1017 Set_Etype (Lit_Node, Choice_Type);
1018 else
1019 Lit_Node := Lit_Of (Value1);
1020 end if;
1021
1022 -- Otherwise is more that one choice value that is missing between
1023 -- Value1 and Value2, therefore build a N_Range node of either
1024 -- integer or enumeration literals.
1025
1026 else
1027 if Is_Integer_Type (Choice_Type) then
1028 Lo := Make_Integer_Literal (Loc, Value1);
1029 Set_Etype (Lo, Choice_Type);
1030 Hi := Make_Integer_Literal (Loc, Value2);
1031 Set_Etype (Hi, Choice_Type);
1032 Lit_Node :=
1033 Make_Range (Loc,
1034 Low_Bound => Lo,
1035 High_Bound => Hi);
1036
1037 else
1038 Lit_Node :=
1039 Make_Range (Loc,
1040 Low_Bound => Lit_Of (Value1),
1041 High_Bound => Lit_Of (Value2));
1042 end if;
1043 end if;
1044
1045 return Lit_Node;
1046 end Build_Choice;
1047
1048 ------------
1049 -- Lit_Of --
1050 ------------
1051
1052 function Lit_Of (Value : Uint) return Node_Id is
1053 Lit : Entity_Id;
1054
1055 begin
1056 -- In the case where the literal is of type Character, there needs
1057 -- to be some special handling since there is no explicit chain
1058 -- of literals to search. Instead, a N_Character_Literal node
1059 -- is created with the appropriate Char_Code and Chars fields.
1060
1061 if Is_Standard_Character_Type (Choice_Type) then
1062 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
1063 Lit := New_Node (N_Character_Literal, Loc);
1064 Set_Chars (Lit, Name_Find);
1065 Set_Char_Literal_Value (Lit, Value);
1066 Set_Etype (Lit, Choice_Type);
1067 Set_Is_Static_Expression (Lit, True);
1068 return Lit;
1069
1070 -- Otherwise, iterate through the literals list of Choice_Type
1071 -- "Value" number of times until the desired literal is reached
1072 -- and then return an occurrence of it.
1073
1074 else
1075 Lit := First_Literal (Choice_Type);
1076 for J in 1 .. UI_To_Int (Value) loop
1077 Next_Literal (Lit);
1078 end loop;
1079
1080 return New_Occurrence_Of (Lit, Loc);
1081 end if;
1082 end Lit_Of;
1083
1084 -- Start of processing for Expand_Others_Choice
1085
1086 begin
1087 if Case_Table'Last = 0 then
1088
1089 -- Special case: only an others case is present. The others case
1090 -- covers the full range of the type.
1091
1092 if Is_OK_Static_Subtype (Choice_Type) then
1093 Choice := New_Occurrence_Of (Choice_Type, Loc);
1094 else
1095 Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
1096 end if;
1097
1098 Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
1099 return;
1100 end if;
1101
1102 -- Establish the bound values for the choice depending upon whether the
1103 -- type of the case statement is static or not.
1104
1105 if Is_OK_Static_Subtype (Choice_Type) then
1106 Exp_Lo := Type_Low_Bound (Choice_Type);
1107 Exp_Hi := Type_High_Bound (Choice_Type);
1108 else
1109 Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
1110 Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
1111 end if;
1112
1113 Lo := Expr_Value (Case_Table (1).Lo);
1114 Hi := Expr_Value (Case_Table (1).Hi);
1115 Previous_Hi := Expr_Value (Case_Table (1).Hi);
1116
1117 -- Build the node for any missing choices that are smaller than any
1118 -- explicit choices given in the case.
1119
1120 if Expr_Value (Exp_Lo) < Lo then
1121 Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
1122 end if;
1123
1124 -- Build the nodes representing any missing choices that lie between
1125 -- the explicit ones given in the case.
1126
1127 for J in 2 .. Case_Table'Last loop
1128 Lo := Expr_Value (Case_Table (J).Lo);
1129 Hi := Expr_Value (Case_Table (J).Hi);
1130
1131 if Lo /= (Previous_Hi + 1) then
1132 Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
1133 end if;
1134
1135 Previous_Hi := Hi;
1136 end loop;
1137
1138 -- Build the node for any missing choices that are greater than any
1139 -- explicit choices given in the case.
1140
1141 if Expr_Value (Exp_Hi) > Hi then
1142 Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
1143 end if;
1144
1145 Set_Others_Discrete_Choices (Others_Choice, Choice_List);
1146
1147 -- Warn on null others list if warning option set
1148
1149 if Warn_On_Redundant_Constructs
1150 and then Comes_From_Source (Others_Choice)
1151 and then Is_Empty_List (Choice_List)
1152 then
1153 Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice);
1154 Error_Msg_N ("\?r?previous choices cover all values", Others_Choice);
1155 end if;
1156 end Expand_Others_Choice;
1157
1158 -----------
1159 -- No_OP --
1160 -----------
1161
1162 procedure No_OP (C : Node_Id) is
1163 begin
1164 if Nkind (C) = N_Range and then Warn_On_Redundant_Constructs then
1165 Error_Msg_N ("choice is an empty range?r?", C);
1166 end if;
1167 end No_OP;
1168
1169 -----------------------------
1170 -- Generic_Analyze_Choices --
1171 -----------------------------
1172
1173 package body Generic_Analyze_Choices is
1174
1175 -- The following type is used to gather the entries for the choice
1176 -- table, so that we can then allocate the right length.
1177
1178 type Link;
1179 type Link_Ptr is access all Link;
1180
1181 type Link is record
1182 Val : Choice_Bounds;
1183 Nxt : Link_Ptr;
1184 end record;
1185
1186 ---------------------
1187 -- Analyze_Choices --
1188 ---------------------
1189
1190 procedure Analyze_Choices
1191 (Alternatives : List_Id;
1192 Subtyp : Entity_Id)
1193 is
1194 Choice_Type : constant Entity_Id := Base_Type (Subtyp);
1195 -- The actual type against which the discrete choices are resolved.
1196 -- Note that this type is always the base type not the subtype of the
1197 -- ruling expression, index or discriminant.
1198
1199 Expected_Type : Entity_Id;
1200 -- The expected type of each choice. Equal to Choice_Type, except if
1201 -- the expression is universal, in which case the choices can be of
1202 -- any integer type.
1203
1204 Alt : Node_Id;
1205 -- A case statement alternative or a variant in a record type
1206 -- declaration.
1207
1208 Choice : Node_Id;
1209 Kind : Node_Kind;
1210 -- The node kind of the current Choice
1211
1212 begin
1213 -- Set Expected type (= choice type except for universal integer,
1214 -- where we accept any integer type as a choice).
1215
1216 if Choice_Type = Universal_Integer then
1217 Expected_Type := Any_Integer;
1218 else
1219 Expected_Type := Choice_Type;
1220 end if;
1221
1222 -- Now loop through the case alternatives or record variants
1223
1224 Alt := First (Alternatives);
1225 while Present (Alt) loop
1226
1227 -- If pragma, just analyze it
1228
1229 if Nkind (Alt) = N_Pragma then
1230 Analyze (Alt);
1231
1232 -- Otherwise we have an alternative. In most cases the semantic
1233 -- processing leaves the list of choices unchanged
1234
1235 -- Check each choice against its base type
1236
1237 else
1238 Choice := First (Discrete_Choices (Alt));
1239 while Present (Choice) loop
1240 Analyze (Choice);
1241 Kind := Nkind (Choice);
1242
1243 -- Choice is a Range
1244
1245 if Kind = N_Range
1246 or else (Kind = N_Attribute_Reference
1247 and then Attribute_Name (Choice) = Name_Range)
1248 then
1249 Resolve (Choice, Expected_Type);
1250
1251 -- Choice is a subtype name, nothing further to do now
1252
1253 elsif Is_Entity_Name (Choice)
1254 and then Is_Type (Entity (Choice))
1255 then
1256 null;
1257
1258 -- Choice is a subtype indication
1259
1260 elsif Kind = N_Subtype_Indication then
1261 Resolve_Discrete_Subtype_Indication
1262 (Choice, Expected_Type);
1263
1264 -- Others choice, no analysis needed
1265
1266 elsif Kind = N_Others_Choice then
1267 null;
1268
1269 -- Only other possibility is an expression
1270
1271 else
1272 Resolve (Choice, Expected_Type);
1273 end if;
1274
1275 -- Move to next choice
1276
1277 Next (Choice);
1278 end loop;
1279
1280 Process_Associated_Node (Alt);
1281 end if;
1282
1283 Next (Alt);
1284 end loop;
1285 end Analyze_Choices;
1286
1287 end Generic_Analyze_Choices;
1288
1289 ---------------------------
1290 -- Generic_Check_Choices --
1291 ---------------------------
1292
1293 package body Generic_Check_Choices is
1294
1295 -- The following type is used to gather the entries for the choice
1296 -- table, so that we can then allocate the right length.
1297
1298 type Link;
1299 type Link_Ptr is access all Link;
1300
1301 type Link is record
1302 Val : Choice_Bounds;
1303 Nxt : Link_Ptr;
1304 end record;
1305
1306 procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
1307
1308 -------------------
1309 -- Check_Choices --
1310 -------------------
1311
1312 procedure Check_Choices
1313 (N : Node_Id;
1314 Alternatives : List_Id;
1315 Subtyp : Entity_Id;
1316 Others_Present : out Boolean)
1317 is
1318 E : Entity_Id;
1319
1320 Raises_CE : Boolean;
1321 -- Set True if one of the bounds of a choice raises CE
1322
1323 Enode : Node_Id;
1324 -- This is where we post error messages for bounds out of range
1325
1326 Choice_List : Link_Ptr := null;
1327 -- Gather list of choices
1328
1329 Num_Choices : Nat := 0;
1330 -- Number of entries in Choice_List
1331
1332 Choice_Type : constant Entity_Id := Base_Type (Subtyp);
1333 -- The actual type against which the discrete choices are resolved.
1334 -- Note that this type is always the base type not the subtype of the
1335 -- ruling expression, index or discriminant.
1336
1337 Bounds_Type : Entity_Id;
1338 -- The type from which are derived the bounds of the values covered
1339 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
1340 -- specifies a value outside of these bounds we have an error.
1341
1342 Bounds_Lo : Uint;
1343 Bounds_Hi : Uint;
1344 -- The actual bounds of the above type
1345
1346 Expected_Type : Entity_Id;
1347 -- The expected type of each choice. Equal to Choice_Type, except if
1348 -- the expression is universal, in which case the choices can be of
1349 -- any integer type.
1350
1351 Alt : Node_Id;
1352 -- A case statement alternative or a variant in a record type
1353 -- declaration.
1354
1355 Choice : Node_Id;
1356 Kind : Node_Kind;
1357 -- The node kind of the current Choice
1358
1359 Others_Choice : Node_Id := Empty;
1360 -- Remember others choice if it is present (empty otherwise)
1361
1362 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
1363 -- Checks the validity of the bounds of a choice. When the bounds
1364 -- are static and no error occurred the bounds are collected for
1365 -- later entry into the choices table so that they can be sorted
1366 -- later on.
1367
1368 procedure Handle_Static_Predicate
1369 (Typ : Entity_Id;
1370 Lo : Node_Id;
1371 Hi : Node_Id);
1372 -- If the type of the alternative has predicates, we must examine
1373 -- each subset of the predicate rather than the bounds of the type
1374 -- itself. This is relevant when the choice is a subtype mark or a
1375 -- subtype indication.
1376
1377 -----------
1378 -- Check --
1379 -----------
1380
1381 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
1382 Lo_Val : Uint;
1383 Hi_Val : Uint;
1384
1385 begin
1386 -- First check if an error was already detected on either bounds
1387
1388 if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
1389 return;
1390
1391 -- Do not insert non static choices in the table to be sorted
1392
1393 elsif not Is_OK_Static_Expression (Lo)
1394 or else
1395 not Is_OK_Static_Expression (Hi)
1396 then
1397 Process_Non_Static_Choice (Choice);
1398 return;
1399
1400 -- Ignore range which raise constraint error
1401
1402 elsif Raises_Constraint_Error (Lo)
1403 or else Raises_Constraint_Error (Hi)
1404 then
1405 Raises_CE := True;
1406 return;
1407
1408 -- AI05-0188 : Within an instance the non-others choices do not
1409 -- have to belong to the actual subtype.
1410
1411 elsif Ada_Version >= Ada_2012 and then In_Instance then
1412 return;
1413
1414 -- Otherwise we have an OK static choice
1415
1416 else
1417 Lo_Val := Expr_Value (Lo);
1418 Hi_Val := Expr_Value (Hi);
1419
1420 -- Do not insert null ranges in the choices table
1421
1422 if Lo_Val > Hi_Val then
1423 Process_Empty_Choice (Choice);
1424 return;
1425 end if;
1426 end if;
1427
1428 -- Check for low bound out of range
1429
1430 if Lo_Val < Bounds_Lo then
1431
1432 -- If the choice is an entity name, then it is a type, and we
1433 -- want to post the message on the reference to this entity.
1434 -- Otherwise post it on the lower bound of the range.
1435
1436 if Is_Entity_Name (Choice) then
1437 Enode := Choice;
1438 else
1439 Enode := Lo;
1440 end if;
1441
1442 -- Specialize message for integer/enum type
1443
1444 if Is_Integer_Type (Bounds_Type) then
1445 Error_Msg_Uint_1 := Bounds_Lo;
1446 Error_Msg_N ("minimum allowed choice value is^", Enode);
1447 else
1448 Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
1449 Error_Msg_N ("minimum allowed choice value is%", Enode);
1450 end if;
1451 end if;
1452
1453 -- Check for high bound out of range
1454
1455 if Hi_Val > Bounds_Hi then
1456
1457 -- If the choice is an entity name, then it is a type, and we
1458 -- want to post the message on the reference to this entity.
1459 -- Otherwise post it on the upper bound of the range.
1460
1461 if Is_Entity_Name (Choice) then
1462 Enode := Choice;
1463 else
1464 Enode := Hi;
1465 end if;
1466
1467 -- Specialize message for integer/enum type
1468
1469 if Is_Integer_Type (Bounds_Type) then
1470 Error_Msg_Uint_1 := Bounds_Hi;
1471 Error_Msg_N ("maximum allowed choice value is^", Enode);
1472 else
1473 Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
1474 Error_Msg_N ("maximum allowed choice value is%", Enode);
1475 end if;
1476 end if;
1477
1478 -- Collect bounds in the list
1479
1480 -- Note: we still store the bounds, even if they are out of range,
1481 -- since this may prevent unnecessary cascaded errors for values
1482 -- that are covered by such an excessive range.
1483
1484 Choice_List :=
1485 new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
1486 Num_Choices := Num_Choices + 1;
1487 end Check;
1488
1489 -----------------------------
1490 -- Handle_Static_Predicate --
1491 -----------------------------
1492
1493 procedure Handle_Static_Predicate
1494 (Typ : Entity_Id;
1495 Lo : Node_Id;
1496 Hi : Node_Id)
1497 is
1498 P : Node_Id;
1499 C : Node_Id;
1500
1501 begin
1502 -- Loop through entries in predicate list, checking each entry.
1503 -- Note that if the list is empty, corresponding to a False
1504 -- predicate, then no choices are checked. If the choice comes
1505 -- from a subtype indication, the given range may have bounds
1506 -- that narrow the predicate choices themselves, so we must
1507 -- consider only those entries within the range of the given
1508 -- subtype indication..
1509
1510 P := First (Static_Discrete_Predicate (Typ));
1511 while Present (P) loop
1512
1513 -- Check that part of the predicate choice is included in the
1514 -- given bounds.
1515
1516 if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
1517 and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
1518 then
1519 C := New_Copy (P);
1520 Set_Sloc (C, Sloc (Choice));
1521
1522 if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
1523 Set_Low_Bound (C, Lo);
1524 end if;
1525
1526 if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then
1527 Set_High_Bound (C, Hi);
1528 end if;
1529
1530 Check (C, Low_Bound (C), High_Bound (C));
1531 end if;
1532
1533 Next (P);
1534 end loop;
1535
1536 Set_Has_SP_Choice (Alt);
1537 end Handle_Static_Predicate;
1538
1539 -- Start of processing for Check_Choices
1540
1541 begin
1542 Raises_CE := False;
1543 Others_Present := False;
1544
1545 -- If Subtyp is not a discrete type or there was some other error,
1546 -- then don't try any semantic checking on the choices since we have
1547 -- a complete mess.
1548
1549 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
1550 return;
1551 end if;
1552
1553 -- If Subtyp is not a static subtype Ada 95 requires then we use the
1554 -- bounds of its base type to determine the values covered by the
1555 -- discrete choices.
1556
1557 -- In Ada 2012, if the subtype has a non-static predicate the full
1558 -- range of the base type must be covered as well.
1559
1560 if Is_OK_Static_Subtype (Subtyp) then
1561 if not Has_Predicates (Subtyp)
1562 or else Has_Static_Predicate (Subtyp)
1563 then
1564 Bounds_Type := Subtyp;
1565 else
1566 Bounds_Type := Choice_Type;
1567 end if;
1568
1569 else
1570 Bounds_Type := Choice_Type;
1571 end if;
1572
1573 -- Obtain static bounds of type, unless this is a generic formal
1574 -- discrete type for which all choices will be non-static.
1575
1576 if not Is_Generic_Type (Root_Type (Bounds_Type))
1577 or else Ekind (Bounds_Type) /= E_Enumeration_Type
1578 then
1579 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
1580 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
1581 end if;
1582
1583 if Choice_Type = Universal_Integer then
1584 Expected_Type := Any_Integer;
1585 else
1586 Expected_Type := Choice_Type;
1587 end if;
1588
1589 -- Now loop through the case alternatives or record variants
1590
1591 Alt := First (Alternatives);
1592 while Present (Alt) loop
1593
1594 -- If pragma, just analyze it
1595
1596 if Nkind (Alt) = N_Pragma then
1597 Analyze (Alt);
1598
1599 -- Otherwise we have an alternative. In most cases the semantic
1600 -- processing leaves the list of choices unchanged
1601
1602 -- Check each choice against its base type
1603
1604 else
1605 Choice := First (Discrete_Choices (Alt));
1606 while Present (Choice) loop
1607 Kind := Nkind (Choice);
1608
1609 -- Choice is a Range
1610
1611 if Kind = N_Range
1612 or else (Kind = N_Attribute_Reference
1613 and then Attribute_Name (Choice) = Name_Range)
1614 then
1615 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
1616
1617 -- Choice is a subtype name
1618
1619 elsif Is_Entity_Name (Choice)
1620 and then Is_Type (Entity (Choice))
1621 then
1622 -- Check for inappropriate type
1623
1624 if not Covers (Expected_Type, Etype (Choice)) then
1625 Wrong_Type (Choice, Choice_Type);
1626
1627 -- Type is OK, so check further
1628
1629 else
1630 E := Entity (Choice);
1631
1632 -- Case of predicated subtype
1633
1634 if Has_Predicates (E) then
1635
1636 -- Use of non-static predicate is an error
1637
1638 if not Is_Discrete_Type (E)
1639 or else not Has_Static_Predicate (E)
1640 or else Has_Dynamic_Predicate_Aspect (E)
1641 then
1642 Bad_Predicated_Subtype_Use
1643 ("cannot use subtype& with non-static "
1644 & "predicate as case alternative",
1645 Choice, E, Suggest_Static => True);
1646
1647 -- Static predicate case. The bounds are those of
1648 -- the given subtype.
1649
1650 else
1651 Handle_Static_Predicate (E,
1652 Type_Low_Bound (E), Type_High_Bound (E));
1653 end if;
1654
1655 -- Not predicated subtype case
1656
1657 elsif not Is_OK_Static_Subtype (E) then
1658 Process_Non_Static_Choice (Choice);
1659 else
1660 Check
1661 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
1662 end if;
1663 end if;
1664
1665 -- Choice is a subtype indication
1666
1667 elsif Kind = N_Subtype_Indication then
1668 Resolve_Discrete_Subtype_Indication
1669 (Choice, Expected_Type);
1670
1671 if Etype (Choice) /= Any_Type then
1672 declare
1673 C : constant Node_Id := Constraint (Choice);
1674 R : constant Node_Id := Range_Expression (C);
1675 L : constant Node_Id := Low_Bound (R);
1676 H : constant Node_Id := High_Bound (R);
1677
1678 begin
1679 E := Entity (Subtype_Mark (Choice));
1680
1681 if not Is_OK_Static_Subtype (E) then
1682 Process_Non_Static_Choice (Choice);
1683
1684 else
1685 if Is_OK_Static_Expression (L)
1686 and then
1687 Is_OK_Static_Expression (H)
1688 then
1689 if Expr_Value (L) > Expr_Value (H) then
1690 Process_Empty_Choice (Choice);
1691 else
1692 if Is_Out_Of_Range (L, E) then
1693 Apply_Compile_Time_Constraint_Error
1694 (L, "static value out of range",
1695 CE_Range_Check_Failed);
1696 end if;
1697
1698 if Is_Out_Of_Range (H, E) then
1699 Apply_Compile_Time_Constraint_Error
1700 (H, "static value out of range",
1701 CE_Range_Check_Failed);
1702 end if;
1703 end if;
1704 end if;
1705
1706 -- Check applicable predicate values within the
1707 -- bounds of the given range.
1708
1709 if Has_Static_Predicate (E) then
1710 Handle_Static_Predicate (E, L, H);
1711
1712 else
1713 Check (Choice, L, H);
1714 end if;
1715 end if;
1716 end;
1717 end if;
1718
1719 -- The others choice is only allowed for the last
1720 -- alternative and as its only choice.
1721
1722 elsif Kind = N_Others_Choice then
1723 if not (Choice = First (Discrete_Choices (Alt))
1724 and then Choice = Last (Discrete_Choices (Alt))
1725 and then Alt = Last (Alternatives))
1726 then
1727 Error_Msg_N
1728 ("the choice OTHERS must appear alone and last",
1729 Choice);
1730 return;
1731 end if;
1732
1733 Others_Present := True;
1734 Others_Choice := Choice;
1735
1736 -- Only other possibility is an expression
1737
1738 else
1739 Check (Choice, Choice, Choice);
1740 end if;
1741
1742 -- Move to next choice
1743
1744 Next (Choice);
1745 end loop;
1746
1747 Process_Associated_Node (Alt);
1748 end if;
1749
1750 Next (Alt);
1751 end loop;
1752
1753 -- Now we can create the Choice_Table, since we know how long
1754 -- it needs to be so we can allocate exactly the right length.
1755
1756 declare
1757 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1758
1759 begin
1760 -- Now copy the items we collected in the linked list into this
1761 -- newly allocated table (leave entry 0 unused for sorting).
1762
1763 declare
1764 T : Link_Ptr;
1765 begin
1766 for J in 1 .. Num_Choices loop
1767 T := Choice_List;
1768 Choice_List := T.Nxt;
1769 Choice_Table (J) := T.Val;
1770 Free (T);
1771 end loop;
1772 end;
1773
1774 Check_Choice_Set
1775 (Choice_Table,
1776 Bounds_Type,
1777 Subtyp,
1778 Others_Present or else (Choice_Type = Universal_Integer),
1779 N);
1780
1781 -- If no others choice we are all done, otherwise we have one more
1782 -- step, which is to set the Others_Discrete_Choices field of the
1783 -- others choice (to contain all otherwise unspecified choices).
1784 -- Skip this if CE is known to be raised.
1785
1786 if Others_Present and not Raises_CE then
1787 Expand_Others_Choice
1788 (Case_Table => Choice_Table,
1789 Others_Choice => Others_Choice,
1790 Choice_Type => Bounds_Type);
1791 end if;
1792 end;
1793 end Check_Choices;
1794
1795 end Generic_Check_Choices;
1796
1797 end Sem_Case;
Mirror of the offical gcc git repository hosted at gcc.gnu.org