+2018-05-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Strip away any
+ conversions before extracting the value of the expression.
+ * exp_ch3.adb (Default_Initialize_Object): Optimize the default
+ initialization of an array of scalars.
+ (Get_Simple_Init_Val): Add processing for array types. Remove the
+ processing of strings because this case is already handled by the array
+ case.
+ (Needs_Simple_Initialization): Moved to Sem_Util.
+ (Simple_Init_Array_Type): New routine.
+ (Simple_Init_Initialize_Scalars_Type): Reimplemented to use the new
+ facilities from Sem_Util.
+ (Simple_Initialization_OK): New routine.
+ * exp_ch3.ads (Needs_Simple_Initialization): Moved to Sem_Util.
+ * exp_ch4.adb (Expand_N_Allocator): Optimize the default allocation of
+ an array of scalars.
+ * sem_prag.adb (Analyze_Float_Value): New routine.
+ (Analyze_Integer_Value): New routine.
+ (Analyze_Pragma): Reimplement the analysis of pragma Initialize_Scalars
+ to handled the extended form of the pragma.
+ (Analyze_Type_Value_Pair): New routine.
+ * sem_util.adb: Add invalid value-related data structures.
+ (Examine_Array_Bounds): New routine.
+ (Has_Static_Array_Bounds): Reimplemented.
+ (Has_Static_Non_Empty_Array_Bounds): New routine.
+ (Invalid_Scalar_Value): New routine.
+ (Needs_Simple_Initialization): Moved from Exp_Ch3.
+ (Set_Invalid_Scalar_Value): New routines.
+ * sem_util.ads (Has_Static_Non_Empty_Array_Bounds): New routine.
+ (Invalid_Scalar_Value): New routine.
+ (Needs_Simple_Initialization): Moved from Exp_Ch3.
+ (Set_Invalid_Scalar_Value): New routines.
+ * snames.ads-tmpl: Add names for the salar type families used by pragma
+ Initialize_Scalars.
+
2018-05-22 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_DT): Initialize the External_Tag with an empty
-- specifically optimized for the target.
function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
+ Csiz : Uint;
Ctyp : Entity_Id;
+ Expr : Node_Id;
+ High : Node_Id;
Index : Entity_Id;
- Expr : Node_Id := N;
Low : Node_Id;
- High : Node_Id;
- Csiz : Uint;
+ Nunits : Int;
Remainder : Uint;
Value : Uint;
- Nunits : Nat;
begin
-- Recurse as far as possible to find the innermost component type
Ctyp := Etype (N);
+ Expr := N;
while Is_Array_Type (Ctyp) loop
if Nkind (Expr) /= N_Aggregate
or else not Is_Others_Aggregate (Expr)
Analyze_And_Resolve (Expr, Ctyp);
+ -- Strip away any conversions from the expression as they simply
+ -- qualify the real expression.
+
+ while Nkind_In (Expr, N_Unchecked_Type_Conversion,
+ N_Type_Conversion)
+ loop
+ Expr := Expression (Expr);
+ end loop;
+
Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
if Nunits = 1 then
-- Return a new reference to Def_Id with attributes Assignment_OK and
-- Must_Not_Freeze already set.
+ function Simple_Initialization_OK
+ (Init_Typ : Entity_Id) return Boolean;
+ -- Determine whether object declaration N with entity Def_Id needs
+ -- simple initialization, assuming that it is of type Init_Typ.
+
--------------------------
-- New_Object_Reference --
--------------------------
return Obj_Ref;
end New_Object_Reference;
+ ------------------------------
+ -- Simple_Initialization_OK --
+ ------------------------------
+
+ function Simple_Initialization_OK
+ (Init_Typ : Entity_Id) return Boolean
+ is
+ begin
+ -- Do not consider the object declaration if it comes with an
+ -- initialization expression, or is internal in which case it
+ -- will be assigned later.
+
+ return
+ not Is_Internal (Def_Id)
+ and then not Has_Init_Expression (N)
+ and then Needs_Simple_Initialization
+ (Typ => Init_Typ,
+ Consider_IS =>
+ Initialize_Scalars
+ and then No (Following_Address_Clause (N)));
+ end Simple_Initialization_OK;
+
-- Local variables
Exceptions_OK : constant Boolean :=
elsif Build_Equivalent_Aggregate then
null;
+ -- Optimize the default initialization of an array object when
+ -- the following conditions are met:
+ --
+ -- * Pragma Initialize_Scalars or Normalize_Scalars is in
+ -- effect.
+ --
+ -- * The bounds of the array type are static and lack empty
+ -- ranges.
+ --
+ -- * The array type does not contain atomic components or is
+ -- treated as packed.
+ --
+ -- * The component is of a scalar type which requires simple
+ -- initialization.
+ --
+ -- Construct an in-place initialization aggregate which may be
+ -- convert into a fast memset by the backend.
+
+ elsif Init_Or_Norm_Scalars
+ and then Is_Array_Type (Typ)
+ and then not Has_Atomic_Components (Typ)
+ and then not Is_Packed (Typ)
+ and then Has_Static_Non_Empty_Array_Bounds (Typ)
+ and then Is_Scalar_Type (Component_Type (Typ))
+ and then Simple_Initialization_OK (Component_Type (Typ))
+ then
+ Set_No_Initialization (N, False);
+ Set_Expression (N,
+ Get_Simple_Init_Val
+ (Typ => Typ,
+ N => Obj_Def,
+ Size => Esize (Def_Id)));
+
+ Analyze_And_Resolve (Expression (N), Typ);
+
-- Otherwise invoke the type init proc, generate:
-- Type_Init_Proc (Obj);
end if;
-- Provide a default value if the object needs simple initialization
- -- and does not already have an initial value. A generated temporary
- -- does not require initialization because it will be assigned later.
- elsif Needs_Simple_Initialization
- (Typ, Initialize_Scalars
- and then No (Following_Address_Clause (N)))
- and then not Is_Internal (Def_Id)
- and then not Has_Init_Expression (N)
- then
+ elsif Simple_Initialization_OK (Typ) then
Set_No_Initialization (N, False);
Set_Expression (N,
Get_Simple_Init_Val
-- * Hi_Bound - Set to No_Unit when there is no information available,
-- or to the known high bound.
+ function Simple_Init_Array_Type return Node_Id;
+ -- Build an expression to initialize array type Typ
+
function Simple_Init_Defaulted_Type return Node_Id;
-- Build an expression to initialize type Typ which is subject to
-- aspect Default_Value.
function Simple_Init_Scalar_Type return Node_Id;
-- Build an expression to initialize scalar type Typ
- function Simple_Init_String_Type return Node_Id;
- -- Build an expression to initialize string type Typ
-
----------------------------
-- Extract_Subtype_Bounds --
----------------------------
end loop;
end Extract_Subtype_Bounds;
+ ----------------------------
+ -- Simple_Init_Array_Type --
+ ----------------------------
+
+ function Simple_Init_Array_Type return Node_Id is
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+
+ function Simple_Init_Dimension (Index : Node_Id) return Node_Id;
+ -- Initialize a single array dimension with index constraint Index
+
+ --------------------
+ -- Simple_Init_Dimension --
+ --------------------
+
+ function Simple_Init_Dimension (Index : Node_Id) return Node_Id is
+ begin
+ -- Process the current dimension
+
+ if Present (Index) then
+
+ -- Build a suitable "others" aggregate for the next dimension,
+ -- or initialize the component itself. Generate:
+ --
+ -- (others => ...)
+
+ return
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression =>
+ Simple_Init_Dimension (Next_Index (Index)))));
+
+ -- Otherwise all dimensions have been processed. Initialize the
+ -- component itself.
+
+ else
+ return
+ Get_Simple_Init_Val
+ (Typ => Comp_Typ,
+ N => N,
+ Size => Esize (Comp_Typ));
+ end if;
+ end Simple_Init_Dimension;
+
+ -- Start of processing for Simple_Init_Array_Type
+
+ begin
+ return Simple_Init_Dimension (First_Index (Typ));
+ end Simple_Init_Array_Type;
+
--------------------------------
-- Simple_Init_Defaulted_Type --
--------------------------------
Float_Typ : Entity_Id;
Hi_Bound : Uint;
Lo_Bound : Uint;
- Val_RE : RE_Id;
+ Scal_Typ : Scalar_Id;
begin
Extract_Subtype_Bounds (Lo_Bound, Hi_Bound);
- -- For float types, use float values from System.Scalar_Values
+ -- Float types
if Is_Floating_Point_Type (Typ) then
Float_Typ := Root_Type (Typ);
if Float_Typ = Standard_Short_Float then
- Val_RE := RE_IS_Isf;
+ Scal_Typ := Name_Short_Float;
elsif Float_Typ = Standard_Float then
- Val_RE := RE_IS_Ifl;
+ Scal_Typ := Name_Float;
elsif Float_Typ = Standard_Long_Float then
- Val_RE := RE_IS_Ilf;
+ Scal_Typ := Name_Long_Float;
else pragma Assert (Float_Typ = Standard_Long_Long_Float);
- Val_RE := RE_IS_Ill;
+ Scal_Typ := Name_Long_Long_Float;
end if;
- -- If zero is invalid, use zero values from System.Scalar_Values
+ -- If zero is invalid, it is a convenient value to use that is for
+ -- sure an appropriate invalid value in all situations.
elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then
- if Size_To_Use <= 8 then
- Val_RE := RE_IS_Iz1;
- elsif Size_To_Use <= 16 then
- Val_RE := RE_IS_Iz2;
- elsif Size_To_Use <= 32 then
- Val_RE := RE_IS_Iz4;
- else
- Val_RE := RE_IS_Iz8;
- end if;
+ return Make_Integer_Literal (Loc, 0);
- -- For unsigned, use unsigned values from System.Scalar_Values
+ -- Unsigned types
elsif Is_Unsigned_Type (Typ) then
if Size_To_Use <= 8 then
- Val_RE := RE_IS_Iu1;
+ Scal_Typ := Name_Unsigned_8;
elsif Size_To_Use <= 16 then
- Val_RE := RE_IS_Iu2;
+ Scal_Typ := Name_Unsigned_16;
elsif Size_To_Use <= 32 then
- Val_RE := RE_IS_Iu4;
+ Scal_Typ := Name_Unsigned_32;
else
- Val_RE := RE_IS_Iu8;
+ Scal_Typ := Name_Unsigned_64;
end if;
- -- For signed, use signed values from System.Scalar_Values
+ -- Signed types
else
if Size_To_Use <= 8 then
- Val_RE := RE_IS_Is1;
+ Scal_Typ := Name_Signed_8;
elsif Size_To_Use <= 16 then
- Val_RE := RE_IS_Is2;
+ Scal_Typ := Name_Signed_16;
elsif Size_To_Use <= 32 then
- Val_RE := RE_IS_Is4;
+ Scal_Typ := Name_Signed_32;
else
- Val_RE := RE_IS_Is8;
+ Scal_Typ := Name_Signed_64;
end if;
end if;
- return New_Occurrence_Of (RTE (Val_RE), Loc);
+ -- Use the values specified by pragma Initialize_Scalars or the ones
+ -- provided by the binder. Higher precedence is given to the pragma.
+
+ return Invalid_Scalar_Value (Loc, Scal_Typ);
end Simple_Init_Initialize_Scalars_Type;
----------------------------------------
return Expr;
end Simple_Init_Scalar_Type;
- -----------------------------
- -- Simple_Init_String_Type --
- -----------------------------
-
- function Simple_Init_String_Type return Node_Id is
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
-
- begin
- -- Generate:
- -- (others => Get_Simple_Init_Value)
-
- return
- Make_Aggregate (Loc,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression =>
- Get_Simple_Init_Val
- (Typ => Comp_Typ,
- N => N,
- Size => Esize (Comp_Typ)))));
- end Simple_Init_String_Type;
-
-- Start of processing for Get_Simple_Init_Val
begin
return Simple_Init_Scalar_Type;
end if;
- -- [[Wide_]Wide_]String with Initialize or Normalize_Scalars
+ -- Array type with Initialize or Normalize_Scalars
- elsif Is_Standard_String_Type (Typ) then
+ elsif Is_Array_Type (Typ) then
pragma Assert (Init_Or_Norm_Scalars);
- return Simple_Init_String_Type;
+ return Simple_Init_Array_Type;
-- Access type is initialized to null
end if;
end Make_Tag_Assignment;
- ---------------------------------
- -- Needs_Simple_Initialization --
- ---------------------------------
-
- function Needs_Simple_Initialization
- (Typ : Entity_Id;
- Consider_IS : Boolean := True) return Boolean
- is
- Consider_IS_NS : constant Boolean :=
- Normalize_Scalars or (Initialize_Scalars and Consider_IS);
-
- begin
- -- Never need initialization if it is suppressed
-
- if Initialization_Suppressed (Typ) then
- return False;
- end if;
-
- -- Check for private type, in which case test applies to the underlying
- -- type of the private type.
-
- if Is_Private_Type (Typ) then
- declare
- RT : constant Entity_Id := Underlying_Type (Typ);
- begin
- if Present (RT) then
- return Needs_Simple_Initialization (RT);
- else
- return False;
- end if;
- end;
-
- -- Scalar type with Default_Value aspect requires initialization
-
- elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then
- return True;
-
- -- Cases needing simple initialization are access types, and, if pragma
- -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
- -- types.
-
- elsif Is_Access_Type (Typ)
- or else (Consider_IS_NS and then (Is_Scalar_Type (Typ)))
- then
- return True;
-
- -- If Initialize/Normalize_Scalars is in effect, string objects also
- -- need initialization, unless they are created in the course of
- -- expanding an aggregate (since in the latter case they will be
- -- filled with appropriate initializing values before they are used).
-
- elsif Consider_IS_NS
- and then Is_Standard_String_Type (Typ)
- and then
- (not Is_Itype (Typ)
- or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate)
- then
- return True;
-
- else
- return False;
- end if;
- end Needs_Simple_Initialization;
-
----------------------
-- Predef_Deep_Spec --
----------------------
-- clause the assignment is handled as part of the freezing of the object,
-- see Check_Address_Clause.
- function Needs_Simple_Initialization
- (Typ : Entity_Id;
- Consider_IS : Boolean := True) return Boolean;
- -- Certain types need initialization even though there is no specific
- -- initialization routine:
- -- Access types (which need initializing to null)
- -- All scalar types if Normalize_Scalars mode set
- -- Descendants of standard string types if Normalize_Scalars mode set
- -- Scalar types having a Default_Value attribute
- -- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
- -- set to False, but if Consider_IS is set to True, then the cases above
- -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
-
end Exp_Ch3;
-- first argument to Init must be converted to the task record type.
declare
- T : constant Entity_Id := Entity (Expression (N));
+ T : constant Entity_Id := Etype (Expression (N));
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Is_Allocate => True);
end if;
+ -- Optimize the default allocation of an array object when the
+ -- following conditions are met:
+ --
+ -- * Pragma Initialize_Scalars or Normalize_Scalars is in effect
+ --
+ -- * The bounds of the array type are static and lack empty ranges
+ --
+ -- * The array type does not contain atomic components or is
+ -- treated as packed.
+ --
+ -- * The component is of a scalar type which requires simple
+ -- initialization.
+ --
+ -- Construct an in-place initialization aggregate which may be
+ -- convert into a fast memset by the backend.
+
+ elsif Init_Or_Norm_Scalars
+ and then Is_Array_Type (T)
+ and then not Has_Atomic_Components (T)
+ and then not Is_Packed (T)
+ and then Has_Static_Non_Empty_Array_Bounds (T)
+ and then Is_Scalar_Type (Component_Type (T))
+ and then Needs_Simple_Initialization
+ (Typ => Component_Type (T),
+ Consider_IS => True)
+ then
+ Set_Analyzed (N);
+ Temp := Make_Temporary (Loc, 'P');
+
+ -- Generate:
+ -- Temp : Ptr_Typ := new ...;
+
+ Insert_Action
+ (Assoc_Node => N,
+ Ins_Action =>
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (PtrT, Loc),
+ Expression => Relocate_Node (N)),
+ Suppress => All_Checks);
+
+ -- Generate:
+ -- Temp.all := (others => ...);
+
+ Insert_Action
+ (Assoc_Node => N,
+ Ins_Action =>
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc)),
+ Expression =>
+ Get_Simple_Init_Val
+ (Typ => T,
+ N => N,
+ Size => Esize (Component_Type (T)))),
+ Suppress => All_Checks);
+
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ Analyze_And_Resolve (N, PtrT);
+
-- Case of no initialization procedure present
elsif not Has_Non_Null_Base_Init_Proc (T) then
-- Initialize_Scalars --
------------------------
- -- pragma Initialize_Scalars;
+ -- pragma Initialize_Scalars
+ -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
+
+ -- TYPE_VALUE_PAIR ::=
+ -- SCALAR_TYPE => static_EXPRESSION
+
+ -- SCALAR_TYPE :=
+ -- Short_Float
+ -- | Float
+ -- | Long_Float
+ -- | Long_Long_Flat
+ -- | Signed_8
+ -- | Signed_16
+ -- | Signed_32
+ -- | Signed_64
+ -- | Unsigned_8
+ -- | Unsigned_16
+ -- | Unsigned_32
+ -- | Unsigned_64
+
+ when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare
+ Seen : array (Scalar_Id) of Node_Id := (others => Empty);
+ -- This collection holds the individual pairs which specify the
+ -- invalid values of their respective scalar types.
+
+ procedure Analyze_Float_Value
+ (Scal_Typ : Float_Scalar_Id;
+ Val_Expr : Node_Id);
+ -- Analyze a type value pair associated with float type Scal_Typ
+ -- and expression Val_Expr.
+
+ procedure Analyze_Integer_Value
+ (Scal_Typ : Integer_Scalar_Id;
+ Val_Expr : Node_Id);
+ -- Analyze a type value pair associated with integer type Scal_Typ
+ -- and expression Val_Expr.
+
+ procedure Analyze_Type_Value_Pair (Pair : Node_Id);
+ -- Analyze type value pair Pair
- when Pragma_Initialize_Scalars =>
+ -------------------------
+ -- Analyze_Float_Value --
+ -------------------------
+
+ procedure Analyze_Float_Value
+ (Scal_Typ : Float_Scalar_Id;
+ Val_Expr : Node_Id)
+ is
+ begin
+ Analyze_And_Resolve (Val_Expr, Any_Real);
+
+ if Is_OK_Static_Expression (Val_Expr) then
+ Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr));
+
+ else
+ Error_Msg_Name_1 := Scal_Typ;
+ Error_Msg_N ("value for type % must be static", Val_Expr);
+ end if;
+ end Analyze_Float_Value;
+
+ ---------------------------
+ -- Analyze_Integer_Value --
+ ---------------------------
+
+ procedure Analyze_Integer_Value
+ (Scal_Typ : Integer_Scalar_Id;
+ Val_Expr : Node_Id)
+ is
+ begin
+ Analyze_And_Resolve (Val_Expr, Any_Integer);
+
+ if Is_OK_Static_Expression (Val_Expr) then
+ Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr));
+
+ else
+ Error_Msg_Name_1 := Scal_Typ;
+ Error_Msg_N ("value for type % must be static", Val_Expr);
+ end if;
+ end Analyze_Integer_Value;
+
+ -----------------------------
+ -- Analyze_Type_Value_Pair --
+ -----------------------------
+
+ procedure Analyze_Type_Value_Pair (Pair : Node_Id) is
+ Scal_Typ : constant Name_Id := Chars (Pair);
+ Val_Expr : constant Node_Id := Expression (Pair);
+ Prev_Pair : Node_Id;
+
+ begin
+ if Scal_Typ in Scalar_Id then
+ Prev_Pair := Seen (Scal_Typ);
+
+ -- Prevent multiple attempts to set a value for a scalar
+ -- type.
+
+ if Present (Prev_Pair) then
+ Error_Msg_Name_1 := Scal_Typ;
+ Error_Msg_N
+ ("cannot specify multiple invalid values for type %",
+ Pair);
+
+ Error_Msg_Sloc := Sloc (Prev_Pair);
+ Error_Msg_N ("previous value set #", Pair);
+
+ -- Ignore the effects of the pair, but do not halt the
+ -- analysis of the pragma altogether.
+
+ return;
+
+ -- Otherwise capture the first pair for this scalar type
+
+ else
+ Seen (Scal_Typ) := Pair;
+ end if;
+
+ if Scal_Typ in Float_Scalar_Id then
+ Analyze_Float_Value (Scal_Typ, Val_Expr);
+
+ else pragma Assert (Scal_Typ in Integer_Scalar_Id);
+ Analyze_Integer_Value (Scal_Typ, Val_Expr);
+ end if;
+
+ -- Otherwise the scalar family is illegal
+
+ else
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("argument of pragma % must denote valid scalar family",
+ Pair);
+ end if;
+ end Analyze_Type_Value_Pair;
+
+ -- Local variables
+
+ Pairs : constant List_Id := Pragma_Argument_Associations (N);
+ Pair : Node_Id;
+
+ -- Start of processing for Do_Initialize_Scalars
+
+ begin
GNAT_Pragma;
- Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Check_Restriction (No_Initialize_Scalars, N);
+ -- Ignore the effects of the pragma when No_Initialize_Scalars is
+ -- in effect.
+
+ if Restriction_Active (No_Initialize_Scalars) then
+ null;
+
-- Initialize_Scalars creates false positives in CodePeer, and
-- incorrect negative results in GNATprove mode, so ignore this
-- pragma in these modes.
- if not Restriction_Active (No_Initialize_Scalars)
- and then not (CodePeer_Mode or GNATprove_Mode)
- then
+ elsif CodePeer_Mode or GNATprove_Mode then
+ null;
+
+ -- Otherwise analyze the pragma
+
+ else
+ if Present (Pairs) then
+
+ -- Install Standard in order to provide access to primitive
+ -- types in case the expressions contain attributes such as
+ -- Integer'Last.
+
+ Push_Scope (Standard_Standard);
+
+ Pair := First (Pairs);
+ while Present (Pair) loop
+ Analyze_Type_Value_Pair (Pair);
+ Next (Pair);
+ end loop;
+
+ -- Remove Standard
+
+ Pop_Scope;
+ end if;
+
Init_Or_Norm_Scalars := True;
- Initialize_Scalars := True;
+ Initialize_Scalars := True;
end if;
+ end Do_Initialize_Scalars;
-----------------
-- Initializes --
package body Sem_Util is
+ ---------------------------
+ -- Local Data Structures --
+ ---------------------------
+
+ Invalid_Binder_Values : array (Scalar_Id) of Entity_Id := (others => Empty);
+ -- A collection to hold the entities of the variables declared in package
+ -- System.Scalar_Values which describe the invalid values of scalar types.
+
+ Invalid_Binder_Values_Set : Boolean := False;
+ -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
+
+ Invalid_Floats : array (Float_Scalar_Id) of Ureal := (others => No_Ureal);
+ -- A collection to hold the invalid values of float types as specified by
+ -- pragma Initialize_Scalars.
+
+ Invalid_Integers : array (Integer_Scalar_Id) of Uint := (others => No_Uint);
+ -- A collection to hold the invalid values of integer types as specified
+ -- by pragma Initialize_Scalars.
+
-----------------------
-- Local Subprograms --
-----------------------
-- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
-- Loc is the source location, T is the original subtype.
+ procedure Examine_Array_Bounds
+ (Typ : Entity_Id;
+ All_Static : out Boolean;
+ Has_Empty : out Boolean);
+ -- Inspect the index constraints of array type Typ. Flag All_Static is set
+ -- when all ranges are static. Flag Has_Empty is set only when All_Static
+ -- is set and indicates that at least one range is empty.
+
function Has_Enabled_Property
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean;
return Id;
end Entity_Of;
+ --------------------------
+ -- Examine_Array_Bounds --
+ --------------------------
+
+ procedure Examine_Array_Bounds
+ (Typ : Entity_Id;
+ All_Static : out Boolean;
+ Has_Empty : out Boolean)
+ is
+ function Is_OK_Static_Bound (Bound : Node_Id) return Boolean;
+ -- Determine whether bound Bound is a suitable static bound
+
+ ------------------------
+ -- Is_OK_Static_Bound --
+ ------------------------
+
+ function Is_OK_Static_Bound (Bound : Node_Id) return Boolean is
+ begin
+ return
+ not Error_Posted (Bound)
+ and then Is_OK_Static_Expression (Bound);
+ end Is_OK_Static_Bound;
+
+ -- Local variables
+
+ Hi_Bound : Node_Id;
+ Index : Node_Id;
+ Lo_Bound : Node_Id;
+
+ -- Start of processing for Examine_Array_Bounds
+
+ begin
+ -- An unconstrained array type does not have static bounds, and it is
+ -- not known whether they are empty or not.
+
+ if not Is_Constrained (Typ) then
+ All_Static := False;
+ Has_Empty := False;
+
+ -- A string literal has static bounds, and is not empty as long as it
+ -- contains at least one character.
+
+ elsif Ekind (Typ) = E_String_Literal_Subtype then
+ All_Static := True;
+ Has_Empty := String_Literal_Length (Typ) > 0;
+ end if;
+
+ -- Assume that all bounds are static and not empty
+
+ All_Static := True;
+ Has_Empty := False;
+
+ -- Examine each index
+
+ Index := First_Index (Typ);
+ while Present (Index) loop
+ if Is_Discrete_Type (Etype (Index)) then
+ Get_Index_Bounds (Index, Lo_Bound, Hi_Bound);
+
+ if Is_OK_Static_Bound (Lo_Bound)
+ and then
+ Is_OK_Static_Bound (Hi_Bound)
+ then
+ -- The static bounds produce an empty range
+
+ if Is_Null_Range (Lo_Bound, Hi_Bound) then
+ Has_Empty := True;
+ end if;
+
+ -- Otherwise at least one of the bounds is not static
+
+ else
+ All_Static := False;
+ end if;
+
+ -- Otherwise the index is non-discrete, therefore not static
+
+ else
+ All_Static := False;
+ end if;
+
+ Next_Index (Index);
+ end loop;
+ end Examine_Array_Bounds;
+
--------------------------
-- Explain_Limited_Type --
--------------------------
-----------------------------
function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
- Ndims : constant Nat := Number_Dimensions (Typ);
-
- Index : Node_Id;
- Low : Node_Id;
- High : Node_Id;
+ All_Static : Boolean;
+ Dummy : Boolean;
begin
- -- Unconstrained types do not have static bounds
-
- if not Is_Constrained (Typ) then
- return False;
- end if;
-
- -- First treat string literals specially, as the lower bound and length
- -- of string literals are not stored like those of arrays.
-
- -- A string literal always has static bounds
-
- if Ekind (Typ) = E_String_Literal_Subtype then
- return True;
- end if;
-
- -- Treat all dimensions in turn
-
- Index := First_Index (Typ);
- for Indx in 1 .. Ndims loop
-
- -- In case of an illegal index which is not a discrete type, return
- -- that the type is not static.
-
- if not Is_Discrete_Type (Etype (Index))
- or else Etype (Index) = Any_Type
- then
- return False;
- end if;
+ Examine_Array_Bounds (Typ, All_Static, Dummy);
- Get_Index_Bounds (Index, Low, High);
+ return All_Static;
+ end Has_Static_Array_Bounds;
- if Error_Posted (Low) or else Error_Posted (High) then
- return False;
- end if;
+ ---------------------------------------
+ -- Has_Static_Non_Empty_Array_Bounds --
+ ---------------------------------------
- if Is_OK_Static_Expression (Low)
- and then
- Is_OK_Static_Expression (High)
- then
- null;
- else
- return False;
- end if;
+ function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
+ All_Static : Boolean;
+ Has_Empty : Boolean;
- Next (Index);
- end loop;
-
- -- If we fall through the loop, all indexes matched
+ begin
+ Examine_Array_Bounds (Typ, All_Static, Has_Empty);
- return True;
- end Has_Static_Array_Bounds;
+ return All_Static and not Has_Empty;
+ end Has_Static_Non_Empty_Array_Bounds;
----------------
-- Has_Stream --
SPARK_Mode_Pragma := Prag;
end Install_SPARK_Mode;
+ --------------------------
+ -- Invalid_Scalar_Value --
+ --------------------------
+
+ function Invalid_Scalar_Value
+ (Loc : Source_Ptr;
+ Scal_Typ : Scalar_Id) return Node_Id
+ is
+ function Invalid_Binder_Value return Node_Id;
+ -- Return a reference to the corresponding invalid value for type
+ -- Scal_Typ as defined in unit System.Scalar_Values.
+
+ function Invalid_Float_Value return Node_Id;
+ -- Return the invalid value of float type Scal_Typ
+
+ function Invalid_Integer_Value return Node_Id;
+ -- Return the invalid value of integer type Scal_Typ
+
+ procedure Set_Invalid_Binder_Values;
+ -- Set the contents of collection Invalid_Binder_Values
+
+ --------------------------
+ -- Invalid_Binder_Value --
+ --------------------------
+
+ function Invalid_Binder_Value return Node_Id is
+ Val_Id : Entity_Id;
+
+ begin
+ -- Initialize the collection of invalid binder values the first time
+ -- around.
+
+ Set_Invalid_Binder_Values;
+
+ -- Obtain the corresponding variable from System.Scalar_Values which
+ -- holds the invalid value for this type.
+
+ Val_Id := Invalid_Binder_Values (Scal_Typ);
+ pragma Assert (Present (Val_Id));
+
+ return New_Occurrence_Of (Val_Id, Loc);
+ end Invalid_Binder_Value;
+
+ -------------------------
+ -- Invalid_Float_Value --
+ -------------------------
+
+ function Invalid_Float_Value return Node_Id is
+ Value : constant Ureal := Invalid_Floats (Scal_Typ);
+
+ begin
+ -- Pragma Invalid_Scalars did not specify an invalid value for this
+ -- type. Fall back to the value provided by the binder.
+
+ if Value = No_Ureal then
+ return Invalid_Binder_Value;
+ else
+ return Make_Real_Literal (Loc, Realval => Value);
+ end if;
+ end Invalid_Float_Value;
+
+ ---------------------------
+ -- Invalid_Integer_Value --
+ ---------------------------
+
+ function Invalid_Integer_Value return Node_Id is
+ Value : constant Uint := Invalid_Integers (Scal_Typ);
+
+ begin
+ -- Pragma Invalid_Scalars did not specify an invalid value for this
+ -- type. Fall back to the value provided by the binder.
+
+ if Value = No_Uint then
+ return Invalid_Binder_Value;
+ else
+ return Make_Integer_Literal (Loc, Intval => Value);
+ end if;
+ end Invalid_Integer_Value;
+
+ -------------------------------
+ -- Set_Invalid_Binder_Values --
+ -------------------------------
+
+ procedure Set_Invalid_Binder_Values is
+ begin
+ if not Invalid_Binder_Values_Set then
+ Invalid_Binder_Values_Set := True;
+
+ -- Initialize the contents of the collection once since RTE calls
+ -- are not cheap.
+
+ Invalid_Binder_Values :=
+ (Name_Short_Float => RTE (RE_IS_Isf),
+ Name_Float => RTE (RE_IS_Ifl),
+ Name_Long_Float => RTE (RE_IS_Ilf),
+ Name_Long_Long_Float => RTE (RE_IS_Ill),
+ Name_Signed_8 => RTE (RE_IS_Is1),
+ Name_Signed_16 => RTE (RE_IS_Is2),
+ Name_Signed_32 => RTE (RE_IS_Is4),
+ Name_Signed_64 => RTE (RE_IS_Is8),
+ Name_Unsigned_8 => RTE (RE_IS_Iu1),
+ Name_Unsigned_16 => RTE (RE_IS_Iu2),
+ Name_Unsigned_32 => RTE (RE_IS_Iu4),
+ Name_Unsigned_64 => RTE (RE_IS_Iu8));
+ end if;
+ end Set_Invalid_Binder_Values;
+
+ -- Start of processing for Invalid_Scalar_Value
+
+ begin
+ if Scal_Typ in Float_Scalar_Id then
+ return Invalid_Float_Value;
+
+ else pragma Assert (Scal_Typ in Integer_Scalar_Id);
+ return Invalid_Integer_Value;
+ end if;
+ end Invalid_Scalar_Value;
+
-----------------------------
-- Is_Actual_Out_Parameter --
-----------------------------
end if;
end Needs_One_Actual;
+ ---------------------------------
+ -- Needs_Simple_Initialization --
+ ---------------------------------
+
+ function Needs_Simple_Initialization
+ (Typ : Entity_Id;
+ Consider_IS : Boolean := True) return Boolean
+ is
+ Consider_IS_NS : constant Boolean :=
+ Normalize_Scalars or (Initialize_Scalars and Consider_IS);
+
+ begin
+ -- Never need initialization if it is suppressed
+
+ if Initialization_Suppressed (Typ) then
+ return False;
+ end if;
+
+ -- Check for private type, in which case test applies to the underlying
+ -- type of the private type.
+
+ if Is_Private_Type (Typ) then
+ declare
+ RT : constant Entity_Id := Underlying_Type (Typ);
+ begin
+ if Present (RT) then
+ return Needs_Simple_Initialization (RT);
+ else
+ return False;
+ end if;
+ end;
+
+ -- Scalar type with Default_Value aspect requires initialization
+
+ elsif Is_Scalar_Type (Typ) and then Has_Default_Aspect (Typ) then
+ return True;
+
+ -- Cases needing simple initialization are access types, and, if pragma
+ -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
+ -- types.
+
+ elsif Is_Access_Type (Typ)
+ or else (Consider_IS_NS and then (Is_Scalar_Type (Typ)))
+ then
+ return True;
+
+ -- If Initialize/Normalize_Scalars is in effect, string objects also
+ -- need initialization, unless they are created in the course of
+ -- expanding an aggregate (since in the latter case they will be
+ -- filled with appropriate initializing values before they are used).
+
+ elsif Consider_IS_NS
+ and then Is_Standard_String_Type (Typ)
+ and then
+ (not Is_Itype (Typ)
+ or else Nkind (Associated_Node_For_Itype (Typ)) /= N_Aggregate)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Needs_Simple_Initialization;
+
------------------------
-- New_Copy_List_Tree --
------------------------
Set_Entity (N, Val);
end Set_Entity_With_Checks;
+ ------------------------------
+ -- Set_Invalid_Scalar_Value --
+ ------------------------------
+
+ procedure Set_Invalid_Scalar_Value
+ (Scal_Typ : Float_Scalar_Id;
+ Value : Ureal)
+ is
+ Slot : Ureal renames Invalid_Floats (Scal_Typ);
+
+ begin
+ -- Detect an attempt to set a different value for the same scalar type
+
+ pragma Assert (Slot = No_Ureal);
+ Slot := Value;
+ end Set_Invalid_Scalar_Value;
+
+ ------------------------------
+ -- Set_Invalid_Scalar_Value --
+ ------------------------------
+
+ procedure Set_Invalid_Scalar_Value
+ (Scal_Typ : Integer_Scalar_Id;
+ Value : Uint)
+ is
+ Slot : Uint renames Invalid_Integers (Scal_Typ);
+
+ begin
+ -- Detect an attempt to set a different value for the same scalar type
+
+ pragma Assert (Slot = No_Uint);
+ Slot := Value;
+ end Set_Invalid_Scalar_Value;
+
------------------------
-- Set_Name_Entity_Id --
------------------------
function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean;
-- Return whether an array type has static bounds
+ function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean;
+ -- Determine whether array type Typ has static non-empty bounds
+
function Has_Stream (T : Entity_Id) return Boolean;
-- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the
-- case of a composite type, has a component for which this predicate is
procedure Install_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id);
-- Establish the SPARK_Mode and SPARK_Mode_Pragma currently in effect
+ function Invalid_Scalar_Value
+ (Loc : Source_Ptr;
+ Scal_Typ : Scalar_Id) return Node_Id;
+ -- Obtain the invalid value for scalar type Scal_Typ as either specified by
+ -- pragma Initialize_Scalars or by the binder. Return an expression created
+ -- at source location Loc, which denotes the invalid value.
+
function Is_Actual_Out_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter of out mode in a subprogram call
-- syntactic ambiguity that results from an indexing of a function call
-- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y).
+ function Needs_Simple_Initialization
+ (Typ : Entity_Id;
+ Consider_IS : Boolean := True) return Boolean;
+ -- Certain types need initialization even though there is no specific
+ -- initialization routine:
+ -- Access types (which need initializing to null)
+ -- All scalar types if Normalize_Scalars mode set
+ -- Descendants of standard string types if Normalize_Scalars mode set
+ -- Scalar types having a Default_Value attribute
+ -- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
+ -- set to False, but if Consider_IS is set to True, then the cases above
+ -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
+
function New_Copy_List_Tree (List : List_Id) return List_Id;
-- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined
-- below. As for New_Copy_Tree, it is illegal to attempt to copy extended
-- If restriction No_Implementation_Identifiers is set, then it checks
-- that the entity is not implementation defined.
+ procedure Set_Invalid_Scalar_Value
+ (Scal_Typ : Float_Scalar_Id;
+ Value : Ureal);
+ -- Associate invalid value Value with scalar type Scal_Typ as specified by
+ -- pragma Initialize_Scalars.
+
+ procedure Set_Invalid_Scalar_Value
+ (Scal_Typ : Integer_Scalar_Id;
+ Value : Uint);
+ -- Associate invalid value Value with scalar type Scal_Typ as specified by
+ -- pragma Initialize_Scalars.
+
procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id);
pragma Inline (Set_Name_Entity_Id);
-- Sets the Entity_Id value associated with the given name, which is the
Name_Sequential : constant Name_Id := N + $;
Last_Partition_Elaboration_Policy_Name : constant Name_Id := N + $;
+ -- Names of recognized scalar families for pragma Initialize_Scalars
+
+ Name_Short_Float : constant Name_Id := N + $; -- GNAT
+ Name_Float : constant Name_Id := N + $; -- GNAT
+ Name_Long_Float : constant Name_Id := N + $; -- GNAT
+ Name_Long_Long_Float : constant Name_Id := N + $; -- GNAT
+ Name_Signed_8 : constant Name_Id := N + $; -- GNAT
+ Name_Signed_16 : constant Name_Id := N + $; -- GNAT
+ Name_Signed_32 : constant Name_Id := N + $; -- GNAT
+ Name_Signed_64 : constant Name_Id := N + $; -- GNAT
+ Name_Unsigned_8 : constant Name_Id := N + $; -- GNAT
+ Name_Unsigned_16 : constant Name_Id := N + $; -- GNAT
+ Name_Unsigned_32 : constant Name_Id := N + $; -- GNAT
+ Name_Unsigned_64 : constant Name_Id := N + $; -- GNAT
+
+ subtype Scalar_Id is Name_Id range
+ Name_Short_Float .. Name_Unsigned_64;
+
+ subtype Float_Scalar_Id is Name_Id range
+ Name_Short_Float .. Name_Long_Long_Float;
+
+ subtype Integer_Scalar_Id is Name_Id range
+ Name_Signed_8 .. Name_Unsigned_64;
+
-- Names of recognized checks for pragma Suppress
-- Note: the name Atomic_Synchronization can only be specified internally
projects / gcc.git / commitdiff