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