OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

a-except-2005.adb (Rmsg_18): New message text.

Browse Source 
2010-10-22  Robert Dewar  <dewar@adacore.com>

	* a-except-2005.adb (Rmsg_18): New message text.
	* a-except.adb (Rmsg_18): New message text.
	* atree.adb (List25): New function
	(Set_List25): New procedure
	* atree.ads (List25): New function
	(Set_List25): New procedure
	* einfo.adb (Static_Predicate): Is now a list
	(OK_To_Reference): Present in all entities
	* einfo.ads (Static_Predicate): Is now a list
	(OK_To_Reference): Applies to all entities
	* exp_ch13.adb (Build_Predicate_Function): Moved to Sem_Ch13
	* sem_attr.adb (Bad_Attribute_For_Predicate): Call
	Bad_Predicated_Subtype_Use.
	* sem_case.ads, sem_case.adb: Major surgery to deal with predicated
	subtype case.
	* sem_ch13.adb (Build_Predicate_Function): Moved from Exp_Ch13 to
	Sem_Ch13.
	(Build_Static_Predicate): New procedure handles static predicates.
	* sem_ch3.adb (Analyze_Subtype_Declaration): Delay freeze on subtype
	with no constraint if ancestor subtype has predicates.
	(Analyze_Variant_Part): New calling sequence for Analyze_Choices
	* sem_ch4.adb (Junk_Operand): Don't complain about OK_To_Reference
	entity.
	(Analyze_Case_Expression): New calling sequence for Analyze_Choices
	* sem_ch5.adb (Analyze_Case_Statement): New calling sequence for
	Analyze_Choices.
	* sem_util.ads, sem_util.adb (Bad_Predicated_Subtype_Use): New procedure
	* types.ads (PE_Bad_Predicated_Generic_Type): Replaces
	PE_Bad_Attribute_For_Predicate.
	* atree.h: Add definition of List25.

From-SVN: r165828
This commit is contained in:
Robert Dewar 2010-10-22 13:58:49 +00:00 committed by Arnaud Charlet
parent 497b37aded
commit 86200f6646
19 changed files with 917 additions and 515 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/ada/ChangeLog
View File

@ -1,3 +1,36 @@
2010-10-22 Robert Dewar <dewar@adacore.com>
* a-except-2005.adb (Rmsg_18): New message text.
* a-except.adb (Rmsg_18): New message text.
* atree.adb (List25): New function
(Set_List25): New procedure
* atree.ads (List25): New function
(Set_List25): New procedure
* einfo.adb (Static_Predicate): Is now a list
(OK_To_Reference): Present in all entities
* einfo.ads (Static_Predicate): Is now a list
(OK_To_Reference): Applies to all entities
* exp_ch13.adb (Build_Predicate_Function): Moved to Sem_Ch13
* sem_attr.adb (Bad_Attribute_For_Predicate): Call
Bad_Predicated_Subtype_Use.
* sem_case.ads, sem_case.adb: Major surgery to deal with predicated
subtype case.
* sem_ch13.adb (Build_Predicate_Function): Moved from Exp_Ch13 to
Sem_Ch13.
(Build_Static_Predicate): New procedure handles static predicates.
* sem_ch3.adb (Analyze_Subtype_Declaration): Delay freeze on subtype
with no constraint if ancestor subtype has predicates.
(Analyze_Variant_Part): New calling sequence for Analyze_Choices
* sem_ch4.adb (Junk_Operand): Don't complain about OK_To_Reference
entity.
(Analyze_Case_Expression): New calling sequence for Analyze_Choices
* sem_ch5.adb (Analyze_Case_Statement): New calling sequence for
Analyze_Choices.
* sem_util.ads, sem_util.adb (Bad_Predicated_Subtype_Use): New procedure
* types.ads (PE_Bad_Predicated_Generic_Type): Replaces
PE_Bad_Attribute_For_Predicate.
* atree.h: Add definition of List25.
2010-10-22 Jerome Lambourg <lambourg@adacore.com>
* gnatlink.adb (Process_Binder_File): Remove CLI-specific code, now

4
gcc/ada/a-except-2005.adb
View File

@ -588,8 +588,8 @@ package body Ada.Exceptions is
Rmsg_16 : constant String := "attempt to take address of" &
" intrinsic subprogram" & NUL;
Rmsg_17 : constant String := "all guards closed" & NUL;
Rmsg_18 : constant String := "attribute not allowed for " &
" generic subtype with predicate" & NUL;
Rmsg_18 : constant String := "improper use of generic subtype" &
" with predicate" & NUL;
Rmsg_19 : constant String := "Current_Task referenced in entry" &
" body" & NUL;
Rmsg_20 : constant String := "duplicated entry address" & NUL;

4
gcc/ada/a-except.adb
View File

@ -520,8 +520,8 @@ package body Ada.Exceptions is
Rmsg_16 : constant String := "attempt to take address of" &
" intrinsic subprogram" & NUL;
Rmsg_17 : constant String := "all guards closed" & NUL;
Rmsg_18 : constant String := "attribute not allowed for " &
" generic subtype with predicate" & NUL;
Rmsg_18 : constant String := "improper use of generic subtype" &
" with predicate" & NUL;
Rmsg_19 : constant String := "Current_Task referenced in entry" &
" body" & NUL;
Rmsg_20 : constant String := "duplicated entry address" & NUL;

12
gcc/ada/atree.adb
View File

@ -2400,6 +2400,12 @@ package body Atree is
return List_Id (Nodes.Table (N + 2).Field7);
end List14;
function List25 (N : Node_Id) return List_Id is
begin
pragma Assert (Nkind (N) in N_Entity);
return List_Id (Nodes.Table (N + 4).Field7);
end List25;
function Elist1 (N : Node_Id) return Elist_Id is
pragma Assert (N <= Nodes.Last);
Value : constant Union_Id := Nodes.Table (N).Field1;
@ -4657,6 +4663,12 @@ package body Atree is
Nodes.Table (N + 2).Field7 := Union_Id (Val);
end Set_List14;
procedure Set_List25 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field7 := Union_Id (Val);
end Set_List25;
procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is
begin
Nodes.Table (N).Field1 := Union_Id (Val);

6
gcc/ada/atree.ads
View File

@ -1096,6 +1096,9 @@ package Atree is
function List14 (N : Node_Id) return List_Id;
pragma Inline (List14);
function List25 (N : Node_Id) return List_Id;
pragma Inline (List25);
function Elist1 (N : Node_Id) return Elist_Id;
pragma Inline (Elist1);
@ -2159,6 +2162,9 @@ package Atree is
procedure Set_List14 (N : Node_Id; Val : List_Id);
pragma Inline (Set_List14);
procedure Set_List25 (N : Node_Id; Val : List_Id);
pragma Inline (Set_List25);
procedure Set_Elist1 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist1);

1
gcc/ada/atree.h
View File

@ -421,6 +421,7 @@ extern Node_Id Current_Error_Node;
#define List5(N) Field5 (N)
#define List10(N) Field10 (N)
#define List14(N) Field14 (N)
#define List25(N) Field25 (N)
#define Elist1(N) Field1 (N)
#define Elist2(N) Field2 (N)

12
gcc/ada/einfo.adb
View File

@ -215,7 +215,7 @@ package body Einfo is
-- Debug_Renaming_Link Node25
-- DT_Offset_To_Top_Func Node25
-- PPC_Wrapper Node25
-- Static_Predicate Node25
-- Static_Predicate List25
-- Task_Body_Procedure Node25
-- Dispatch_Table_Wrappers Elist26
@ -2316,7 +2316,6 @@ package body Einfo is
function OK_To_Reference (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag249 (Id);
end OK_To_Reference;
@ -2621,10 +2620,10 @@ package body Einfo is
return Node24 (Id);
end Spec_PPC_List;
function Static_Predicate (Id : E) return N is
function Static_Predicate (Id : E) return S is
begin
pragma Assert (Is_Discrete_Type (Id));
return Node25 (Id);
return List25 (Id);
end Static_Predicate;
function Storage_Size_Variable (Id : E) return E is
@ -4811,7 +4810,6 @@ package body Einfo is
procedure Set_OK_To_Reference (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag249 (Id, V);
end Set_OK_To_Reference;
@ -5127,14 +5125,14 @@ package body Einfo is
Set_Node24 (Id, V);
end Set_Spec_PPC_List;
procedure Set_Static_Predicate (Id : E; V : N) is
procedure Set_Static_Predicate (Id : E; V : S) is
begin
pragma Assert
(Ekind_In (Id, E_Enumeration_Subtype,
E_Modular_Integer_Subtype,
E_Signed_Integer_Subtype)
and then Has_Predicates (Id));
Set_Node25 (Id, V);
Set_List25 (Id, V);
end Set_Static_Predicate;
procedure Set_Storage_Size_Variable (Id : E; V : E) is

31
gcc/ada/einfo.ads
View File

@ -3152,10 +3152,10 @@ package Einfo is
-- formals as a value of type Pos.
-- OK_To_Reference (Flag249)
-- Present in all entities for types and subtypes. If set it indicates
-- that a naked reference to the type is permitted within an expression
-- that is being analyzed or preanalyed (for example, a type name may
-- be referenced within the Invariant aspect expression for the type).
-- Present in all entities. If set it indicates that a naked reference to
-- the entity is permitted within an expression that is being preanalyzed
-- (for example, a type name may be referenced within the Invariant
-- or Predicate aspect expression for a type).
-- OK_To_Rename (Flag247)
-- Present only in entities for variables. If this flag is set, it
@ -3609,11 +3609,14 @@ package Einfo is
-- textual appearance. Note that this includes precondition/postcondition
-- pragmas generated to correspond to Pre/Post aspects.
-- Static_Predicate (Node25)
-- Static_Predicate (List25)
-- Present in discrete types/subtypes with predicates (Has_Predicates
-- set True). Set for a subtype that has a predicate that is considered
-- static. Points to the fully analyzed predicate expression, which is
-- always a membership test (possibly a set membership).
-- set True). Points to a list of expression and N_Range nodes that
-- represent the predicate in canonical form. The canonical form has
-- entries sorted in ascending order, with all duplicates eliminated,
-- and adjacent ranges coalesced, so that there is always a gap in the
-- values between successive entries. The entries in this list are
-- fully analyzed.
-- Storage_Size_Variable (Node15) [implementation base type only]
-- Present in access types and task type entities. This flag is set
@ -4735,6 +4738,7 @@ package Einfo is
-- Needs_Debug_Info (Flag147)
-- Never_Set_In_Source (Flag115)
-- No_Return (Flag113)
-- OK_To_Reference (Flag249)
-- Overlays_Constant (Flag243)
-- Referenced (Flag156)
-- Referenced_As_LHS (Flag36)
@ -4817,7 +4821,6 @@ package Einfo is
-- Known_To_Have_Preelab_Init (Flag207)
-- Must_Be_On_Byte_Boundary (Flag183)
-- Must_Have_Preelab_Init (Flag208)
-- OK_To_Reference (Flag249)
-- Optimize_Alignment_Space (Flag241)
-- Optimize_Alignment_Time (Flag242)
-- Size_Depends_On_Discriminant (Flag177)
@ -5073,7 +5076,7 @@ package Einfo is
-- First_Literal (Node17)
-- Scalar_Range (Node20)
-- Enum_Pos_To_Rep (Node23) (type only)
-- Static_Predicate (Node25)
-- Static_Predicate (List25)
-- Has_Biased_Representation (Flag139)
-- Has_Contiguous_Rep (Flag181)
-- Has_Enumeration_Rep_Clause (Flag66)
@ -5275,7 +5278,7 @@ package Einfo is
-- Modulus (Uint17) (base type only)
-- Original_Array_Type (Node21)
-- Scalar_Range (Node20)
-- Static_Predicate (Node25)
-- Static_Predicate (List25)
-- Non_Binary_Modulus (Flag58) (base type only)
-- Has_Biased_Representation (Flag139)
-- Type_Low_Bound (synth)
@ -5545,7 +5548,7 @@ package Einfo is
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- Scalar_Range (Node20)
-- Static_Predicate (Node25)
-- Static_Predicate (List25)
-- Has_Biased_Representation (Flag139)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
@ -6241,7 +6244,7 @@ package Einfo is
function Small_Value (Id : E) return R;
function Spec_Entity (Id : E) return E;
function Spec_PPC_List (Id : E) return N;
function Static_Predicate (Id : E) return N;
function Static_Predicate (Id : E) return S;
function Storage_Size_Variable (Id : E) return E;
function Static_Elaboration_Desired (Id : E) return B;
function Static_Initialization (Id : E) return N;
@ -6829,7 +6832,7 @@ package Einfo is
procedure Set_Small_Value (Id : E; V : R);
procedure Set_Spec_Entity (Id : E; V : E);
procedure Set_Spec_PPC_List (Id : E; V : N);
procedure Set_Static_Predicate (Id : E; V : N);
procedure Set_Static_Predicate (Id : E; V : S);
procedure Set_Storage_Size_Variable (Id : E; V : E);
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
procedure Set_Static_Initialization (Id : E; V : N);

329
gcc/ada/exp_ch13.adb
View File

@ -26,8 +26,6 @@
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
@ -39,8 +37,6 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
@ -54,313 +50,6 @@ with Validsw; use Validsw;
package body Exp_Ch13 is
-----------------------
-- Local Subprograms --
-----------------------
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
FBody : out Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
-- then either there are pragma Invariant entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragam Predicate), or
-- there are inherited aspects from a parent type, or ancestor subtypes,
-- or interfaces. This procedure builds the spec and body for the Predicate
-- function that tests these predicates, returning them in PDecl and Pbody
-- and setting Predicate_Procedure for Typ. In some error situations no
-- procedure is built, in which case PDecl/PBody are empty on return.
------------------------------
-- Build_Predicate_Function --
------------------------------
-- The procedure that is constructed here has the form
-- function typPredicate (Ixxx : typ) return Boolean is
-- begin
-- return
-- exp1 and then exp2 and then ...
-- and then typ1Predicate (typ1 (Ixxx))
-- and then typ2Predicate (typ2 (Ixxx))
-- and then ...;
-- end typPredicate;
-- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
-- this is the point at which these expressions get analyzed, providing the
-- required delay, and typ1, typ2, are entities from which predicates are
-- inherited. Note that we do NOT generate Check pragmas, that's because we
-- use this function even if checks are off, e.g. for membership tests.
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
FBody : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Typ);
Spec : Node_Id;
SId : Entity_Id;
Expr : Node_Id;
-- This is the expression for the return statement in the function. It
-- is build by connecting the component predicates with AND THEN.
procedure Add_Call (T : Entity_Id);
-- Includes a call to the predicate function for type T in Expr if T
-- has predicates and Predicate_Function (T) is non-empty.
procedure Add_Predicates;
-- Appends expressions for any Predicate pragmas in the rep item chain
-- Typ to Expr. Note that we look only at items for this exact entity.
-- Inheritance of predicates for the parent type is done by calling the
-- Predicate_Function of the parent type, using Add_Call above.
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of Predicate procedure
--------------
-- Add_Call --
--------------
procedure Add_Call (T : Entity_Id) is
Exp : Node_Id;
begin
if Present (T) and then Present (Predicate_Function (T)) then
Set_Has_Predicates (Typ);
-- Build the call to the predicate function of T
Exp :=
Make_Predicate_Call
(T,
Convert_To (T,
Make_Identifier (Loc, Chars => Object_Name)));
-- Add call to evolving expression, using AND THEN if needed
if No (Expr) then
Expr := Exp;
else
Expr :=
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (Expr),
Right_Opnd => Exp);
end if;
-- Output info message on inheritance if required
if Opt.List_Inherited_Aspects then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
Error_Msg_N ("?info: & inherits predicate from & #", Typ);
end if;
end if;
end Add_Call;
--------------------
-- Add_Predicates --
--------------------
procedure Add_Predicates is
Ritem : Node_Id;
Arg1 : Node_Id;
Arg2 : Node_Id;
function Replace_Node (N : Node_Id) return Traverse_Result;
-- Process single node for traversal to replace type references
procedure Replace_Type is new Traverse_Proc (Replace_Node);
-- Traverse an expression changing every occurrence of an entity
-- reference to type T with a reference to the object argument.
------------------
-- Replace_Node --
------------------
function Replace_Node (N : Node_Id) return Traverse_Result is
begin
-- Case of entity name referencing the type
if Is_Entity_Name (N) and then Entity (N) = Typ then
-- Replace with object
Rewrite (N,
Make_Identifier (Loc,
Chars => Object_Name));
-- All done with this node
return Skip;
-- Not an occurrence of the type entity, keep going
else
return OK;
end if;
end Replace_Node;
-- Start of processing for Add_Predicates
begin
Ritem := First_Rep_Item (Typ);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
then
Arg1 := First (Pragma_Argument_Associations (Ritem));
Arg2 := Next (Arg1);
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
-- See if this predicate pragma is for the current type
if Entity (Arg1) = Typ then
-- We have a match, this entry is for our subtype
-- First We need to replace any occurrences of the name of
-- the type with references to the object. We do this by
-- first doing a preanalysis, to identify all the entities,
-- then we traverse looking for the type entity, doing the
-- needed substitution. The preanalysis is done with the
-- special OK_To_Reference flag set on the type, so that if
-- we get an occurrence of this type, it will be recognized
-- as legitimate.
Set_OK_To_Reference (Typ, True);
Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
Set_OK_To_Reference (Typ, False);
Replace_Type (Arg2);
-- OK, replacement complete, now we can add the expression
if No (Expr) then
Expr := Relocate_Node (Arg2);
else
Expr :=
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (Expr),
Right_Opnd => Relocate_Node (Arg2));
end if;
end if;
end if;
Next_Rep_Item (Ritem);
end loop;
end Add_Predicates;
-- Start of processing for Build_Predicate_Function
begin
-- Initialize for construction of statement list
Expr := Empty;
FDecl := Empty;
FBody := Empty;
-- Return if already built or if type does not have predicates
if not Has_Predicates (Typ)
or else Present (Predicate_Function (Typ))
then
return;
end if;
-- Add Predicates for the current type
Add_Predicates;
-- Add predicates for ancestor if present
declare
Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
begin
if Present (Atyp) then
Add_Call (Atyp);
end if;
end;
-- Add predicates of any interfaces of a tagged type
if Is_Tagged_Type (Typ) then
declare
Iface_List : Elist_Id;
Elmt : Elmt_Id;
begin
Collect_Interfaces (Typ, Iface_List);
if Present (Iface_List) then
loop
Elmt := First_Elmt (Iface_List);
exit when No (Elmt);
Add_Call (Node (Elmt));
Remove_Elmt (Iface_List, Elmt);
end loop;
end if;
end;
end if;
if Present (Expr) then
-- Build function declaration
pragma Assert (Has_Predicates (Typ));
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
Set_Has_Predicates (SId);
Set_Predicate_Function (Typ, SId);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => SId,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars => Object_Name),
Parameter_Type => New_Occurrence_Of (Typ, Loc))),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
FDecl :=
Make_Subprogram_Declaration (Loc,
Specification => Spec);
-- Build function body
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => SId,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars => Object_Name),
Parameter_Type =>
New_Occurrence_Of (Typ, Loc))),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
FBody :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => Expr))));
end if;
end Build_Predicate_Function;
------------------------------------------
-- Expand_N_Attribute_Definition_Clause --
------------------------------------------
@ -725,24 +414,6 @@ package body Exp_Ch13 is
Rewrite (N, Make_Null_Statement (Sloc (N)));
end if;
-- If freezing a type entity which has predicates, this is where we
-- build and insert the predicate function for the type.
if Is_Type (E) and then Has_Predicates (E) then
declare
FDecl : Node_Id;
FBody : Node_Id;
begin
Build_Predicate_Function (E, FDecl, FBody);
if Present (FDecl) then
Insert_After (N, FBody);
Insert_After (N, FDecl);
end if;
end;
end if;
-- Pop scope if we installed one for the analysis
if In_Other_Scope then

22
gcc/ada/sem_attr.adb
View File

@ -215,7 +215,8 @@ package body Sem_Attr is
-- Output error message for use of a predicate (First, Last, Range) not
-- allowed with a type that has predicates. If the type is a generic
-- actual, then the message is a warning, and we generate code to raise
-- program error with an appropriate reason.
-- program error with an appropriate reason. No error message is given
-- for internally generated uses of the attributes.
procedure Check_Array_Or_Scalar_Type;
-- Common procedure used by First, Last, Range attribute to check
@ -838,23 +839,10 @@ package body Sem_Attr is
procedure Bad_Attribute_For_Predicate is
begin
if Has_Predicates (P_Type) then
if Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
if Is_Generic_Actual_Type (P_Type) then
Error_Msg_F
("type& has predicates, attribute % not allowed?", P);
Error_Msg_F
("\?Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Bad_Attribute_For_Predicate));
else
Error_Msg_F
("type& has predicates, attribute % not allowed", P);
Error_Attr;
end if;
Bad_Predicated_Subtype_Use
(P_Type, N, "type& has predicates, attribute % not allowed");
end if;
end Bad_Attribute_For_Predicate;

233
gcc/ada/sem_case.adb
View File

@ -32,7 +32,6 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@ -43,23 +42,31 @@ with Sinfo; use Sinfo;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Ada.Unchecked_Deallocation;
with GNAT.Heap_Sort_G;
package body Sem_Case is
type Choice_Bounds is record
Lo : Node_Id;
Hi : Node_Id;
Node : Node_Id;
end record;
-- Represent one choice bounds entry with Lo and Hi values, Node points
-- to the choice node itself.
type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
-- Table type used to sort the choices present in a case statement, array
-- aggregate or record variant. The actual entries are stored in 1 .. Last,
-- but we have a 0 entry for convenience in sorting.
-----------------------
-- 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 algorithm
-- (this is not absolutely necessary but it makes the code more
-- efficient).
procedure Check_Choices
(Choice_Table : in out Sort_Choice_Table_Type;
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
Others_Present : Boolean;
@ -101,7 +108,7 @@ package body Sem_Case is
-------------------
procedure Check_Choices
(Choice_Table : in out Sort_Choice_Table_Type;
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
Others_Present : Boolean;
@ -321,7 +328,9 @@ package body Sem_Case is
Issue_Msg (Prev_Hi + 1, Lo - 1);
end if;
Prev_Hi := Hi;
if Hi > Prev_Hi then
Prev_Hi := Hi;
end if;
end loop;
if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
@ -511,7 +520,7 @@ package body Sem_Case is
-- Start of processing for Expand_Others_Choice
begin
if Case_Table'Length = 0 then
if Case_Table'Last = 0 then
-- Special case: only an others case is present.
-- The others case covers the full range of the type.
@ -537,9 +546,9 @@ package body Sem_Case is
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);
Lo := Expr_Value (Case_Table (1).Lo);
Hi := Expr_Value (Case_Table (1).Hi);
Previous_Hi := Expr_Value (Case_Table (1).Hi);
-- Build the node for any missing choices that are smaller than any
-- explicit choices given in the case.
@ -551,7 +560,7 @@ package body Sem_Case is
-- 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
for J in 2 .. Case_Table'Last loop
Lo := Expr_Value (Case_Table (J).Lo);
Hi := Expr_Value (Case_Table (J).Hi);
@ -588,7 +597,6 @@ package body Sem_Case is
procedure No_OP (C : Node_Id) is
pragma Warnings (Off, C);
begin
null;
end No_OP;
@ -599,6 +607,19 @@ package body Sem_Case is
package body Generic_Choices_Processing is
-- The following type is used to gather the entries for the choice
-- table, so that we can then allocate the right length.
type Link;
type Link_Ptr is access all Link;
type Link is record
Val : Choice_Bounds;
Nxt : Link_Ptr;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
---------------------
-- Analyze_Choices --
---------------------
@ -606,20 +627,19 @@ package body Sem_Case is
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
pragma Assert (Choice_Table'First = 1);
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_List : Link_Ptr := null;
-- Gather list of choices
Num_Choices : Nat := 0;
-- Number of entries in Choice_List
Choice_Type : constant Entity_Id := Base_Type (Subtyp);
-- The actual type against which the discrete choices are resolved.
@ -648,13 +668,17 @@ package body Sem_Case is
Kind : Node_Kind;
-- The node kind of the current Choice
Delete_Choice : Boolean;
-- Set to True to delete 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.
-- are static and no error occurred the bounds are collected for
-- later entry into the choices table so that they can be sorted
-- later on.
-----------
-- Check --
@ -706,8 +730,7 @@ package body Sem_Case is
-- 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.
-- Otherwise post it on the lower bound of the range.
if Is_Entity_Name (Choice) then
Enode := Choice;
@ -751,22 +774,20 @@ package body Sem_Case is
end if;
end if;
-- Store bounds in the table
-- Collect bounds in the list
-- 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;
Choice_List :=
new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
Num_Choices := Num_Choices + 1;
end Check;
-- Start of processing for Analyze_Choices
begin
Last_Choice := 0;
Raises_CE := False;
Others_Present := False;
@ -811,6 +832,7 @@ package body Sem_Case is
else
Choice := First (Get_Choices (Alt));
while Present (Choice) loop
Delete_Choice := False;
Analyze (Choice);
Kind := Nkind (Choice);
@ -834,7 +856,45 @@ package body Sem_Case is
else
E := Entity (Choice);
if not Is_Static_Subtype (E) then
-- Case of predicated subtype
if Has_Predicates (E) then
-- Use of non-static predicate is an error
if not Is_Discrete_Type (E)
or else No (Static_Predicate (E))
then
Bad_Predicated_Subtype_Use
(E, N,
"cannot use subtype& with non-static "
& "predicate as case alternative");
-- Static predicate case
else
declare
Copy : constant List_Id := Empty_List;
P : Node_Id;
C : Node_Id;
begin
P := First (Static_Predicate (E));
while Present (P) loop
C := New_Copy (P);
Set_Sloc (C, Sloc (Choice));
Append_To (Copy, C);
Next (P);
end loop;
Insert_List_After (Choice, Copy);
Delete_Choice := True;
end;
end if;
-- Not predicated subtype case
elsif not Is_Static_Subtype (E) then
Process_Non_Static_Choice (Choice);
else
Check
@ -848,6 +908,8 @@ package body Sem_Case is
Resolve_Discrete_Subtype_Indication
(Choice, Expected_Type);
-- Here for other than predicated subtype case
if Etype (Choice) /= Any_Type then
declare
C : constant Node_Id := Constraint (Choice);
@ -911,7 +973,18 @@ package body Sem_Case is
Check (Choice, Choice, Choice);
end if;
Next (Choice);
-- Move to next choice, deleting the current one if the
-- flag requesting this deletion is set True.
declare
C : constant Node_Id := Choice;
begin
Next (Choice);
if Delete_Choice then
Remove (C);
end if;
end;
end loop;
Process_Associated_Node (Alt);
@ -920,66 +993,48 @@ package body Sem_Case is
Next (Alt);
end loop;
Check_Choices
(Sort_Choice_Table (0 .. Last_Choice),
Bounds_Type,
Subtyp,
Others_Present or else (Choice_Type = Universal_Integer),
N);
-- Now we can create the Choice_Table, since we know how long
-- it needs to be so we can allocate exactly the right length.
-- Now copy the sorted discrete choices
declare
Choice_Table : Choice_Table_Type (0 .. Num_Choices);
for J in 1 .. Last_Choice loop
Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
end loop;
begin
-- Now copy the items we collected in the linked list into this
-- newly allocated table (leave entry 0 unused for sorting).
-- 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.
declare
T : Link_Ptr;
begin
for J in 1 .. Num_Choices loop
T := Choice_List;
Choice_List := T.Nxt;
Choice_Table (J) := T.Val;
Free (T);
end loop;
end;
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;
Check_Choices
(Choice_Table,
Bounds_Type,
Subtyp,
Others_Present or else (Choice_Type = Universal_Integer),
N);
-- 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,
Others_Choice => Others_Choice,
Choice_Type => Bounds_Type);
end if;
end;
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 No (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;

34
gcc/ada/sem_case.ads
View File

@ -34,16 +34,6 @@ with Types; use Types;
package Sem_Case is
type Choice_Bounds is record
Lo : Node_Id;
Hi : Node_Id;
Node : Node_Id;
end record;
type Choice_Table_Type is array (Pos range <>) of Choice_Bounds;
-- Table type used to sort the choices present in a case statement,
-- array aggregate or record variant.
procedure No_OP (C : Node_Id);
-- The no-operation routine. Does absolutely nothing. Can be used
-- in the following generic for the parameter Process_Empty_Choice.
@ -75,16 +65,9 @@ package Sem_Case is
package Generic_Choices_Processing is
function Number_Of_Choices (N : Node_Id) return Nat;
-- Iterates through the choices of N, (N can be a case expression, case
-- statement, array aggregate or record variant), counting all the
-- Choice nodes except for the Others choice.
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);
-- From a case expression, case statement, array aggregate or record
@ -92,23 +75,6 @@ package Sem_Case is
-- choices. Subtyp is the subtype of the discrete choices. The type
-- against which the discrete choices must be resolved is its base type.
--
-- On entry Choice_Table must be big enough to contain all the discrete
-- choices encountered. The lower bound of Choice_Table must be one.
--
-- On exit Choice_Table contains all the static and non empty discrete
-- choices in sorted order. Last_Choice gives the position of the last
-- valid choice in Choice_Table, Choice_Table'First contains the first.
-- We can have Last_Choice < Choice_Table'Last for one (or several) of
-- the following reasons:
--
-- (a) The list of choices contained a non static choice
--
-- (b) The list of choices contained an empty choice
-- (something like "1 .. 0 => ")
--
-- (c) One of the bounds of a discrete choice contains an
-- error or raises constraint error.
--
-- In one of the bounds of a discrete choice raises a constraint
-- error the flag Raise_CE is set.
--

633
gcc/ada/sem_ch13.adb
View File

@ -77,6 +77,23 @@ package body Sem_Ch13 is
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
-----------------------
-- Local Subprograms --
-----------------------
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
FBody : out Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
-- then either there are pragma Invariant entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragam Predicate), or
-- there are inherited aspects from a parent type, or ancestor subtypes,
-- or interfaces. This procedure builds the spec and body for the Predicate
-- function that tests these predicates, returning them in PDecl and Pbody
-- and setting Predicate_Procedure for Typ. In some error situations no
-- procedure is built, in which case PDecl/PBody are empty on return.
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- Uint value. If the value is inappropriate, then error messages are
@ -3038,6 +3055,23 @@ package body Sem_Ch13 is
end if;
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
-- If we have a type with predicates, build predicate function
if Is_Type (E) and then Has_Predicates (E) then
declare
FDecl : Node_Id;
FBody : Node_Id;
begin
Build_Predicate_Function (E, FDecl, FBody);
if Present (FDecl) then
Insert_After (N, FBody);
Insert_After (N, FDecl);
end if;
end;
end if;
end Analyze_Freeze_Entity;
------------------------------------------
@ -3773,6 +3807,605 @@ package body Sem_Ch13 is
end if;
end Build_Invariant_Procedure;
------------------------------
-- Build_Predicate_Function --
------------------------------
-- The procedure that is constructed here has the form
-- function typPredicate (Ixxx : typ) return Boolean is
-- begin
-- return
-- exp1 and then exp2 and then ...
-- and then typ1Predicate (typ1 (Ixxx))
-- and then typ2Predicate (typ2 (Ixxx))
-- and then ...;
-- end typPredicate;
-- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
-- this is the point at which these expressions get analyzed, providing the
-- required delay, and typ1, typ2, are entities from which predicates are
-- inherited. Note that we do NOT generate Check pragmas, that's because we
-- use this function even if checks are off, e.g. for membership tests.
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
FBody : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Typ);
Spec : Node_Id;
SId : Entity_Id;
Expr : Node_Id;
-- This is the expression for the return statement in the function. It
-- is build by connecting the component predicates with AND THEN.
procedure Add_Call (T : Entity_Id);
-- Includes a call to the predicate function for type T in Expr if T
-- has predicates and Predicate_Function (T) is non-empty.
procedure Add_Predicates;
-- Appends expressions for any Predicate pragmas in the rep item chain
-- Typ to Expr. Note that we look only at items for this exact entity.
-- Inheritance of predicates for the parent type is done by calling the
-- Predicate_Function of the parent type, using Add_Call above.
procedure Build_Static_Predicate;
-- This function is called to process a static predicate, and put it in
-- canonical form and store it in Static_Predicate (Typ).
Object_Name : constant Name_Id := New_Internal_Name ('I');
-- Name for argument of Predicate procedure
--------------
-- Add_Call --
--------------
procedure Add_Call (T : Entity_Id) is
Exp : Node_Id;
begin
if Present (T) and then Present (Predicate_Function (T)) then
Set_Has_Predicates (Typ);
-- Build the call to the predicate function of T
Exp :=
Make_Predicate_Call
(T,
Convert_To (T,
Make_Identifier (Loc, Chars => Object_Name)));
-- Add call to evolving expression, using AND THEN if needed
if No (Expr) then
Expr := Exp;
else
Expr :=
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (Expr),
Right_Opnd => Exp);
end if;
-- Output info message on inheritance if required
if Opt.List_Inherited_Aspects then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
Error_Msg_N ("?info: & inherits predicate from & #", Typ);
end if;
end if;
end Add_Call;
--------------------
-- Add_Predicates --
--------------------
procedure Add_Predicates is
Ritem : Node_Id;
Arg1 : Node_Id;
Arg2 : Node_Id;
function Replace_Node (N : Node_Id) return Traverse_Result;
-- Process single node for traversal to replace type references
procedure Replace_Type is new Traverse_Proc (Replace_Node);
-- Traverse an expression changing every occurrence of an entity
-- reference to type T with a reference to the object argument.
------------------
-- Replace_Node --
------------------
function Replace_Node (N : Node_Id) return Traverse_Result is
begin
-- Case of entity name referencing the type
if Is_Entity_Name (N) and then Entity (N) = Typ then
-- Replace with object
Rewrite (N,
Make_Identifier (Loc,
Chars => Object_Name));
-- All done with this node
return Skip;
-- Not an occurrence of the type entity, keep going
else
return OK;
end if;
end Replace_Node;
-- Start of processing for Add_Predicates
begin
Ritem := First_Rep_Item (Typ);
while Present (Ritem) loop
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
then
Arg1 := First (Pragma_Argument_Associations (Ritem));
Arg2 := Next (Arg1);
Arg1 := Get_Pragma_Arg (Arg1);
Arg2 := Get_Pragma_Arg (Arg2);
-- See if this predicate pragma is for the current type
if Entity (Arg1) = Typ then
-- We have a match, this entry is for our subtype
-- First We need to replace any occurrences of the name of
-- the type with references to the object. We do this by
-- first doing a preanalysis, to identify all the entities,
-- then we traverse looking for the type entity, doing the
-- needed substitution. The preanalysis is done with the
-- special OK_To_Reference flag set on the type, so that if
-- we get an occurrence of this type, it will be recognized
-- as legitimate.
Set_OK_To_Reference (Typ, True);
Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
Set_OK_To_Reference (Typ, False);
Replace_Type (Arg2);
-- OK, replacement complete, now we can add the expression
if No (Expr) then
Expr := Relocate_Node (Arg2);
-- There already was a predicate, so add to it
else
Expr :=
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (Expr),
Right_Opnd => Relocate_Node (Arg2));
end if;
end if;
end if;
Next_Rep_Item (Ritem);
end loop;
end Add_Predicates;
----------------------------
-- Build_Static_Predicate --
----------------------------
procedure Build_Static_Predicate is
Exp : Node_Id;
Alt : Node_Id;
Non_Static : Boolean := False;
-- Set True if something non-static is found
Plist : List_Id := No_List;
-- The entries in Plist are either static expressions which represent
-- a possible value, or ranges of values. Subtype marks don't appear,
-- since we expand them out.
Lo, Hi : Uint;
-- Low bound and high bound values of static subtype of Typ
procedure Process_Entry (N : Node_Id);
-- Process one entry (range or value or subtype mark)
-------------------
-- Process_Entry --
-------------------
procedure Process_Entry (N : Node_Id) is
SLo, SHi : Uint;
-- Low and high bounds of range in list
P : Node_Id;
function Build_Val (V : Uint) return Node_Id;
-- Return an analyzed N_Identifier node referencing this value
function Build_Range (Lo, Hi : Uint) return Node_Id;
-- Return an analyzed N_Range node referencing this range
function Lo_Val (N : Node_Id) return Uint;
-- Given static expression or static range, gets expression value
-- or low bound of range.
function Hi_Val (N : Node_Id) return Uint;
-- Given static expression or static range, gets expression value
-- of high bound of range.
-----------------
-- Build_Range --
-----------------
function Build_Range (Lo, Hi : Uint) return Node_Id is
Result : Node_Id;
begin
if Lo = Hi then
return Build_Val (Hi);
else
Result :=
Make_Range (Sloc (N),
Low_Bound => Build_Val (Lo),
High_Bound => Build_Val (Hi));
Set_Etype (Result, Typ);
Set_Analyzed (Result);
return Result;
end if;
end Build_Range;
---------------
-- Build_Val --
---------------
function Build_Val (V : Uint) return Node_Id is
Result : Node_Id;
begin
if Is_Enumeration_Type (Typ) then
Result := Get_Enum_Lit_From_Pos (Typ, V, Sloc (N));
else
Result := Make_Integer_Literal (Sloc (N), Intval => V);
end if;
Set_Etype (Result, Typ);
Set_Is_Static_Expression (Result);
Set_Analyzed (Result);
return Result;
end Build_Val;
------------
-- Hi_Val --
------------
function Hi_Val (N : Node_Id) return Uint is
begin
if Nkind (N) = N_Identifier then
return Expr_Value (N);
else
return Expr_Value (High_Bound (N));
end if;
end Hi_Val;
------------
-- Lo_Val --
------------
function Lo_Val (N : Node_Id) return Uint is
begin
if Nkind (N) = N_Identifier then
return Expr_Value (N);
else
return Expr_Value (Low_Bound (N));
end if;
end Lo_Val;
-- Start of processing for Process_Entry
begin
-- Range case
if Nkind (N) = N_Range then
if not Is_Static_Expression (Low_Bound (N))
or else
not Is_Static_Expression (High_Bound (N))
then
Non_Static := True;
return;
else
SLo := Lo_Val (N);
SHi := Hi_Val (N);
end if;
-- Identifier case
else pragma Assert (Nkind (N) = N_Identifier);
-- Static expression case
if Is_Static_Expression (N) then
SLo := Lo_Val (N);
SHi := Hi_Val (N);
-- Type case
elsif Is_Type (Entity (N)) then
-- If type has static predicates, process them recursively
if Present (Static_Predicate (Entity (N))) then
P := First (Static_Predicate (Entity (N)));
while Present (P) loop
Process_Entry (P);
if Non_Static then
return;
else
Next (P);
end if;
end loop;
return;
-- For static subtype without predicates, get range
elsif Is_Static_Subtype (Entity (N))
and then not Has_Predicates (Entity (N))
then
SLo := Expr_Value (Type_Low_Bound (Entity (N)));
SHi := Expr_Value (Type_High_Bound (Entity (N)));
-- Any other type makes us non-static
else
Non_Static := True;
return;
end if;
-- Any other kind of identifier in predicate (e.g. a non-static
-- expression value) means this is not a static predicate.
else
Non_Static := True;
return;
end if;
end if;
-- Here with SLo and SHi set for (possibly single element) range
-- of entry to insert in Plist. Non-static if out of range.
if SLo < Lo or else SHi > Hi then
Non_Static := True;
return;
end if;
-- If no Plist currently, create it
if No (Plist) then
Plist := New_List (Build_Range (SLo, SHi));
return;
-- Otherwise search Plist for insertion point
else
P := First (Plist);
loop
-- Case of inserting before current entry
if SHi < Lo_Val (P) - 1 then
Insert_Before (P, Build_Range (SLo, SHi));
exit;
-- Case of belongs past current entry
elsif SLo > Hi_Val (P) + 1 then
-- End of list case
if No (Next (P)) then
Append_To (Plist, Build_Range (SLo, SHi));
exit;
-- Else just move to next item on list
else
Next (P);
end if;
-- Case of extending current entyr, and in overlap cases
-- may also eat up entries past this one.
else
declare
New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo);
New_Hi : Uint := UI_Max (Hi_Val (P), SHi);
begin
-- See if there are entries past us that we eat up
while Present (Next (P))
and then Lo_Val (Next (P)) <= New_Hi + 1
loop
New_Hi := Hi_Val (Next (P));
Remove (Next (P));
end loop;
-- We now need to replace the current node P with
-- a new entry New_Lo .. New_Hi.
Insert_After (P, Build_Range (New_Lo, New_Hi));
Remove (P);
exit;
end;
end if;
end loop;
end if;
end Process_Entry;
-- Start of processing for Build_Static_Predicate
begin
-- Immediately non-static if our subtype is non static, or we
-- do not have an appropriate discrete subtype in the first place.
if not Ekind_In (Typ, E_Enumeration_Subtype,
E_Modular_Integer_Subtype,
E_Signed_Integer_Subtype)
or else not Is_Static_Subtype (Typ)
then
return;
end if;
Lo := Expr_Value (Type_Low_Bound (Typ));
Hi := Expr_Value (Type_High_Bound (Typ));
-- Check if we have membership predicate
if Nkind (Expr) = N_In then
Exp := Expr;
-- Allow qualified expression with membership predicate inside
elsif Nkind (Expr) = N_Qualified_Expression
and then Nkind (Expression (Expr)) = N_In
then
Exp := Expression (Expr);
-- Anything else cannot be a static predicate
else
return;
end if;
-- We have a membership operation, so we have a potentially static
-- predicate, collect and canonicalize the entries in the list.
if Present (Right_Opnd (Exp)) then
Process_Entry (Right_Opnd (Exp));
if Non_Static then
return;
end if;
else
Alt := First (Alternatives (Exp));
while Present (Alt) loop
Process_Entry (Alt);
if Non_Static then
return;
end if;
Next (Alt);
end loop;
end if;
-- Processing was successful and all entries were static, so
-- now we can store the result as the predicate list.
Set_Static_Predicate (Typ, Plist);
end Build_Static_Predicate;
-- Start of processing for Build_Predicate_Function
begin
-- Initialize for construction of statement list
Expr := Empty;
FDecl := Empty;
FBody := Empty;
-- Return if already built or if type does not have predicates
if not Has_Predicates (Typ)
or else Present (Predicate_Function (Typ))
then
return;
end if;
-- Add Predicates for the current type
Add_Predicates;
-- Add predicates for ancestor if present
declare
Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
begin
if Present (Atyp) then
Add_Call (Atyp);
end if;
end;
-- If we have predicates, build the function
if Present (Expr) then
-- Deal with static predicate case
Build_Static_Predicate;
-- Build function declaration
pragma Assert (Has_Predicates (Typ));
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
Set_Has_Predicates (SId);
Set_Predicate_Function (Typ, SId);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => SId,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars => Object_Name),
Parameter_Type => New_Occurrence_Of (Typ, Loc))),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
FDecl :=
Make_Subprogram_Declaration (Loc,
Specification => Spec);
-- Build function body
SId :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => SId,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars => Object_Name),
Parameter_Type =>
New_Occurrence_Of (Typ, Loc))),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
FBody :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => Expr))));
end if;
end Build_Predicate_Function;
-----------------------------------
-- Check_Constant_Address_Clause --
-----------------------------------

16
gcc/ada/sem_ch3.adb
View File

@ -3842,7 +3842,14 @@ package body Sem_Ch3 is
Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T));
Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T));
Set_Convention (Id, Convention (T));
Set_Has_Predicates (Id, Has_Predicates (T));
-- If ancestor has predicates then so does the subtype, and in addition
-- we must delay the freeze to properly arrange predicate inheritance.
if Has_Predicates (T) then
Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (Id);
end if;
-- In the case where there is no constraint given in the subtype
-- indication, Process_Subtype just returns the Subtype_Mark, so its
@ -4292,13 +4299,9 @@ package body Sem_Ch3 is
Discr_Name : Node_Id;
Discr_Type : Entity_Id;
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean := False;
pragma Warnings (Off, Case_Table);
pragma Warnings (Off, Last_Choice);
pragma Warnings (Off, Dont_Care);
pragma Warnings (Off, Others_Present);
-- We don't care about the assigned values of any of these
@ -4332,8 +4335,7 @@ package body Sem_Ch3 is
-- Call the instantiated Analyze_Choices which does the rest of the work
Analyze_Choices
(N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present);
end Analyze_Variant_Part;
----------------------------

13
gcc/ada/sem_ch4.adb
View File

@ -1137,7 +1137,6 @@ package body Sem_Ch4 is
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean;
@ -1154,8 +1153,6 @@ package body Sem_Ch4 is
Process_Associated_Node => No_OP);
use Case_Choices_Processing;
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
@ -1252,8 +1249,7 @@ package body Sem_Ch4 is
-- Call instantiated Analyze_Choices which does the rest of the work
Analyze_Choices
(N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N
@ -5563,6 +5559,13 @@ package body Sem_Ch4 is
return False;
end if;
-- If OK_To_Reference is set for the entity, then don't complain, it
-- means we are doing a preanalysis in which such complaints are wrong.
if OK_To_Reference (Entity (Enode)) then
return False;
end if;
-- Now test the entity we got to see if it is a bad case
case Ekind (Entity (Enode)) is

9
gcc/ada/sem_ch5.adb
View File

@ -1018,12 +1018,6 @@ package body Sem_Ch5 is
Analyze_Statements (Statements (Alternative));
end Process_Statements;
-- Table to record choices. Put after subprograms since we make
-- a call to Number_Of_Choices to get the right number of entries.
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
pragma Warnings (Off, Case_Table);
-- Start of processing for Analyze_Case_Statement
begin
@ -1096,8 +1090,7 @@ package body Sem_Ch5 is
-- Call instantiated Analyze_Choices which does the rest of the work
Analyze_Choices
(N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);

24
gcc/ada/sem_util.adb
View File

@ -329,6 +329,30 @@ package body Sem_Util is
end if;
end Apply_Compile_Time_Constraint_Error;
--------------------------------
-- Bad_Predicated_Subtype_Use --
--------------------------------
procedure Bad_Predicated_Subtype_Use
(Typ : Entity_Id;
N : Node_Id;
Msg : String)
is
begin
if Has_Predicates (Typ) then
if Is_Generic_Actual_Type (Typ) then
Error_Msg_F (Msg & '?', Typ);
Error_Msg_F ("\Program_Error will be raised at run time?", Typ);
Insert_Action (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Bad_Predicated_Generic_Type));
else
Error_Msg_F (Msg, Typ);
end if;
end if;
end Bad_Predicated_Subtype_Use;
--------------------------
-- Build_Actual_Subtype --
--------------------------

14
gcc/ada/sem_util.ads
View File

@ -93,6 +93,20 @@ package Sem_Util is
-- not end with a ? (this is used when the caller wants to parameterize
-- whether an error or warning is given.
procedure Bad_Predicated_Subtype_Use
(Typ : Entity_Id;
N : Node_Id;
Msg : String);
-- This is called when Typ, a predicated subtype, is used in a context
-- which does not allow the use of a predicated subtype. Msg will be
-- passed to Error_Msg_F to output an appropriate message. The caller
-- should set up any insertions other than the & for the type itself.
-- Note that if Typ is a generic actual type, then the message will be
-- output as a warning, and a raise Program_Error is inserted using
-- Insert_Action with node N as the insertion point. Node N also supplies
-- the source location for construction of the raise node. If Typ is NOT a
-- type with predicates this call has no effect.
function Build_Actual_Subtype
(T : Entity_Id;
N : Node_Or_Entity_Id) return Node_Id;

2
gcc/ada/types.ads
View File

@ -789,7 +789,7 @@ package Types is
PE_Accessibility_Check_Failed, -- 15
PE_Address_Of_Intrinsic, -- 16
PE_All_Guards_Closed, -- 17
PE_Bad_Attribute_For_Predicate, -- 18
PE_Bad_Predicated_Generic_Type, -- 18
PE_Current_Task_In_Entry_Body, -- 19
PE_Duplicated_Entry_Address, -- 20
PE_Explicit_Raise, -- 21