MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
1b096a0a0a
8sa1-gcc/gcc/ada/sem_case.adb
Arnaud Charlet 523456dbde [multiple changes] 
2004-07-15  Robert Dewar  <dewar@gnat.com>

	* makegpr.adb, s-secsta.ads, sem_ch3.adb, sem_case.adb: Minor
	reformatting

	* gnat_ugn.texi: Add instantiation of direct_io or sequential_io with
	access values as an example of a warning.

	* gnat_rm.texi: Document new attribute Has_Access_Values

	* gnat-style.texi: Document that box comments belong on nested
	subprograms

	* sem_util.ads (Has_Access_Values): Improved documentation

	* s-finimp.ads, s-finimp.adb: Fix spelling error in comment

	* sem_prag.adb (Check_Duplicated_Export_Name): New procedure
	(Process_Interface_Name): Call to this new procedure
	(Set_Extended_Import_Export_External_Name): Call to this new procedure

	* s-mastop-x86.adb, 9drpc.adb: Fix spelling error in comment

	* a-direio.ads, a-sequio.ads: Warn if Element_Type has access values

	* einfo.ads: Minor comment typo fixed

2004-07-15  Jose Ruiz  <ruiz@act-europe.fr>

	* snames.adb: Add _atcb.

	* snames.ads: Add Name_uATCB.

	* s-tarest.adb (Create_Restricted_Task): ATCBs are always preallocated
	(in the expanded code) when using the restricted run time.

	* s-tarest.ads (Create_Restricted_Task): Created_Task transformed into
	a in parameter in order to allow ATCBs to be preallocated (in the
	expanded code).

	* s-taskin.adb (Initialize_ATCB): T converted into a in parameter in
	order to allow ATCBs to be preallocated. In case of error, the ATCB is
	deallocated in System.Tasking.Stages.

	* s-taskin.ads (Initialize_ATCB): T converted into a in parameter in
	order to allow ATCBs to be preallocated.

	* s-tassta.adb (Create_Task): In case of error the ATCB is deallocated
	here. It was previously done in Initialize_ATCB.

	* rtsfind.ads: Make the Ada_Task_Control_Block visible.

	* exp_ch9.adb: Preallocate the Ada_Task_Control_Block when using the
	Restricted run time.

	* exp_ch3.adb: When using the Restricted run time, pass the
	preallocated Ada_Task_Control_Block when creating a task.

2004-07-15  Ed Schonberg  <schonberg@gnat.com>

	* sem_util.adb (Normalize_Actuals): If there are no actuals on a
	function call that is itself an actual in an enclosing call, diagnose
	problem here rather than assuming that resolution will catch it.

	* sem_ch7.adb (Analyze_Package_Specification): If the specification is
	the local copy of a generic unit for a formal package, and the generic
	is a child unit, install private part of ancestors before compiling
	private part of spec.

	* sem_cat.adb (Validate_Categorization_Dependency): Simplify code to
	use scope entities rather than tree structures, to handle properly
	parent units that are instances rewritten as bodies for inlining
	purposes.

	* sem_ch10.adb (Get_Parent_Entity, Implicit_With_On_Parent,
	Remove_Parents): Handle properly a parent unit that is an
	instantiation, when the unit has been rewritten as a body for inlining
	purposes.

	* par.adb (Goto_List): Global variable to collect goto statements in a
	given unit, for use in detecting natural loops.

	* par-ch5.adb (P_Goto_Statement): Add goto to global Goto_List, for
	use in detecting natural loops.

	* par-labl.adb (Find_Natural_Loops): Recognize loops create by
	backwards goto's, and rewrite as a infinite loop, to improve locality
	of temporaries.

	* exp_util.adb (Force_Evaluation): Recognize a left-hand side
	subcomponent that includes an indexed reference, to prevent the
	generation of copies that would miscompile the desired assignment
	statement.
	(Build_Task_Image_Decls): Add a numeric suffix to
	generated name for string variable, to avoid spurious conflicts with
	the name of the type of a single protected object.

	* exp_ch4.adb (Expand_Array_Equality): If indices are distinct, use a
	loop with an explicit exit statement, to avoid generating an
	out-of-range value with 'Succ leading to spurious constraint_errors
	when compiling with -gnatVo.

2004-07-15  Thomas Quinot  <quinot@act-europe.fr>

	* sem_ch4.adb (Analyze_Slice): Always call Analyze on the prefix: it
	might not be analyzed yet, even if its Etype is already set (case of an
	unchecked conversion built using Unchecked_Convert_To, for example).
	If the prefix has already been analyzed, this will be a nop anyway.

	* exp_ch5.adb (Make_Tag_Ctrl_Assignment): For an assignment of a
	controller type, or an assignment of a record type with controlled
	components, copy only user data, and leave the finalization chain
	pointers untouched.

2004-07-15  Vincent Celier  <celier@gnat.com>

	* make.adb (Collect_Arguments): Improve error message when attempting
	to compile a source not part of any project, when -x is not used.

	* prj.ads: (Defined_Variable_Kind): New subtype

	* prj-attr.adb (Register_New_Package): Two new procedures to register
	a package with or without its attributes.
	(Register_New_Attribute): Mew procedure to register a new attribute in a
	package.
	New attribute oriented subprograms: Attribute_Node_Id_Of,
	Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
	Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
	Next_Attribute.
	New package oriented subprograms: Package_Node_Id_Of,
	Add_Unknown_Package, First_Attribute_Of, Add_Attribute.

	* prj-attr.ads (Attribute_Node_Id): Now a private, self initialized
	type.
	(Package_Node_Id): Now a private, self initialized type
	(Register_New_Package): New procedure to register a package with its
	attributes.
	New attribute oriented subprograms: Attribute_Node_Id_Of,
	Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
	Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
	Next_Attribute.
	New package oriented subprograms: Package_Node_Id_Of,
	Add_Unknown_Package, First_Attribute_Of, Add_Attribute.

	* prj-dect.adb (Parse_Attribute_Declaration,
	Parse_Package_Declaration): Adapt to new spec of Prj.Attr.

	* prj-makr.adb (Make): Parse existing project file before creating
	other files. Fail if there was an error during parsing.

	* prj-proc.adb (Add_Attributes, Process_Declarative_Items): Adapt to
	new spec of Prj.Attr.

	* prj-strt.adb (Attribute_Reference, Parse_Variable_Reference): Adapt
	to new spec of Prj.Attr.

2004-07-15  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* utils2.c: Fix typo in comment.

From-SVN: r84774
2004-07-15 22:34:43 +02:00

928 lines
32 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ C A S E --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
package body Sem_Case is
-----------------------
-- Local Subprograms --
-----------------------
type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
-- This new array type is used as the actual table type for sorting
-- discrete choices. The reason for not using Choice_Table_Type, is that
-- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algortim
-- (this is not absolutely necessary but it makes the code more
-- efficient).
procedure Check_Choices
(Choice_Table : in out Sort_Choice_Table_Type;
Bounds_Type : Entity_Id;
Others_Present : Boolean;
Msg_Sloc : Source_Ptr);
-- This is the procedure which verifies that a set of case alternatives
-- or record variant choices has no duplicates, and covers the range
-- specified by Bounds_Type. Choice_Table contains the discrete choices
-- to check. These must start at position 1.
-- Furthermore Choice_Table (0) must exist. This element is used by
-- the sorting algorithm as a temporary. Others_Present is a flag
-- indicating whether or not an Others choice is present. Finally
-- Msg_Sloc gives the source location of the construct containing the
-- choices in the Choice_Table.
function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
-- Given a Pos value of enumeration type Ctype, returns the name
-- ID of an appropriate string to be used in error message output.
procedure Expand_Others_Choice
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id);
-- The case table is the table generated by a call to Analyze_Choices
-- (with just 1 .. Last_Choice entries present). Others_Choice is a
-- pointer to the N_Others_Choice node (this routine is only called if
-- an others choice is present), and Choice_Type is the discrete type
-- of the bounds. The effect of this call is to analyze the cases and
-- determine the set of values covered by others. This choice list is
-- set in the Others_Discrete_Choices field of the N_Others_Choice node.
-------------------
-- Check_Choices --
-------------------
procedure Check_Choices
(Choice_Table : in out Sort_Choice_Table_Type;
Bounds_Type : Entity_Id;
Others_Present : Boolean;
Msg_Sloc : Source_Ptr)
is
function Lt_Choice (C1, C2 : Natural) return Boolean;
-- Comparison routine for comparing Choice_Table entries.
-- Use the lower bound of each Choice as the key.
procedure Move_Choice (From : Natural; To : Natural);
-- Move routine for sorting the Choice_Table.
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Uint; Value2 : Uint);
-- Issue an error message indicating that there are missing choices,
-- followed by the image of the missing choices themselves which lie
-- between Value1 and Value2 inclusive.
---------------
-- Issue_Msg --
---------------
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
begin
Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
end Issue_Msg;
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
begin
Issue_Msg (Expr_Value (Value1), Value2);
end Issue_Msg;
procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
begin
Issue_Msg (Value1, Expr_Value (Value2));
end Issue_Msg;
procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
begin
-- In some situations, we call this with a null range, and
-- obviously we don't want to complain in this case!
if Value1 > Value2 then
return;
end if;
-- Case of only one value that is missing
if Value1 = Value2 then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg ("missing case value: ^!", Msg_Sloc);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg ("missing case value: %!", Msg_Sloc);
end if;
-- More than one choice value, so print range of values
else
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg_Uint_2 := Value2;
Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
Error_Msg ("missing case values: % .. %!", Msg_Sloc);
end if;
end if;
end Issue_Msg;
---------------
-- Lt_Choice --
---------------
function Lt_Choice (C1, C2 : Natural) return Boolean is
begin
return
Expr_Value (Choice_Table (Nat (C1)).Lo)
<
Expr_Value (Choice_Table (Nat (C2)).Lo);
end Lt_Choice;
-----------------
-- Move_Choice --
-----------------
procedure Move_Choice (From : Natural; To : Natural) is
begin
Choice_Table (Nat (To)) := Choice_Table (Nat (From));
end Move_Choice;
-- Variables local to Check_Choices
Choice : Node_Id;
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
Prev_Choice : Node_Id;
Hi : Uint;
Lo : Uint;
Prev_Hi : Uint;
-- Start processing for Check_Choices
begin
-- Choice_Table must start at 0 which is an unused location used
-- by the sorting algorithm. However the first valid position for
-- a discrete choice is 1.
pragma Assert (Choice_Table'First = 0);
if Choice_Table'Last = 0 then
if not Others_Present then
Issue_Msg (Bounds_Lo, Bounds_Hi);
end if;
return;
end if;
Sort
(Positive (Choice_Table'Last),
Move_Choice'Unrestricted_Access,
Lt_Choice'Unrestricted_Access);
Lo := Expr_Value (Choice_Table (1).Lo);
Hi := Expr_Value (Choice_Table (1).Hi);
Prev_Hi := Hi;
if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
Issue_Msg (Bounds_Lo, Lo - 1);
end if;
for J in 2 .. Choice_Table'Last loop
Lo := Expr_Value (Choice_Table (J).Lo);
Hi := Expr_Value (Choice_Table (J).Hi);
if Lo <= Prev_Hi then
Prev_Choice := Choice_Table (J - 1).Node;
Choice := Choice_Table (J).Node;
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Error_Msg_N ("duplication of choice value#", Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Error_Msg_N ("duplication of choice value#", Prev_Choice);
end if;
elsif not Others_Present and then Lo /= Prev_Hi + 1 then
Issue_Msg (Prev_Hi + 1, Lo - 1);
end if;
Prev_Hi := Hi;
end loop;
if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
Issue_Msg (Hi + 1, Bounds_Hi);
end if;
end Check_Choices;
------------------
-- Choice_Image --
------------------
function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
Rtp : constant Entity_Id := Root_Type (Ctype);
Lit : Entity_Id;
C : Int;
begin
-- For character, or wide character. If we are in 7-bit ASCII graphic
-- range, then build and return appropriate character literal name
if Rtp = Standard_Character
or else Rtp = Standard_Wide_Character
then
C := UI_To_Int (Value);
if C in 16#20# .. 16#7E# then
Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
return Name_Find;
end if;
-- For user defined enumeration type, find enum/char literal
else
Lit := First_Literal (Rtp);
for J in 1 .. UI_To_Int (Value) loop
Next_Literal (Lit);
end loop;
-- If enumeration literal, just return its value
if Nkind (Lit) = N_Defining_Identifier then
return Chars (Lit);
-- For character literal, get the name and use it if it is
-- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
else
Get_Decoded_Name_String (Chars (Lit));
if Name_Len = 3
and then Name_Buffer (2) in
Character'Val (16#20#) .. Character'Val (16#7E#)
then
return Chars (Lit);
end if;
end if;
end if;
-- If we fall through, we have a character literal which is not in
-- the 7-bit ASCII graphic set. For such cases, we construct the
-- name "type'val(nnn)" where type is the choice type, and nnn is
-- the pos value passed as an argument to Choice_Image.
Get_Name_String (Chars (First_Subtype (Ctype)));
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ''';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := 'v';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := 'a';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := 'l';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := '(';
UI_Image (Value);
for J in 1 .. UI_Image_Length loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := UI_Image_Buffer (J);
end loop;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ')';
return Name_Find;
end Choice_Image;
--------------------------
-- Expand_Others_Choice --
--------------------------
procedure Expand_Others_Choice
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Others_Choice);
Choice_List : constant List_Id := New_List;
Choice : Node_Id;
Exp_Lo : Node_Id;
Exp_Hi : Node_Id;
Hi : Uint;
Lo : Uint;
Previous_Hi : Uint;
function Build_Choice (Value1, Value2 : Uint) return Node_Id;
-- Builds a node representing the missing choices given by the
-- Value1 and Value2. A N_Range node is built if there is more than
-- one literal value missing. Otherwise a single N_Integer_Literal,
-- N_Identifier or N_Character_Literal is built depending on what
-- Choice_Type is.
function Lit_Of (Value : Uint) return Node_Id;
-- Returns the Node_Id for the enumeration literal corresponding to the
-- position given by Value within the enumeration type Choice_Type.
------------------
-- Build_Choice --
------------------
function Build_Choice (Value1, Value2 : Uint) return Node_Id is
Lit_Node : Node_Id;
Lo, Hi : Node_Id;
begin
-- If there is only one choice value missing between Value1 and
-- Value2, build an integer or enumeration literal to represent it.
if (Value2 - Value1) = 0 then
if Is_Integer_Type (Choice_Type) then
Lit_Node := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lit_Node, Choice_Type);
else
Lit_Node := Lit_Of (Value1);
end if;
-- Otherwise is more that one choice value that is missing between
-- Value1 and Value2, therefore build a N_Range node of either
-- integer or enumeration literals.
else
if Is_Integer_Type (Choice_Type) then
Lo := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lo, Choice_Type);
Hi := Make_Integer_Literal (Loc, Value2);
Set_Etype (Hi, Choice_Type);
Lit_Node :=
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi);
else
Lit_Node :=
Make_Range (Loc,
Low_Bound => Lit_Of (Value1),
High_Bound => Lit_Of (Value2));
end if;
end if;
return Lit_Node;
end Build_Choice;
------------
-- Lit_Of --
------------
function Lit_Of (Value : Uint) return Node_Id is
Lit : Entity_Id;
begin
-- In the case where the literal is of type Character, there needs
-- to be some special handling since there is no explicit chain
-- of literals to search. Instead, a N_Character_Literal node
-- is created with the appropriate Char_Code and Chars fields.
if Root_Type (Choice_Type) = Standard_Character
or else
Root_Type (Choice_Type) = Standard_Wide_Character
then
Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
Lit := New_Node (N_Character_Literal, Loc);
Set_Chars (Lit, Name_Find);
Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
Set_Etype (Lit, Choice_Type);
Set_Is_Static_Expression (Lit, True);
return Lit;
-- Otherwise, iterate through the literals list of Choice_Type
-- "Value" number of times until the desired literal is reached
-- and then return an occurrence of it.
else
Lit := First_Literal (Choice_Type);
for J in 1 .. UI_To_Int (Value) loop
Next_Literal (Lit);
end loop;
return New_Occurrence_Of (Lit, Loc);
end if;
end Lit_Of;
-- Start of processing for Expand_Others_Choice
begin
if Case_Table'Length = 0 then
-- Special case: only an others case is present.
-- The others case covers the full range of the type.
if Is_Static_Subtype (Choice_Type) then
Choice := New_Occurrence_Of (Choice_Type, Loc);
else
Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
end if;
Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
return;
end if;
-- Establish the bound values for the choice depending upon whether
-- the type of the case statement is static or not.
if Is_OK_Static_Subtype (Choice_Type) then
Exp_Lo := Type_Low_Bound (Choice_Type);
Exp_Hi := Type_High_Bound (Choice_Type);
else
Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
end if;
Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
-- Build the node for any missing choices that are smaller than any
-- explicit choices given in the case.
if Expr_Value (Exp_Lo) < Lo then
Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
end if;
-- Build the nodes representing any missing choices that lie between
-- the explicit ones given in the case.
for J in Case_Table'First + 1 .. Case_Table'Last loop
Lo := Expr_Value (Case_Table (J).Lo);
Hi := Expr_Value (Case_Table (J).Hi);
if Lo /= (Previous_Hi + 1) then
Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
end if;
Previous_Hi := Hi;
end loop;
-- Build the node for any missing choices that are greater than any
-- explicit choices given in the case.
if Expr_Value (Exp_Hi) > Hi then
Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
end if;
Set_Others_Discrete_Choices (Others_Choice, Choice_List);
-- Warn on null others list if warning option set
if Warn_On_Redundant_Constructs
and then Comes_From_Source (Others_Choice)
and then Is_Empty_List (Choice_List)
then
Error_Msg_N ("?others choice is empty", Others_Choice);
end if;
end Expand_Others_Choice;
-----------
-- No_OP --
-----------
procedure No_OP (C : Node_Id) is
pragma Warnings (Off, C);
begin
null;
end No_OP;
--------------------------------
-- Generic_Choices_Processing --
--------------------------------
package body Generic_Choices_Processing is
---------------------
-- Analyze_Choices --
---------------------
procedure Analyze_Choices
(N : Node_Id;
Subtyp : Entity_Id;
Choice_Table : out Choice_Table_Type;
Last_Choice : out Nat;
Raises_CE : out Boolean;
Others_Present : out Boolean)
is
E : Entity_Id;
Enode : Node_Id;
-- This is where we post error messages for bounds out of range
Nb_Choices : constant Nat := Choice_Table'Length;
Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
Choice_Type : constant Entity_Id := Base_Type (Subtyp);
-- The actual type against which the discrete choices are
-- resolved. Note that this type is always the base type not the
-- subtype of the ruling expression, index or discriminant.
Bounds_Type : Entity_Id;
-- The type from which are derived the bounds of the values
-- covered by the discrete choices (see 3.8.1 (4)). If a discrete
-- choice specifies a value outside of these bounds we have an error.
Bounds_Lo : Uint;
Bounds_Hi : Uint;
-- The actual bounds of the above type.
Expected_Type : Entity_Id;
-- The expected type of each choice. Equal to Choice_Type, except
-- if the expression is universal, in which case the choices can
-- be of any integer type.
Alt : Node_Id;
-- A case statement alternative or a variant in a record type
-- declaration
Choice : Node_Id;
Kind : Node_Kind;
-- The node kind of the current Choice
Others_Choice : Node_Id := Empty;
-- Remember others choice if it is present (empty otherwise)
procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
-- Checks the validity of the bounds of a choice. When the bounds
-- are static and no error occurred the bounds are entered into
-- the choices table so that they can be sorted later on.
-----------
-- Check --
-----------
procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
Lo_Val : Uint;
Hi_Val : Uint;
begin
-- First check if an error was already detected on either bounds
if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
return;
-- Do not insert non static choices in the table to be sorted
elsif not Is_Static_Expression (Lo)
or else not Is_Static_Expression (Hi)
then
Process_Non_Static_Choice (Choice);
return;
-- Ignore range which raise constraint error
elsif Raises_Constraint_Error (Lo)
or else Raises_Constraint_Error (Hi)
then
Raises_CE := True;
return;
-- Otherwise we have an OK static choice
else
Lo_Val := Expr_Value (Lo);
Hi_Val := Expr_Value (Hi);
-- Do not insert null ranges in the choices table
if Lo_Val > Hi_Val then
Process_Empty_Choice (Choice);
return;
end if;
end if;
-- Check for low bound out of range
if Lo_Val < Bounds_Lo then
-- If the choice is an entity name, then it is a type, and
-- we want to post the message on the reference to this
-- entity. Otherwise we want to post it on the lower bound
-- of the range.
if Is_Entity_Name (Choice) then
Enode := Choice;
else
Enode := Lo;
end if;
-- Specialize message for integer/enum type
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Bounds_Lo;
Error_Msg_N ("minimum allowed choice value is^", Enode);
else
Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
Error_Msg_N ("minimum allowed choice value is%", Enode);
end if;
end if;
-- Check for high bound out of range
if Hi_Val > Bounds_Hi then
-- If the choice is an entity name, then it is a type, and
-- we want to post the message on the reference to this
-- entity. Otherwise we want to post it on the upper bound
-- of the range.
if Is_Entity_Name (Choice) then
Enode := Choice;
else
Enode := Hi;
end if;
-- Specialize message for integer/enum type
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Bounds_Hi;
Error_Msg_N ("maximum allowed choice value is^", Enode);
else
Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
Error_Msg_N ("maximum allowed choice value is%", Enode);
end if;
end if;
-- Store bounds in the table
-- Note: we still store the bounds, even if they are out of
-- range, since this may prevent unnecessary cascaded errors
-- for values that are covered by such an excessive range.
Last_Choice := Last_Choice + 1;
Sort_Choice_Table (Last_Choice).Lo := Lo;
Sort_Choice_Table (Last_Choice).Hi := Hi;
Sort_Choice_Table (Last_Choice).Node := Choice;
end Check;
-- Start of processing for Analyze_Choices
begin
Last_Choice := 0;
Raises_CE := False;
Others_Present := False;
-- If Subtyp is not a static subtype Ada 95 requires then we use
-- the bounds of its base type to determine the values covered by
-- the discrete choices.
if Is_OK_Static_Subtype (Subtyp) then
Bounds_Type := Subtyp;
else
Bounds_Type := Choice_Type;
end if;
-- Obtain static bounds of type, unless this is a generic formal
-- discrete type for which all choices will be non-static.
if not Is_Generic_Type (Root_Type (Bounds_Type))
or else Ekind (Bounds_Type) /= E_Enumeration_Type
then
Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
end if;
if Choice_Type = Universal_Integer then
Expected_Type := Any_Integer;
else
Expected_Type := Choice_Type;
end if;
-- Now loop through the case alternatives or record variants
Alt := First (Get_Alternatives (N));
while Present (Alt) loop
-- If pragma, just analyze it
if Nkind (Alt) = N_Pragma then
Analyze (Alt);
-- Otherwise check each choice against its base type
else
Choice := First (Get_Choices (Alt));
while Present (Choice) loop
Analyze (Choice);
Kind := Nkind (Choice);
-- Choice is a Range
if Kind = N_Range
or else (Kind = N_Attribute_Reference
and then Attribute_Name (Choice) = Name_Range)
then
Resolve (Choice, Expected_Type);
Check (Choice, Low_Bound (Choice), High_Bound (Choice));
-- Choice is a subtype name
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
if not Covers (Expected_Type, Etype (Choice)) then
Wrong_Type (Choice, Choice_Type);
else
E := Entity (Choice);
if not Is_Static_Subtype (E) then
Process_Non_Static_Choice (Choice);
else
Check
(Choice, Type_Low_Bound (E), Type_High_Bound (E));
end if;
end if;
-- Choice is a subtype indication
elsif Kind = N_Subtype_Indication then
Resolve_Discrete_Subtype_Indication
(Choice, Expected_Type);
if Etype (Choice) /= Any_Type then
declare
C : constant Node_Id := Constraint (Choice);
R : constant Node_Id := Range_Expression (C);
L : constant Node_Id := Low_Bound (R);
H : constant Node_Id := High_Bound (R);
begin
E := Entity (Subtype_Mark (Choice));
if not Is_Static_Subtype (E) then
Process_Non_Static_Choice (Choice);
else
if Is_OK_Static_Expression (L)
and then Is_OK_Static_Expression (H)
then
if Expr_Value (L) > Expr_Value (H) then
Process_Empty_Choice (Choice);
else
if Is_Out_Of_Range (L, E) then
Apply_Compile_Time_Constraint_Error
(L, "static value out of range",
CE_Range_Check_Failed);
end if;
if Is_Out_Of_Range (H, E) then
Apply_Compile_Time_Constraint_Error
(H, "static value out of range",
CE_Range_Check_Failed);
end if;
end if;
end if;
Check (Choice, L, H);
end if;
end;
end if;
-- The others choice is only allowed for the last
-- alternative and as its only choice.
elsif Kind = N_Others_Choice then
if not (Choice = First (Get_Choices (Alt))
and then Choice = Last (Get_Choices (Alt))
and then Alt = Last (Get_Alternatives (N)))
then
Error_Msg_N
("the choice OTHERS must appear alone and last",
Choice);
return;
end if;
Others_Present := True;
Others_Choice := Choice;
-- Only other possibility is an expression
else
Resolve (Choice, Expected_Type);
Check (Choice, Choice, Choice);
end if;
Next (Choice);
end loop;
Process_Associated_Node (Alt);
end if;
Next (Alt);
end loop;
Check_Choices
(Sort_Choice_Table (0 .. Last_Choice),
Bounds_Type,
Others_Present or else (Choice_Type = Universal_Integer),
Sloc (N));
-- Now copy the sorted discrete choices
for J in 1 .. Last_Choice loop
Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
end loop;
-- If no others choice we are all done, otherwise we have one more
-- step, which is to set the Others_Discrete_Choices field of the
-- others choice (to contain all otherwise unspecified choices).
-- Skip this if CE is known to be raised.
if Others_Present and not Raises_CE then
Expand_Others_Choice
(Case_Table => Choice_Table (1 .. Last_Choice),
Others_Choice => Others_Choice,
Choice_Type => Bounds_Type);
end if;
end Analyze_Choices;
-----------------------
-- Number_Of_Choices --
-----------------------
function Number_Of_Choices (N : Node_Id) return Nat is
Alt : Node_Id;
-- A case statement alternative or a record variant
Choice : Node_Id;
Count : Nat := 0;
begin
if not Present (Get_Alternatives (N)) then
return 0;
end if;
Alt := First_Non_Pragma (Get_Alternatives (N));
while Present (Alt) loop
Choice := First (Get_Choices (Alt));
while Present (Choice) loop
if Nkind (Choice) /= N_Others_Choice then
Count := Count + 1;
end if;
Next (Choice);
end loop;
Next_Non_Pragma (Alt);
end loop;
return Count;
end Number_Of_Choices;
end Generic_Choices_Processing;
end Sem_Case;
Reference in New Issue View Git Blame Copy Permalink