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