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