[multiple changes]
2014-07-18 Robert Dewar <dewar@adacore.com> * sem_ch3.adb, g-memdum.ads, i-cstrea.ads: Minor reformatting. 2014-07-18 Robert Dewar <dewar@adacore.com> * einfo.adb (Has_Static_Predicate): New function. (Set_Has_Static_Predicate): New procedure. * einfo.ads (Has_Static_Predicate): New flag. * sem_ch13.adb (Is_Predicate_Static): New function (Build_Predicate_Functions): Use Is_Predicate_Static to reorganize (Add_Call): Minor change in Sloc of generated expression (Add_Predicates): Remove setting of Static_Pred, no longer used. * sem_ch4.adb (Has_Static_Predicate): Removed this function, replace by use of the entity flag Has_Static_Predicate_Aspect. * sem_eval.adb (Eval_Static_Predicate_Check): Check real case and issue warning that predicate is not checked for now. * sem_eval.ads (Eval_Static_Predicate_Check): Fix comments in spec. * sem_util.adb (Check_Expression_Against_Static_Predicate): Carry out check for any case where there is a static predicate, and output appropriate message. * sinfo.ads: Minor comment corrections. 2014-07-18 Ed Schonberg <schonberg@adacore.com> * exp_ch3.adb (Expand_Freeze_Record_Type): If the type is derived from an untagged private type whose full view is tagged, the type is marked tagged for layout reasons, but it has no dispatch table, so Set_All_DT_Position must not be called. * exp_ch13.adb: If the freeze node is for a type internal to a record declaration, as is the case for a class-wide subtype of a parent component, the relevant scope is the scope of the enclosing record. From-SVN: r212804
This commit is contained in:
parent
3b8481cb9a
commit
ee4eee0a54
|
@ -1,3 +1,38 @@
|
|||
2014-07-18 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* sem_ch3.adb, g-memdum.ads, i-cstrea.ads: Minor reformatting.
|
||||
|
||||
2014-07-18 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* einfo.adb (Has_Static_Predicate): New function.
|
||||
(Set_Has_Static_Predicate): New procedure.
|
||||
* einfo.ads (Has_Static_Predicate): New flag.
|
||||
* sem_ch13.adb (Is_Predicate_Static): New function
|
||||
(Build_Predicate_Functions): Use Is_Predicate_Static to reorganize
|
||||
(Add_Call): Minor change in Sloc of generated expression
|
||||
(Add_Predicates): Remove setting of Static_Pred, no longer used.
|
||||
* sem_ch4.adb (Has_Static_Predicate): Removed this function,
|
||||
replace by use of the entity flag Has_Static_Predicate_Aspect.
|
||||
* sem_eval.adb (Eval_Static_Predicate_Check): Check real case
|
||||
and issue warning that predicate is not checked for now.
|
||||
* sem_eval.ads (Eval_Static_Predicate_Check): Fix comments in
|
||||
spec.
|
||||
* sem_util.adb (Check_Expression_Against_Static_Predicate):
|
||||
Carry out check for any case where there is a static predicate,
|
||||
and output appropriate message.
|
||||
* sinfo.ads: Minor comment corrections.
|
||||
|
||||
2014-07-18 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* exp_ch3.adb (Expand_Freeze_Record_Type): If the type is derived
|
||||
from an untagged private type whose full view is tagged, the type
|
||||
is marked tagged for layout reasons, but it has no dispatch table,
|
||||
so Set_All_DT_Position must not be called.
|
||||
* exp_ch13.adb: If the freeze node is for a type internal to a
|
||||
record declaration, as is the case for a class-wide subtype
|
||||
of a parent component, the relevant scope is the scope of the
|
||||
enclosing record.
|
||||
|
||||
2014-07-18 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* g-memdum.adb, g-memdum.ads: Code clean ups.
|
||||
|
|
|
@ -415,7 +415,7 @@ package body Einfo is
|
|||
-- Has_Aliased_Components Flag135
|
||||
-- No_Strict_Aliasing Flag136
|
||||
-- Is_Machine_Code_Subprogram Flag137
|
||||
-- Is_Packed_Array_Impl_Type Flag138
|
||||
-- Is_Packed_Array_Impl_Type Flag138
|
||||
-- Has_Biased_Representation Flag139
|
||||
-- Has_Complex_Representation Flag140
|
||||
|
||||
|
@ -559,12 +559,12 @@ package body Einfo is
|
|||
-- SPARK_Aux_Pragma_Inherited Flag266
|
||||
-- Has_Shift_Operator Flag267
|
||||
-- Is_Independent Flag268
|
||||
-- Has_Static_Predicate Flag269
|
||||
|
||||
-- (unused) Flag1
|
||||
-- (unused) Flag2
|
||||
-- (unused) Flag3
|
||||
|
||||
-- (unused) Flag269
|
||||
-- (unused) Flag270
|
||||
|
||||
-- (unused) Flag271
|
||||
|
@ -1719,6 +1719,12 @@ package body Einfo is
|
|||
return Flag211 (Id);
|
||||
end Has_Static_Discriminants;
|
||||
|
||||
function Has_Static_Predicate (Id : E) return B is
|
||||
begin
|
||||
pragma Assert (Is_Type (Id));
|
||||
return Flag269 (Id);
|
||||
end Has_Static_Predicate;
|
||||
|
||||
function Has_Static_Predicate_Aspect (Id : E) return B is
|
||||
begin
|
||||
pragma Assert (Is_Type (Id));
|
||||
|
@ -4436,6 +4442,12 @@ package body Einfo is
|
|||
Set_Flag211 (Id, V);
|
||||
end Set_Has_Static_Discriminants;
|
||||
|
||||
procedure Set_Has_Static_Predicate (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Is_Type (Id));
|
||||
Set_Flag269 (Id, V);
|
||||
end Set_Has_Static_Predicate;
|
||||
|
||||
procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Is_Type (Id));
|
||||
|
@ -8243,6 +8255,7 @@ package body Einfo is
|
|||
W ("Has_Specified_Stream_Read", Flag192 (Id));
|
||||
W ("Has_Specified_Stream_Write", Flag193 (Id));
|
||||
W ("Has_Static_Discriminants", Flag211 (Id));
|
||||
W ("Has_Static_Predicate", Flag269 (Id));
|
||||
W ("Has_Static_Predicate_Aspect", Flag259 (Id));
|
||||
W ("Has_Storage_Size_Clause", Flag23 (Id));
|
||||
W ("Has_Stream_Size_Clause", Flag184 (Id));
|
||||
|
@ -8325,7 +8338,7 @@ package body Einfo is
|
|||
W ("Is_Optional_Parameter", Flag134 (Id));
|
||||
W ("Is_Package_Body_Entity", Flag160 (Id));
|
||||
W ("Is_Packed", Flag51 (Id));
|
||||
W ("Is_Packed_Array_Impl_Type", Flag138 (Id));
|
||||
W ("Is_Packed_Array_Impl_Type", Flag138 (Id));
|
||||
W ("Is_Potentially_Use_Visible", Flag9 (Id));
|
||||
W ("Is_Predicate_Function", Flag255 (Id));
|
||||
W ("Is_Predicate_Function_M", Flag256 (Id));
|
||||
|
|
|
@ -1511,11 +1511,18 @@ package Einfo is
|
|||
|
||||
-- Has_Dynamic_Predicate_Aspect (Flag258)
|
||||
-- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect
|
||||
-- applies to the type. Note that we can tell if a dynamic predicate is
|
||||
-- present by looking at Has_Predicates and Static_Predicate, but that
|
||||
-- could have come from a Predicate aspect or pragma, and we need to
|
||||
-- record the difference so that we can use the right set of check
|
||||
-- policies to figure out if the predicate is active.
|
||||
-- was explicitly applied to the type. Generally we treat predicates as
|
||||
-- static if possible, regardless of whether they are specified using
|
||||
-- Predicate, Static_Predicate, or Dynamic_Predicate. And if a predicate
|
||||
-- can be treated as static (i.e. its expression is predicate-static),
|
||||
-- then the flag Has_Static_Predicate will be set True. But there are
|
||||
-- cases where legality is affected by the presence of an explicit
|
||||
-- Dynamic_Predicate aspect. For example, even if a predicate looks
|
||||
-- static, you can't use it in a case statement if there is an explicit
|
||||
-- Dynamic_Predicate aspect specified. So test Has_Static_Predicate if
|
||||
-- you just want to know if the predicate can be evaluated statically,
|
||||
-- but test Has_Dynamic_Predicate_Aspect to enforce legality rules about
|
||||
-- the use of dynamic predicates.
|
||||
|
||||
-- Has_Entries (synthesized)
|
||||
-- Applies to concurrent types. True if any entries are declared
|
||||
|
@ -1870,13 +1877,23 @@ package Einfo is
|
|||
-- case of a variant record, the component list can be trimmed down to
|
||||
-- include only the components corresponding to these discriminants.
|
||||
|
||||
-- Has_Static_Predicate (Flag269)
|
||||
-- Defined in all types and subtypes. Set if the type (which must be
|
||||
-- a discrete, real, or string subtype) has a static predicate, i.e. a
|
||||
-- predicate whose expression is predicate-static. This can result from
|
||||
-- use of a Predicate, Static_Predicate or Dynamic_Predicate aspect. We
|
||||
-- can distinguish these cases by testing Has_Static_Predicate_Aspect
|
||||
-- and Has_Dynamic_Predicate_Aspect. See description of the latter flag
|
||||
-- for further information on dynamic predicates which are also static.
|
||||
|
||||
-- Has_Static_Predicate_Aspect (Flag259)
|
||||
-- Defined in all types and subtypes. Set if a Static_Predicate aspect
|
||||
-- applies to the type. Note that we can tell if a static predicate is
|
||||
-- present by looking at Has_Predicates and Static_Predicate, but that
|
||||
-- could have come from a Predicate aspect or pragma, and we need to
|
||||
-- record the difference so that we can use the right set of check
|
||||
-- policies to figure out if the predicate is active.
|
||||
-- present by looking at Has_Static_Predicate, but this could have come
|
||||
-- from a Predicate aspect or pragma or even from a Dynamic_Predicate
|
||||
-- aspect. When we need to know the difference (e.g. to know what set of
|
||||
-- check policies apply, use this flag and Has_Dynamic_Predicate_Aspect
|
||||
-- to determine which case we have.
|
||||
|
||||
-- Has_Storage_Size_Clause (Flag23) [implementation base type only]
|
||||
-- Defined in task types and access types. It is set if a Storage_Size
|
||||
|
@ -3873,15 +3890,15 @@ package Einfo is
|
|||
-- the corresponding parameter entities in the spec.
|
||||
|
||||
-- Static_Predicate (List25)
|
||||
-- Defined in discrete types/subtypes with predicates (Has_Predicates
|
||||
-- set). Set if the type/subtype has a static predicate. 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 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 and typed with the base
|
||||
-- type of the subtype. Note that all entries are static and have values
|
||||
-- within the subtype range.
|
||||
-- Defined in discrete types/subtypes with static predicates (with the
|
||||
-- two flags Has_Predicates set and Has_Static_Predicate set). Set if the
|
||||
-- type/subtype has a static predicate. 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 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 and typed with the base type of the subtype. Note
|
||||
-- that all entries are static and have values within the subtype range.
|
||||
|
||||
-- Status_Flag_Or_Transient_Decl (Node15)
|
||||
-- Defined in variables and constants. Applies to objects that require
|
||||
|
@ -5188,6 +5205,7 @@ package Einfo is
|
|||
-- Has_Specified_Stream_Output (Flag191)
|
||||
-- Has_Specified_Stream_Read (Flag192)
|
||||
-- Has_Specified_Stream_Write (Flag193)
|
||||
-- Has_Static_Predicate (Flag269)
|
||||
-- Has_Static_Predicate_Aspect (Flag259)
|
||||
-- Has_Task (Flag30) (base type only)
|
||||
-- Has_Unchecked_Union (Flag123) (base type only)
|
||||
|
@ -6540,6 +6558,7 @@ package Einfo is
|
|||
function Has_Specified_Stream_Read (Id : E) return B;
|
||||
function Has_Specified_Stream_Write (Id : E) return B;
|
||||
function Has_Static_Discriminants (Id : E) return B;
|
||||
function Has_Static_Predicate (Id : E) return B;
|
||||
function Has_Static_Predicate_Aspect (Id : E) return B;
|
||||
function Has_Storage_Size_Clause (Id : E) return B;
|
||||
function Has_Stream_Size_Clause (Id : E) return B;
|
||||
|
@ -7166,6 +7185,7 @@ package Einfo is
|
|||
procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True);
|
||||
procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True);
|
||||
procedure Set_Has_Static_Discriminants (Id : E; V : B := True);
|
||||
procedure Set_Has_Static_Predicate (Id : E; V : B := True);
|
||||
procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True);
|
||||
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True);
|
||||
procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True);
|
||||
|
@ -7905,6 +7925,7 @@ package Einfo is
|
|||
pragma Inline (Has_Specified_Stream_Read);
|
||||
pragma Inline (Has_Specified_Stream_Write);
|
||||
pragma Inline (Has_Static_Discriminants);
|
||||
pragma Inline (Has_Static_Predicate);
|
||||
pragma Inline (Has_Static_Predicate_Aspect);
|
||||
pragma Inline (Has_Storage_Size_Clause);
|
||||
pragma Inline (Has_Stream_Size_Clause);
|
||||
|
@ -8378,6 +8399,7 @@ package Einfo is
|
|||
pragma Inline (Set_Has_Specified_Stream_Read);
|
||||
pragma Inline (Set_Has_Specified_Stream_Write);
|
||||
pragma Inline (Set_Has_Static_Discriminants);
|
||||
pragma Inline (Set_Has_Static_Predicate);
|
||||
pragma Inline (Set_Has_Static_Predicate_Aspect);
|
||||
pragma Inline (Set_Has_Storage_Size_Clause);
|
||||
pragma Inline (Set_Has_Stream_Size_Clause);
|
||||
|
|
|
@ -443,6 +443,17 @@ package body Exp_Ch13 is
|
|||
return;
|
||||
end if;
|
||||
|
||||
-- The entity may be a subtype declared for a constrained record
|
||||
-- component, in which case the relevant scope is the scope of
|
||||
-- the record. This happens for class-wide subtypes created for
|
||||
-- a constrained type extension with inherited discriminants.
|
||||
|
||||
if Is_Type (E_Scope)
|
||||
and then Ekind (E_Scope) not in Concurrent_Kind
|
||||
then
|
||||
E_Scope := Scope (E_Scope);
|
||||
end if;
|
||||
|
||||
-- Remember that we are processing a freezing entity and its freezing
|
||||
-- nodes. This flag (non-zero = set) is used to avoid the need of
|
||||
-- climbing through the tree while processing the freezing actions (ie.
|
||||
|
|
|
@ -1356,7 +1356,7 @@ package body Exp_Ch3 is
|
|||
|
||||
elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
|
||||
and then
|
||||
(not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
|
||||
(not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
|
||||
or else
|
||||
not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
|
||||
then
|
||||
|
@ -1620,7 +1620,7 @@ package body Exp_Ch3 is
|
|||
-- to the appropriate formal parameter.
|
||||
|
||||
if Nkind (Arg) = N_Identifier
|
||||
and then Ekind (Entity (Arg)) = E_Discriminant
|
||||
and then Ekind (Entity (Arg)) = E_Discriminant
|
||||
then
|
||||
Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
|
||||
|
||||
|
@ -2042,7 +2042,7 @@ package body Exp_Ch3 is
|
|||
-- Append it to the list
|
||||
|
||||
if Nkind (Arg) = N_Identifier
|
||||
and then Ekind (Entity (Arg)) = E_Discriminant
|
||||
and then Ekind (Entity (Arg)) = E_Discriminant
|
||||
then
|
||||
Append_To (Args,
|
||||
New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
|
||||
|
@ -2530,8 +2530,8 @@ package body Exp_Ch3 is
|
|||
|
||||
Ins_Nod := First (Body_Stmts);
|
||||
while Present (Next (Ins_Nod))
|
||||
and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
|
||||
or else not Is_Init_Proc (Name (Ins_Nod)))
|
||||
and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
|
||||
or else not Is_Init_Proc (Name (Ins_Nod)))
|
||||
loop
|
||||
Next (Ins_Nod);
|
||||
end loop;
|
||||
|
@ -3421,7 +3421,7 @@ package body Exp_Ch3 is
|
|||
return False;
|
||||
|
||||
elsif (Has_Discriminants (Rec_Id)
|
||||
and then not Is_Unchecked_Union (Rec_Id))
|
||||
and then not Is_Unchecked_Union (Rec_Id))
|
||||
or else Is_Tagged_Type (Rec_Id)
|
||||
or else Is_Concurrent_Record_Type (Rec_Id)
|
||||
or else Has_Task (Rec_Id)
|
||||
|
@ -3595,9 +3595,7 @@ package body Exp_Ch3 is
|
|||
Typ : constant Entity_Id := Etype (Comp);
|
||||
|
||||
begin
|
||||
if Is_Array_Type (Typ)
|
||||
and then Is_Itype (Typ)
|
||||
then
|
||||
if Is_Array_Type (Typ) and then Is_Itype (Typ) then
|
||||
Ref := Make_Itype_Reference (Loc);
|
||||
Set_Itype (Ref, Typ);
|
||||
Append_Freeze_Action (Rec_Type, Ref);
|
||||
|
@ -3624,9 +3622,7 @@ package body Exp_Ch3 is
|
|||
-- The aggregate may have been rewritten as a Raise node, in which
|
||||
-- case there are no relevant itypes.
|
||||
|
||||
if Present (Agg)
|
||||
and then Nkind (Agg) = N_Aggregate
|
||||
then
|
||||
if Present (Agg) and then Nkind (Agg) = N_Aggregate then
|
||||
Set_Static_Initialization (Proc_Id, Agg);
|
||||
|
||||
declare
|
||||
|
@ -5045,8 +5041,8 @@ package body Exp_Ch3 is
|
|||
and then Is_Library_Level_Entity (Def_Id)
|
||||
and then Is_Library_Level_Tagged_Type (Base_Typ)
|
||||
and then (Ekind (Base_Typ) = E_Record_Type
|
||||
or else Ekind (Base_Typ) = E_Protected_Type
|
||||
or else Ekind (Base_Typ) = E_Task_Type)
|
||||
or else Ekind (Base_Typ) = E_Protected_Type
|
||||
or else Ekind (Base_Typ) = E_Task_Type)
|
||||
and then not Has_Dispatch_Table (Base_Typ)
|
||||
then
|
||||
declare
|
||||
|
@ -5186,17 +5182,17 @@ package body Exp_Ch3 is
|
|||
|
||||
if Has_Non_Null_Base_Init_Proc (Typ)
|
||||
|
||||
-- Suppress call if No_Initialization set on declaration
|
||||
-- Suppress call if No_Initialization set on declaration
|
||||
|
||||
and then not No_Initialization (N)
|
||||
and then not No_Initialization (N)
|
||||
|
||||
-- Suppress call for special case of value type for VM
|
||||
-- Suppress call for special case of value type for VM
|
||||
|
||||
and then not Is_Value_Type (Typ)
|
||||
and then not Is_Value_Type (Typ)
|
||||
|
||||
-- Suppress call if initialization suppressed for the type
|
||||
-- Suppress call if initialization suppressed for the type
|
||||
|
||||
and then not Initialization_Suppressed (Typ)
|
||||
and then not Initialization_Suppressed (Typ)
|
||||
then
|
||||
-- Return without initializing when No_Default_Initialization
|
||||
-- applies. Note that the actual restriction check occurs later,
|
||||
|
@ -5346,8 +5342,7 @@ package body Exp_Ch3 is
|
|||
|
||||
and then not
|
||||
(Nkind (Obj_Def) = N_Identifier
|
||||
and then
|
||||
Present (Equivalent_Type (Entity (Obj_Def))))
|
||||
and then Present (Equivalent_Type (Entity (Obj_Def))))
|
||||
then
|
||||
pragma Assert (Is_Class_Wide_Type (Typ));
|
||||
|
||||
|
@ -5357,9 +5352,7 @@ package body Exp_Ch3 is
|
|||
-- case, the expansion of the return statement will take care of
|
||||
-- creating the object (via allocator) and initializing it.
|
||||
|
||||
if Is_Return_Object (Def_Id)
|
||||
and then Is_Limited_View (Typ)
|
||||
then
|
||||
if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
|
||||
null;
|
||||
|
||||
elsif Tagged_Type_Expansion then
|
||||
|
@ -5417,24 +5410,23 @@ package body Exp_Ch3 is
|
|||
and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
|
||||
and then (Expr_Typ = Etype (Expr_Typ)
|
||||
or else not
|
||||
Is_Variable_Size_Record (Etype (Expr_Typ)))
|
||||
Is_Variable_Size_Record (Etype (Expr_Typ)))
|
||||
then
|
||||
-- Copy the object
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Obj_Id,
|
||||
Object_Definition =>
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Expr_Typ, Loc),
|
||||
Expression =>
|
||||
Relocate_Node (Expr_N)));
|
||||
Expression => Relocate_Node (Expr_N)));
|
||||
|
||||
-- Statically reference the tag associated with the
|
||||
-- interface
|
||||
|
||||
Tag_Comp :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Occurrence_Of (Obj_Id, Loc),
|
||||
Prefix => New_Occurrence_Of (Obj_Id, Loc),
|
||||
Selector_Name =>
|
||||
New_Occurrence_Of
|
||||
(Find_Interface_Tag (Expr_Typ, Iface), Loc));
|
||||
|
@ -5747,10 +5739,10 @@ package body Exp_Ch3 is
|
|||
-- is too much trouble ???
|
||||
|
||||
if (Is_Possibly_Unaligned_Slice (Expr)
|
||||
or else (Is_Possibly_Unaligned_Object (Expr)
|
||||
and then not Represented_As_Scalar (Etype (Expr))))
|
||||
or else (Is_Possibly_Unaligned_Object (Expr)
|
||||
and then not Represented_As_Scalar (Etype (Expr))))
|
||||
and then not (Is_Array_Type (Etype (Expr))
|
||||
and then not Is_Constrained (Etype (Expr)))
|
||||
and then not Is_Constrained (Etype (Expr)))
|
||||
then
|
||||
declare
|
||||
Stat : constant Node_Id :=
|
||||
|
@ -6053,9 +6045,9 @@ package body Exp_Ch3 is
|
|||
if Is_Itype (Base)
|
||||
and then Nkind (Associated_Node_For_Itype (Base)) =
|
||||
N_Object_Declaration
|
||||
and then (Present (Expression (Associated_Node_For_Itype (Base)))
|
||||
or else
|
||||
No_Initialization (Associated_Node_For_Itype (Base)))
|
||||
and then
|
||||
(Present (Expression (Associated_Node_For_Itype (Base)))
|
||||
or else No_Initialization (Associated_Node_For_Itype (Base)))
|
||||
then
|
||||
null;
|
||||
|
||||
|
@ -6064,7 +6056,7 @@ package body Exp_Ch3 is
|
|||
-- initialize scalars mode, and these types are treated specially
|
||||
-- and do not need initialization procedures.
|
||||
|
||||
elsif Root_Type (Base) = Standard_String
|
||||
elsif Root_Type (Base) = Standard_String
|
||||
or else Root_Type (Base) = Standard_Wide_String
|
||||
or else Root_Type (Base) = Standard_Wide_Wide_String
|
||||
then
|
||||
|
@ -6108,7 +6100,7 @@ package body Exp_Ch3 is
|
|||
-- Normalize_Scalars and there better be a public Init_Proc for it.
|
||||
|
||||
elsif (Present (Init_Proc (Component_Type (Base)))
|
||||
and then No (Base_Init_Proc (Base)))
|
||||
and then No (Base_Init_Proc (Base)))
|
||||
or else (Init_Or_Norm_Scalars and then Base = Typ)
|
||||
or else Is_Public (Typ)
|
||||
then
|
||||
|
@ -6765,6 +6757,16 @@ package body Exp_Ch3 is
|
|||
or else Is_Tagged_Type (Etype (Def_Id))
|
||||
then
|
||||
Set_All_DT_Position (Def_Id);
|
||||
|
||||
-- If this is a type derived from an untagged private type whose
|
||||
-- full view is tagged, the type is marked tagged for layout
|
||||
-- reasons, but it has no dispatch table.
|
||||
|
||||
elsif Is_Derived_Type (Def_Id)
|
||||
and then Is_Private_Type (Etype (Def_Id))
|
||||
and then not Is_Tagged_Type (Etype (Def_Id))
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Create and decorate the tags. Suppress their creation when
|
||||
|
@ -6925,16 +6927,16 @@ package body Exp_Ch3 is
|
|||
if Is_Tagged_Type (Def_Id)
|
||||
and then not Is_Interface (Def_Id)
|
||||
then
|
||||
-- Do not add the body of predefined primitives in case of
|
||||
-- CPP tagged type derivations that have convention CPP.
|
||||
-- Do not add the body of predefined primitives in case of CPP tagged
|
||||
-- type derivations that have convention CPP.
|
||||
|
||||
if Is_CPP_Class (Root_Type (Def_Id))
|
||||
and then Convention (Def_Id) = Convention_CPP
|
||||
then
|
||||
null;
|
||||
|
||||
-- Do not add the body of predefined primitives in case of
|
||||
-- CIL and Java tagged types.
|
||||
-- Do not add the body of predefined primitives in case of CIL and
|
||||
-- Java tagged types.
|
||||
|
||||
elsif Convention (Def_Id) = Convention_CIL
|
||||
or else Convention (Def_Id) = Convention_Java
|
||||
|
@ -7087,8 +7089,8 @@ package body Exp_Ch3 is
|
|||
end;
|
||||
end if;
|
||||
|
||||
-- Check whether individual components have a defined invariant,
|
||||
-- and add the corresponding component invariant checks.
|
||||
-- Check whether individual components have a defined invariant, and add
|
||||
-- the corresponding component invariant checks.
|
||||
|
||||
Insert_Component_Invariant_Checks
|
||||
(N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N));
|
||||
|
@ -7569,16 +7571,16 @@ package body Exp_Ch3 is
|
|||
-- Start of processing for Get_Simple_Init_Val
|
||||
|
||||
begin
|
||||
-- For a private type, we should always have an underlying type
|
||||
-- (because this was already checked in Needs_Simple_Initialization).
|
||||
-- What we do is to get the value for the underlying type and then do
|
||||
-- an Unchecked_Convert to the private type.
|
||||
-- For a private type, we should always have an underlying type (because
|
||||
-- this was already checked in Needs_Simple_Initialization). What we do
|
||||
-- is to get the value for the underlying type and then do an unchecked
|
||||
-- conversion to the private type.
|
||||
|
||||
if Is_Private_Type (T) then
|
||||
Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
|
||||
|
||||
-- A special case, if the underlying value is null, then qualify it
|
||||
-- with the underlying type, so that the null is properly typed
|
||||
-- with the underlying type, so that the null is properly typed.
|
||||
-- Similarly, if it is an aggregate it must be qualified, because an
|
||||
-- unchecked conversion does not provide a context for it.
|
||||
|
||||
|
@ -7603,7 +7605,7 @@ package body Exp_Ch3 is
|
|||
return Result;
|
||||
|
||||
-- Scalars with Default_Value aspect. The first subtype may now be
|
||||
-- private, so retrieve value from underlying type.
|
||||
-- private, so retrieve value from underlying type.
|
||||
|
||||
elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
|
||||
if Is_Private_Type (First_Subtype (T)) then
|
||||
|
@ -7841,9 +7843,10 @@ package body Exp_Ch3 is
|
|||
else
|
||||
return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
|
||||
|
||||
-- May need a more precise check here: the First_Rep_Item may
|
||||
-- be a stream attribute, which does not affect the representation
|
||||
-- of the type ???
|
||||
-- May need a more precise check here: the First_Rep_Item may be a
|
||||
-- stream attribute, which does not affect the representation of the
|
||||
-- type ???
|
||||
|
||||
end if;
|
||||
end Has_New_Non_Standard_Rep;
|
||||
|
||||
|
@ -7955,7 +7958,7 @@ package body Exp_Ch3 is
|
|||
if Ekind (Comp) = E_Discriminant
|
||||
or else
|
||||
(Nkind (Parent (Comp)) = N_Component_Declaration
|
||||
and then Present (Expression (Parent (Comp))))
|
||||
and then Present (Expression (Parent (Comp))))
|
||||
then
|
||||
Warning_Needed := True;
|
||||
exit;
|
||||
|
@ -7988,10 +7991,10 @@ package body Exp_Ch3 is
|
|||
Formals : List_Id;
|
||||
|
||||
begin
|
||||
-- First parameter is always _Init : in out typ. Note that we need
|
||||
-- this to be in/out because in the case of the task record value,
|
||||
-- there are default record fields (_Priority, _Size, -Task_Info)
|
||||
-- that may be referenced in the generated initialization routine.
|
||||
-- First parameter is always _Init : in out typ. Note that we need this
|
||||
-- to be in/out because in the case of the task record value, there
|
||||
-- are default record fields (_Priority, _Size, -Task_Info) that may
|
||||
-- be referenced in the generated initialization routine.
|
||||
|
||||
Formals := New_List (
|
||||
Make_Parameter_Specification (Loc,
|
||||
|
@ -8085,8 +8088,7 @@ package body Exp_Ch3 is
|
|||
Offset_To_Top_Comp : Entity_Id := Empty;
|
||||
|
||||
begin
|
||||
-- Initialize the pointer to the secondary DT associated with the
|
||||
-- interface.
|
||||
-- Initialize pointer to secondary DT associated with the interface
|
||||
|
||||
if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
|
||||
Append_To (Stmts_List,
|
||||
|
@ -8157,8 +8159,8 @@ package body Exp_Ch3 is
|
|||
(DT_Offset_To_Top_Func (Tag_Comp), Loc),
|
||||
Attribute_Name => Name_Address)))));
|
||||
|
||||
-- In this case the next component stores the value of the
|
||||
-- offset to the top.
|
||||
-- In this case the next component stores the value of the offset
|
||||
-- to the top.
|
||||
|
||||
Offset_To_Top_Comp := Next_Entity (Tag_Comp);
|
||||
pragma Assert (Present (Offset_To_Top_Comp));
|
||||
|
@ -8304,11 +8306,11 @@ package body Exp_Ch3 is
|
|||
then
|
||||
exit when
|
||||
(Is_Record_Type (Comp_Typ)
|
||||
and then Is_Variable_Size_Record
|
||||
(Base_Type (Comp_Typ)))
|
||||
and then Is_Variable_Size_Record
|
||||
(Base_Type (Comp_Typ)))
|
||||
or else
|
||||
(Is_Array_Type (Comp_Typ)
|
||||
and then Is_Variable_Size_Array (Comp_Typ));
|
||||
and then Is_Variable_Size_Array (Comp_Typ));
|
||||
end if;
|
||||
|
||||
Next_Entity (Comp);
|
||||
|
@ -8892,9 +8894,7 @@ package body Exp_Ch3 is
|
|||
while Present (Elmt) loop
|
||||
Prim := Node (Elmt);
|
||||
|
||||
if Is_User_Defined_Equality (Prim)
|
||||
and then No (Alias (Prim))
|
||||
then
|
||||
if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
|
||||
if No (Renaming_Prim) then
|
||||
pragma Assert (No (Eq_Prim));
|
||||
Eq_Prim := Prim;
|
||||
|
@ -9489,9 +9489,9 @@ package body Exp_Ch3 is
|
|||
|
||||
elsif Consider_IS_NS
|
||||
and then
|
||||
(Root_Type (T) = Standard_String
|
||||
or else Root_Type (T) = Standard_Wide_String
|
||||
or else Root_Type (T) = Standard_Wide_Wide_String)
|
||||
(Root_Type (T) = Standard_String or else
|
||||
Root_Type (T) = Standard_Wide_String or else
|
||||
Root_Type (T) = Standard_Wide_Wide_String)
|
||||
and then
|
||||
(not Is_Itype (T)
|
||||
or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
|
||||
|
@ -9971,9 +9971,7 @@ package body Exp_Ch3 is
|
|||
-- attribute has been specified or Write (resp. Read) is available for
|
||||
-- an ancestor type. The last condition only applies under Ada 2005.
|
||||
|
||||
if Is_Limited_Type (Typ)
|
||||
and then Is_Tagged_Type (Typ)
|
||||
then
|
||||
if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
|
||||
if Operation = TSS_Stream_Read then
|
||||
Has_Predefined_Or_Specified_Stream_Attribute :=
|
||||
Has_Specified_Stream_Read (Typ);
|
||||
|
|
|
@ -49,9 +49,9 @@ package GNAT.Memory_Dump is
|
|||
-- like the AAMP, where the storage unit is not 8 bits). The output is one
|
||||
-- or more lines in the following format, which is for the case of 32-bit
|
||||
-- addresses (64-bit addresses are handled appropriately):
|
||||
|
||||
--
|
||||
-- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
|
||||
|
||||
--
|
||||
-- All but the last line have 16 bytes. A question mark is used in the
|
||||
-- string data to indicate a non-printable character.
|
||||
|
||||
|
@ -63,15 +63,15 @@ package GNAT.Memory_Dump is
|
|||
-- If Prefix is set to Absolute_Address, the output is identical to the
|
||||
-- above version, each line starting with the absolute address of the
|
||||
-- first dumped storage element.
|
||||
|
||||
--
|
||||
-- If Prefix is set to Offset, then instead each line starts with the
|
||||
-- indication of the offset relative to Addr:
|
||||
|
||||
--
|
||||
-- 00: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
|
||||
|
||||
--
|
||||
-- Finally if Prefix is set to None, the prefix is suppressed altogether,
|
||||
-- and only the memory contents are displayed:
|
||||
|
||||
--
|
||||
-- 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
|
||||
|
||||
end GNAT.Memory_Dump;
|
||||
|
|
|
@ -221,21 +221,18 @@ package Interfaces.C_Streams is
|
|||
-- Control of Text/Binary Mode --
|
||||
---------------------------------
|
||||
|
||||
-- If text_translation_required is true, then the following functions may
|
||||
-- be used to dynamically switch a file from binary to text mode or vice
|
||||
-- versa. These functions have no effect if text_translation_required is
|
||||
-- false (i.e. in normal unix mode). Use fileno to get a stream handle.
|
||||
|
||||
procedure set_binary_mode (handle : int);
|
||||
procedure set_text_mode (handle : int);
|
||||
|
||||
-- set_wide_text_mode is as set_text_mode but switches the translation to
|
||||
-- 16-bit wide-character instead of 8-bit character. Again, this routine
|
||||
-- has no effect if text_translation_required is false. On Windows this
|
||||
-- is used to have proper 16-bit wide-string output on the console for
|
||||
-- example.
|
||||
-- If text_translation_required is true, then these two functions may
|
||||
-- be used to dynamically switch a file from binary to text mode or vice
|
||||
-- versa. These functions have no effect if text_translation_required is
|
||||
-- false (e.g. in normal unix mode). Use fileno to get a stream handle.
|
||||
|
||||
procedure set_wide_text_mode (handle : int);
|
||||
-- This is similar to set_text_mode but switches the translation to 16-bit
|
||||
-- wide-character instead of 8-bit character. Again, this routine has no
|
||||
-- effect if text_translation_required is false. On Windows this is used
|
||||
-- to have proper 16-bit wide-string output on the console for example.
|
||||
|
||||
----------------------------
|
||||
-- Full Path Name support --
|
||||
|
|
|
@ -134,6 +134,34 @@ package body Sem_Ch13 is
|
|||
-- that do not specify a representation characteristic are operational
|
||||
-- attributes.
|
||||
|
||||
function Is_Predicate_Static
|
||||
(Expr : Node_Id;
|
||||
Nam : Name_Id) return Boolean;
|
||||
-- Given predicate expression Expr, tests if Expr is predicate-static in
|
||||
-- the sense of the rules in (RM 3.2.4 (15-24)). Occurrences of the type
|
||||
-- name in the predicate expression have been replaced by references to
|
||||
-- an identifier whose Chars field is Nam. This name is unique, so any
|
||||
-- identifier with Chars matching Nam must be a reference to the type.
|
||||
-- Returns True if the expression is predicate-static and False otherwise,
|
||||
-- but is not in the business of setting flags or issuing error messages.
|
||||
--
|
||||
-- Only scalar types can have static predicates, so False is always
|
||||
-- returned for non-scalar types.
|
||||
--
|
||||
-- Note: the RM seems to suggest that string types can also have static
|
||||
-- predicates. But that really makes lttle sense as very few useful
|
||||
-- predicates can be constructed for strings. Remember that:
|
||||
--
|
||||
-- "ABC" < "DEF"
|
||||
--
|
||||
-- is not a static expression. So even though the clearly faulty RM wording
|
||||
-- allows the following:
|
||||
--
|
||||
-- subtype S is String with Static_Predicate => S < "DEF"
|
||||
--
|
||||
-- We can't allow this, otherwise we have predicate-static applying to a
|
||||
-- larger class than static expressions, which was never intended.
|
||||
|
||||
procedure New_Stream_Subprogram
|
||||
(N : Node_Id;
|
||||
Ent : Entity_Id;
|
||||
|
@ -7509,9 +7537,6 @@ package body Sem_Ch13 is
|
|||
Raise_Expression_Present : Boolean := False;
|
||||
-- Set True if Expr has at least one Raise_Expression
|
||||
|
||||
Static_Predic : Node_Id := Empty;
|
||||
-- Set to N_Pragma node for a static predicate if one is encountered
|
||||
|
||||
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.
|
||||
|
@ -7557,9 +7582,10 @@ package body Sem_Ch13 is
|
|||
|
||||
if No (Expr) then
|
||||
Expr := Exp;
|
||||
|
||||
else
|
||||
Expr :=
|
||||
Make_And_Then (Loc,
|
||||
Make_And_Then (Sloc (Expr),
|
||||
Left_Opnd => Relocate_Node (Expr),
|
||||
Right_Opnd => Exp);
|
||||
end if;
|
||||
|
@ -7630,16 +7656,6 @@ package body Sem_Ch13 is
|
|||
if Nkind (Ritem) = N_Pragma
|
||||
and then Pragma_Name (Ritem) = Name_Predicate
|
||||
then
|
||||
-- Save the static predicate of the type for diagnostics and
|
||||
-- error reporting purposes.
|
||||
|
||||
if Present (Corresponding_Aspect (Ritem))
|
||||
and then Chars (Identifier (Corresponding_Aspect (Ritem))) =
|
||||
Name_Static_Predicate
|
||||
then
|
||||
Static_Predic := Ritem;
|
||||
end if;
|
||||
|
||||
-- Acquire arguments
|
||||
|
||||
Arg1 := First (Pragma_Argument_Associations (Ritem));
|
||||
|
@ -7963,51 +7979,80 @@ package body Sem_Ch13 is
|
|||
end;
|
||||
end if;
|
||||
|
||||
if Is_Discrete_Type (Typ) then
|
||||
-- See if we have a static predicate. Note that the answer may be
|
||||
-- yes even if we have an explicit Dynamic_Predicate present.
|
||||
|
||||
-- Attempt to build a static predicate for a discrete subtype.
|
||||
-- This action may fail because the actual expression may not be
|
||||
-- static. Note that the presence of an inherited or explicitly
|
||||
-- declared dynamic predicate is orthogonal to this check because
|
||||
-- we are only interested in the static predicate.
|
||||
declare
|
||||
PS : constant Boolean := Is_Predicate_Static (Expr, Object_Name);
|
||||
EN : Node_Id;
|
||||
|
||||
Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
|
||||
begin
|
||||
-- Case where we have a predicate static aspect
|
||||
|
||||
-- Emit an error when the predicate is categorized as static
|
||||
-- but its expression is dynamic.
|
||||
if PS then
|
||||
|
||||
if Present (Static_Predic)
|
||||
and then No (Static_Predicate (Typ))
|
||||
then
|
||||
Error_Msg_F
|
||||
("expression does not have required form for "
|
||||
& "static predicate",
|
||||
Next (First (Pragma_Argument_Associations
|
||||
(Static_Predic))));
|
||||
end if;
|
||||
-- We don't set Has_Static_Predicate_Aspect, since we can have
|
||||
-- any of the three cases (Predicate, Dynamic_Predicate, or
|
||||
-- Static_Predicate) generating a predicate with an expression
|
||||
-- that is predicate static. We just indicate that we have a
|
||||
-- predicate that can be treated as static.
|
||||
|
||||
-- If a static predicate applies on other types, that's an error:
|
||||
-- either the type is scalar but non-static, or it's not even a
|
||||
-- scalar type. We do not issue an error on generated types, as
|
||||
-- these may be duplicates of the same error on a source type.
|
||||
Set_Has_Static_Predicate (Typ);
|
||||
|
||||
elsif Present (Static_Predic) and then Comes_From_Source (Typ) then
|
||||
if Is_Real_Type (Typ) then
|
||||
Error_Msg_FE
|
||||
("static predicates not implemented for real type&",
|
||||
Typ, Typ);
|
||||
-- For discrete subtype, build the static predicate list
|
||||
|
||||
elsif Is_Scalar_Type (Typ) then
|
||||
Error_Msg_FE
|
||||
("static predicate not allowed for non-static type&",
|
||||
Typ, Typ);
|
||||
if Is_Discrete_Type (Typ) then
|
||||
Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
|
||||
|
||||
-- If we don't get a static predicate list, it means that we
|
||||
-- have a case where this is not possible, most typically in
|
||||
-- the case where we inherit a dynamic predicate. We do not
|
||||
-- consider this an error, we just leave the predicate as
|
||||
-- dynamic. But if we do succeed in building the list, then
|
||||
-- we mark the predicate as static.
|
||||
|
||||
if No (Static_Predicate (Typ)) then
|
||||
Set_Has_Static_Predicate (Typ, False);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Case of dynamic predicate (expression is not predicate-static)
|
||||
|
||||
else
|
||||
Error_Msg_FE
|
||||
("static predicate not allowed for non-scalar type&",
|
||||
Typ, Typ);
|
||||
-- Again, we don't set Has_Dynamic_Predicate_Aspect, since that
|
||||
-- is only set if we have an explicit Dynamic_Predicate aspect
|
||||
-- given. Here we may simply have a Predicate aspect where the
|
||||
-- expression happens not to be predicate-static.
|
||||
|
||||
-- Emit an error when the predicate is categorized as static
|
||||
-- but its expression is not predicate-static.
|
||||
|
||||
-- First a little fiddling to get a nice location for the
|
||||
-- message. If the expression is of the form (A and then B),
|
||||
-- then use the left operand for the Sloc. This avoids getting
|
||||
-- confused by a call to a higher level predicate with a less
|
||||
-- convenient source location.
|
||||
|
||||
EN := Expr;
|
||||
while Nkind (EN) = N_And_Then loop
|
||||
EN := Left_Opnd (EN);
|
||||
end loop;
|
||||
|
||||
-- Now post appropriate message
|
||||
|
||||
if Has_Static_Predicate_Aspect (Typ) then
|
||||
if Is_Scalar_Type (Typ) then
|
||||
Error_Msg_F
|
||||
("expression is not predicate-static (RM 4.3.2(16-22))",
|
||||
EN);
|
||||
else
|
||||
Error_Msg_FE
|
||||
("static predicate not allowed for non-scalar type&",
|
||||
EN, Typ);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end Build_Predicate_Functions;
|
||||
|
||||
|
@ -10293,6 +10338,210 @@ package body Sem_Ch13 is
|
|||
end if;
|
||||
end Is_Operational_Item;
|
||||
|
||||
-------------------------
|
||||
-- Is_Predicate_Static --
|
||||
-------------------------
|
||||
|
||||
function Is_Predicate_Static
|
||||
(Expr : Node_Id;
|
||||
Nam : Name_Id) return Boolean
|
||||
is
|
||||
function All_Static_Case_Alternatives (L : List_Id) return Boolean;
|
||||
-- Given a list of case expression alternatives, returns True if
|
||||
-- all the alternative are static (have all static choices, and a
|
||||
-- static expression).
|
||||
|
||||
function All_Static_Choices (L : List_Id) return Boolean;
|
||||
-- Returns true if all elements of the list are ok static choices
|
||||
-- as defined below for Is_Static_Choice. Used for case expression
|
||||
-- alternatives and for the right operand of a membership test.
|
||||
|
||||
function Is_Static_Choice (N : Node_Id) return Boolean;
|
||||
-- Returns True if N represents a static choice (static subtype, or
|
||||
-- static subtype indication, or static expression or static range).
|
||||
--
|
||||
-- Note that this is a bit more inclusive than we actually need
|
||||
-- (in particular membership tests do not allow the use of subtype
|
||||
-- indications. But that doesn't matter, we have already checked
|
||||
-- that the construct is legal to get this far.
|
||||
|
||||
function Is_Type_Ref (N : Node_Id) return Boolean;
|
||||
pragma Inline (Is_Type_Ref);
|
||||
-- Returns if True if N is a reference to the type for the predicate in
|
||||
-- the expression (i.e. if it is an identifier whose Chars field matches
|
||||
-- the Nam given in the call). N must not be parenthesized, if the type
|
||||
-- name appears in parens, this routine will return False.
|
||||
|
||||
----------------------------------
|
||||
-- All_Static_Case_Alternatives --
|
||||
----------------------------------
|
||||
|
||||
function All_Static_Case_Alternatives (L : List_Id) return Boolean is
|
||||
N : Node_Id;
|
||||
|
||||
begin
|
||||
N := First (L);
|
||||
while Present (N) loop
|
||||
if not (All_Static_Choices (Discrete_Choices (N))
|
||||
and then Is_OK_Static_Expression (Expression (N)))
|
||||
then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Next (N);
|
||||
end loop;
|
||||
|
||||
return True;
|
||||
end All_Static_Case_Alternatives;
|
||||
|
||||
------------------------
|
||||
-- All_Static_Choices --
|
||||
------------------------
|
||||
|
||||
function All_Static_Choices (L : List_Id) return Boolean is
|
||||
N : Node_Id;
|
||||
|
||||
begin
|
||||
N := First (L);
|
||||
while Present (N) loop
|
||||
if not Is_Static_Choice (N) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Next (N);
|
||||
end loop;
|
||||
|
||||
return True;
|
||||
end All_Static_Choices;
|
||||
|
||||
----------------------
|
||||
-- Is_Static_Choice --
|
||||
----------------------
|
||||
|
||||
function Is_Static_Choice (N : Node_Id) return Boolean is
|
||||
begin
|
||||
return Is_OK_Static_Expression (N)
|
||||
or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
|
||||
and then Is_OK_Static_Subtype (Entity (N)))
|
||||
or else (Nkind (N) = N_Subtype_Indication
|
||||
and then Is_OK_Static_Subtype (Entity (N)))
|
||||
or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N));
|
||||
end Is_Static_Choice;
|
||||
|
||||
-----------------
|
||||
-- Is_Type_Ref --
|
||||
-----------------
|
||||
|
||||
function Is_Type_Ref (N : Node_Id) return Boolean is
|
||||
begin
|
||||
return Nkind (N) = N_Identifier
|
||||
and then Chars (N) = Nam
|
||||
and then Paren_Count (N) = 0;
|
||||
end Is_Type_Ref;
|
||||
|
||||
-- Start of processing for Is_Predicate_Static
|
||||
|
||||
begin
|
||||
-- Only scalar types can be predicate static
|
||||
|
||||
if not Is_Scalar_Type (Etype (Expr)) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- Predicate_Static means one of the following holds. Numbers are the
|
||||
-- corresponding paragraph numbers in (RM 3.2.4(16-22)).
|
||||
|
||||
-- 16: A static expression
|
||||
|
||||
if Is_OK_Static_Expression (Expr) then
|
||||
return True;
|
||||
|
||||
-- 17: A membership test whose simple_expression is the current
|
||||
-- instance, and whose membership_choice_list meets the requirements
|
||||
-- for a static membership test.
|
||||
|
||||
elsif Nkind (Expr) in N_Membership_Test
|
||||
and then ((Present (Right_Opnd (Expr))
|
||||
and then Is_Static_Choice (Right_Opnd (Expr)))
|
||||
or else
|
||||
(Present (Alternatives (Expr))
|
||||
and then All_Static_Choices (Alternatives (Expr))))
|
||||
then
|
||||
return True;
|
||||
|
||||
-- 18. A case_expression whose selecting_expression is the current
|
||||
-- instance, and whose dependent expressions are static expressions.
|
||||
|
||||
elsif Nkind (Expr) = N_Case_Expression
|
||||
and then Is_Type_Ref (Expression (Expr))
|
||||
and then All_Static_Case_Alternatives (Alternatives (Expr))
|
||||
then
|
||||
return True;
|
||||
|
||||
-- 19. A call to a predefined equality or ordering operator, where one
|
||||
-- operand is the current instance, and the other is a static
|
||||
-- expression.
|
||||
|
||||
elsif Nkind (Expr) in N_Op_Compare
|
||||
and then ((Is_Type_Ref (Left_Opnd (Expr))
|
||||
and then Is_OK_Static_Expression (Right_Opnd (Expr)))
|
||||
or else
|
||||
(Is_Type_Ref (Right_Opnd (Expr))
|
||||
and then Is_OK_Static_Expression (Left_Opnd (Expr))))
|
||||
then
|
||||
return True;
|
||||
|
||||
-- 20. A call to a predefined boolean logical operator, where each
|
||||
-- operand is predicate-static.
|
||||
|
||||
elsif (Nkind_In (Expr, N_Op_And, N_Op_Or, N_Op_Xor)
|
||||
and then Is_Predicate_Static (Left_Opnd (Expr), Nam)
|
||||
and then Is_Predicate_Static (Right_Opnd (Expr), Nam))
|
||||
or else
|
||||
(Nkind (Expr) = N_Op_Not
|
||||
and then Is_Predicate_Static (Right_Opnd (Expr), Nam))
|
||||
then
|
||||
return True;
|
||||
|
||||
-- 21. A short-circuit control form where both operands are
|
||||
-- predicate-static.
|
||||
|
||||
elsif Nkind (Expr) in N_Short_Circuit
|
||||
and then Is_Predicate_Static (Left_Opnd (Expr), Nam)
|
||||
and then Is_Predicate_Static (Right_Opnd (Expr), Nam)
|
||||
then
|
||||
return True;
|
||||
|
||||
-- 22. A parenthesized predicate-static expression. This does not
|
||||
-- require any special test, since we just ignore paren levels in
|
||||
-- all the cases above.
|
||||
|
||||
-- One more test that is an implementation artifact caused by the fact
|
||||
-- that we are analyzing not the original expresesion, but the generated
|
||||
-- expression in the body of the predicate function. This can include
|
||||
-- refereces to inherited predicates, so that the expression we are
|
||||
-- processing looks like:
|
||||
|
||||
-- expression and then xxPredicate (typ (Inns))
|
||||
|
||||
-- Where the call is to a Predicate function for an inherited predicate.
|
||||
-- We simply ignore such a call (which could be to either a dynamic or
|
||||
-- a static predicate, but remember that we can have Static_Predicate
|
||||
-- for a non-static subtype).
|
||||
|
||||
elsif Nkind (Expr) = N_Function_Call
|
||||
and then Is_Predicate_Function (Entity (Name (Expr)))
|
||||
then
|
||||
return True;
|
||||
|
||||
-- That's an exhaustive list of tests, all other cases are not
|
||||
-- predicate static, so we return False.
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
end Is_Predicate_Static;
|
||||
|
||||
---------------------
|
||||
-- Kill_Rep_Clause --
|
||||
---------------------
|
||||
|
|
|
@ -13618,8 +13618,8 @@ package body Sem_Ch3 is
|
|||
Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type))
|
||||
or else
|
||||
(Ada_Version >= Ada_2012
|
||||
and then Ekind (Id_Type) = E_Incomplete_Type
|
||||
and then Full_View (Id_Type) = Parent_Type)
|
||||
and then Ekind (Id_Type) = E_Incomplete_Type
|
||||
and then Full_View (Id_Type) = Parent_Type)
|
||||
then
|
||||
-- Constraint checks on formals are generated during expansion,
|
||||
-- based on the signature of the original subprogram. The bounds
|
||||
|
|
|
@ -1331,9 +1331,6 @@ package body Sem_Ch4 is
|
|||
-----------------------------
|
||||
|
||||
procedure Analyze_Case_Expression (N : Node_Id) is
|
||||
function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean;
|
||||
-- Determine whether subtype Subtyp has aspect Static_Predicate
|
||||
|
||||
procedure Non_Static_Choice_Error (Choice : Node_Id);
|
||||
-- Error routine invoked by the generic instantiation below when
|
||||
-- the case expression has a non static choice.
|
||||
|
@ -1350,28 +1347,6 @@ package body Sem_Ch4 is
|
|||
Process_Associated_Node => No_OP);
|
||||
use Case_Choices_Checking;
|
||||
|
||||
--------------------------
|
||||
-- Has_Static_Predicate --
|
||||
--------------------------
|
||||
|
||||
function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean is
|
||||
Item : Node_Id;
|
||||
|
||||
begin
|
||||
Item := First_Rep_Item (Subtyp);
|
||||
while Present (Item) loop
|
||||
if Nkind (Item) = N_Aspect_Specification
|
||||
and then Chars (Identifier (Item)) = Name_Static_Predicate
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
Next_Rep_Item (Item);
|
||||
end loop;
|
||||
|
||||
return False;
|
||||
end Has_Static_Predicate;
|
||||
|
||||
-----------------------------
|
||||
-- Non_Static_Choice_Error --
|
||||
-----------------------------
|
||||
|
@ -1493,7 +1468,7 @@ package body Sem_Ch4 is
|
|||
-- to bogus errors.
|
||||
|
||||
if Is_Static_Subtype (Exp_Type)
|
||||
and then Has_Static_Predicate (Exp_Type)
|
||||
and then Has_Static_Predicate_Aspect (Exp_Type)
|
||||
and then In_Spec_Expression
|
||||
then
|
||||
null;
|
||||
|
|
|
@ -3306,28 +3306,42 @@ package body Sem_Eval is
|
|||
Typ : Entity_Id) return Boolean
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Pred : constant List_Id := Static_Predicate (Typ);
|
||||
Test : Node_Id;
|
||||
|
||||
begin
|
||||
if No (Pred) then
|
||||
-- Discrete type case
|
||||
|
||||
if Is_Discrete_Type (Typ) then
|
||||
declare
|
||||
Pred : constant List_Id := Static_Predicate (Typ);
|
||||
Test : Node_Id;
|
||||
|
||||
begin
|
||||
pragma Assert (Present (Pred));
|
||||
|
||||
-- The static predicate is a list of alternatives in the proper
|
||||
-- format for an Ada 2012 membership test. If the argument is a
|
||||
-- literal, the membership test can be evaluated statically. This
|
||||
-- is easier than running a full intepretation of the predicate
|
||||
-- expression, and more efficient in some cases.
|
||||
|
||||
Test :=
|
||||
Make_In (Loc,
|
||||
Left_Opnd => New_Copy_Tree (N),
|
||||
Right_Opnd => Empty,
|
||||
Alternatives => Pred);
|
||||
Analyze_And_Resolve (Test, Standard_Boolean);
|
||||
|
||||
return Nkind (Test) = N_Identifier
|
||||
and then Entity (Test) = Standard_True;
|
||||
end;
|
||||
|
||||
-- Real type case
|
||||
|
||||
else
|
||||
pragma Assert (Is_Real_Type (Typ));
|
||||
Error_Msg_N ("??real predicate not applied", N);
|
||||
return True;
|
||||
end if;
|
||||
|
||||
-- The static predicate is a list of alternatives in the proper format
|
||||
-- for an Ada 2012 membership test. If the argument is a literal, the
|
||||
-- membership test can be evaluated statically. The caller transforms
|
||||
-- a result of False into a static contraint error.
|
||||
|
||||
Test :=
|
||||
Make_In (Loc,
|
||||
Left_Opnd => New_Copy_Tree (N),
|
||||
Right_Opnd => Empty,
|
||||
Alternatives => Pred);
|
||||
Analyze_And_Resolve (Test, Standard_Boolean);
|
||||
|
||||
return Nkind (Test) = N_Identifier
|
||||
and then Entity (Test) = Standard_True;
|
||||
end Eval_Static_Predicate_Check;
|
||||
|
||||
-------------------------
|
||||
|
|
|
@ -248,7 +248,7 @@ package Sem_Eval is
|
|||
-- In general we take a pessimistic view. False does not mean the value
|
||||
-- could not be known at compile time, but True means that absolutely
|
||||
-- definition it is known at compile time and it is safe to call
|
||||
-- Expr_Value on the expression Op.
|
||||
-- Expr_Value[_XX] on the expression Op.
|
||||
--
|
||||
-- Note that we don't define precisely the set of expressions that return
|
||||
-- True. Callers should not make any assumptions regarding the value that
|
||||
|
@ -365,9 +365,11 @@ package Sem_Eval is
|
|||
procedure Eval_Unchecked_Conversion (N : Node_Id);
|
||||
|
||||
function Eval_Static_Predicate_Check
|
||||
(N : Node_Id;
|
||||
Typ : Entity_Id) return Boolean;
|
||||
-- Evaluate a static predicate check applied to a scalar literal
|
||||
(N : Node_Id;
|
||||
Typ : Entity_Id) return Boolean;
|
||||
-- Evaluate a static predicate check applied to a known at compile time
|
||||
-- value N, which can be of a discrete, real or string type. The caller
|
||||
-- has checked that a static predicate does apply to Typ.
|
||||
|
||||
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
|
||||
-- Rewrite N with a new N_String_Literal node as the result of the compile
|
||||
|
|
|
@ -1695,13 +1695,13 @@ package body Sem_Util is
|
|||
begin
|
||||
-- When the predicate is static and the value of the expression is known
|
||||
-- at compile time, evaluate the predicate check. A type is non-static
|
||||
-- when it has aspect Dynamic_Predicate.
|
||||
-- when it has aspect Dynamic_Predicate, but if the dynamic predicate
|
||||
-- was predicate-static, we still check it statically. After all this
|
||||
-- is only a warning, not an error.
|
||||
|
||||
if Compile_Time_Known_Value (Expr)
|
||||
and then Has_Predicates (Typ)
|
||||
and then Is_Discrete_Type (Typ)
|
||||
and then Present (Static_Predicate (Typ))
|
||||
and then not Has_Dynamic_Predicate_Aspect (Typ)
|
||||
and then Has_Static_Predicate (Typ)
|
||||
then
|
||||
-- Either -gnatc is enabled or the expression is ok
|
||||
|
||||
|
@ -1710,12 +1710,14 @@ package body Sem_Util is
|
|||
then
|
||||
null;
|
||||
|
||||
-- The expression is prohibited by the static predicate
|
||||
-- The expression is prohibited by the static predicate. There has
|
||||
-- been some debate if this is an illegality (in the case where
|
||||
-- the static predicate was explicitly given as such), but that
|
||||
-- discussion decided this was not illegal, just a warning situation.
|
||||
|
||||
else
|
||||
Error_Msg_NE
|
||||
("??static expression fails static predicate check on &",
|
||||
Expr, Typ);
|
||||
("??static expression fails predicate check on &", Expr, Typ);
|
||||
end if;
|
||||
end if;
|
||||
end Check_Expression_Against_Static_Predicate;
|
||||
|
|
|
@ -4022,13 +4022,13 @@ package Sinfo is
|
|||
-- to deal with, and diagnose a simple expression other than a name for
|
||||
-- the right operand. This simplifies error recovery in the parser.
|
||||
|
||||
-- The Alternatives field below is present only if there is more
|
||||
-- than one Membership_Choice present (which is legitimate only in
|
||||
-- Ada 2012 mode) in which case Right_Opnd is Empty, and Alternatives
|
||||
-- contains the list of choices. In the tree passed to the back end,
|
||||
-- Alternatives is always No_List, and Right_Opnd is set (i.e. the
|
||||
-- expansion circuitry expands out the complex set membership case
|
||||
-- using simple membership operations).
|
||||
-- The Alternatives field below is present only if there is more than
|
||||
-- one Membership_Choice present (which is legitimate only in Ada 2012
|
||||
-- mode) in which case Right_Opnd is Empty, and Alternatives contains
|
||||
-- the list of choices. In the tree passed to the back end, Alternatives
|
||||
-- is always No_List, and Right_Opnd is set (i.e. the expansion circuit
|
||||
-- expands out the complex set membership case using simple membership
|
||||
-- and equality operations).
|
||||
|
||||
-- Should we rename Alternatives here to Membership_Choices ???
|
||||
|
||||
|
@ -4271,7 +4271,7 @@ package Sinfo is
|
|||
-- CASE_EXPRESSION ::=
|
||||
-- case SELECTING_EXPRESSION is
|
||||
-- CASE_EXPRESSION_ALTERNATIVE
|
||||
-- {CASE_EXPRESSION_ALTERNATIVE}
|
||||
-- {,CASE_EXPRESSION_ALTERNATIVE}
|
||||
|
||||
-- Note that the Alternatives cannot include pragmas (this contrasts
|
||||
-- with the situation of case statements where pragmas are allowed).
|
||||
|
|
Loading…
Reference in New Issue