+2018-05-28 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch3.adb
+ (Build_Initialization_Call): Add logic to pass the appropriate actual to match
+ new formal.
+ (Init_Formals): Add new formal *_skip_null_excluding_check
+ * exp_util.adb, exp_util.ads
+ (Enclosing_Init_Proc): Added to fetch the enclosing Init_Proc from the current
+ scope.
+ (Inside_Init_Proc): Refactored to use Enclosing_Init_Proc
+ (Needs_Conditional_Null_Excluding_Check): Added to factorize the predicate
+ used to determine how to generate an Init_Proc for a given type.
+ (Needs_Constant_Address): Minor reformatting
+ * sem_res.adb
+ (Resolve_Null): Add logic to generate a conditional check in certain cases
+
2018-05-28 Hristian Kirtchev <kirtchev@adacore.com>
* exp_aggr.adb, gnatlink.adb, sem_ch6.adb, sem_res.adb, sem_util.adb:
Decl := Empty;
end if;
+ -- Handle the optionally generated formal *_skip_null_excluding_checks
+
+ if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) then
+
+ -- Look at the associated node for the object we are referencing and
+ -- verify that we are expanding a call to an Init_Proc for an
+ -- internally generated object declaration before passing True and
+ -- skipping the relevant checks.
+
+ if Nkind (Id_Ref) in N_Has_Entity
+ and then Comes_From_Source (Associated_Node (Id_Ref))
+ then
+ Append_To (Args,
+ New_Occurrence_Of (Standard_True, Loc));
+
+ -- Otherwise, we pass False to perform null excluding checks
+
+ else
+ Append_To (Args,
+ New_Occurrence_Of (Standard_False, Loc));
+ end if;
+ end if;
+
-- Add discriminant values if discriminants are present
if Has_Discriminants (Full_Init_Type) then
Parameter_Type => New_Occurrence_Of (Standard_String, Loc)));
end if;
+ -- Due to certain edge cases such as arrays with null excluding
+ -- components being built with the secondary stack it becomes necessary
+ -- to add a formal to the Init_Proc which controls whether we raise
+ -- constraint errors on generated calls for internal object
+ -- declarations.
+
+ if Needs_Conditional_Null_Excluding_Check (Typ) then
+ Append_To (Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars
+ (Component_Type (Typ)), "_skip_null_excluding_check")),
+ In_Present => True,
+ Parameter_Type =>
+ New_Occurrence_Of (Standard_Boolean, Loc)));
+ end if;
+
return Formals;
exception
return New_Exp;
end Duplicate_Subexpr_Move_Checks;
+ -------------------------
+ -- Enclosing_Init_Proc --
+ -------------------------
+
+ function Enclosing_Init_Proc return Entity_Id is
+ S : Entity_Id;
+
+ begin
+ S := Current_Scope;
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Init_Proc (S) then
+ return S;
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+
+ return Empty;
+ end Enclosing_Init_Proc;
+
--------------------
-- Ensure_Defined --
--------------------
----------------------
function Inside_Init_Proc return Boolean is
- S : Entity_Id;
+ Proc : constant Entity_Id := Enclosing_Init_Proc;
begin
- S := Current_Scope;
- while Present (S) and then S /= Standard_Standard loop
- if Is_Init_Proc (S) then
- return True;
- else
- S := Scope (S);
- end if;
- end loop;
-
- return False;
+ return Proc /= Empty;
end Inside_Init_Proc;
----------------------------
end if;
end May_Generate_Large_Temp;
+ --------------------------------------------
+ -- Needs_Conditional_Null_Excluding_Check --
+ --------------------------------------------
+
+ function Needs_Conditional_Null_Excluding_Check
+ (Typ : Entity_Id) return Boolean
+ is
+ begin
+ return Is_Array_Type (Typ)
+ and then Can_Never_Be_Null (Component_Type (Typ));
+ end Needs_Conditional_Null_Excluding_Check;
+
+ ----------------------------
+ -- Needs_Constant_Address --
+ ----------------------------
+
+ function Needs_Constant_Address
+ (Decl : Node_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ begin
+ -- If we have no initialization of any kind, then we don't need to place
+ -- any restrictions on the address clause, because the object will be
+ -- elaborated after the address clause is evaluated. This happens if the
+ -- declaration has no initial expression, or the type has no implicit
+ -- initialization, or the object is imported.
+
+ -- The same holds for all initialized scalar types and all access types.
+ -- Packed bit arrays of size up to 64 are represented using a modular
+ -- type with an initialization (to zero) and can be processed like other
+ -- initialized scalar types.
+
+ -- If the type is controlled, code to attach the object to a
+ -- finalization chain is generated at the point of declaration, and
+ -- therefore the elaboration of the object cannot be delayed: the
+ -- address expression must be a constant.
+
+ if No (Expression (Decl))
+ and then not Needs_Finalization (Typ)
+ and then
+ (not Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Imported (Defining_Identifier (Decl)))
+ then
+ return False;
+
+ elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
+ or else Is_Access_Type (Typ)
+ or else
+ (Is_Bit_Packed_Array (Typ)
+ and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
+ then
+ return False;
+
+ else
+
+ -- Otherwise, we require the address clause to be constant because
+ -- the call to the initialization procedure (or the attach code) has
+ -- to happen at the point of the declaration.
+
+ -- Actually the IP call has been moved to the freeze actions anyway,
+ -- so maybe we can relax this restriction???
+
+ return True;
+ end if;
+ end Needs_Constant_Address;
+
------------------------
-- Needs_Finalization --
------------------------
end if;
end Needs_Finalization;
- ----------------------------
- -- Needs_Constant_Address --
- ----------------------------
-
- function Needs_Constant_Address
- (Decl : Node_Id;
- Typ : Entity_Id) return Boolean
- is
- begin
- -- If we have no initialization of any kind, then we don't need to place
- -- any restrictions on the address clause, because the object will be
- -- elaborated after the address clause is evaluated. This happens if the
- -- declaration has no initial expression, or the type has no implicit
- -- initialization, or the object is imported.
-
- -- The same holds for all initialized scalar types and all access types.
- -- Packed bit arrays of size up to 64 are represented using a modular
- -- type with an initialization (to zero) and can be processed like other
- -- initialized scalar types.
-
- -- If the type is controlled, code to attach the object to a
- -- finalization chain is generated at the point of declaration, and
- -- therefore the elaboration of the object cannot be delayed: the
- -- address expression must be a constant.
-
- if No (Expression (Decl))
- and then not Needs_Finalization (Typ)
- and then
- (not Has_Non_Null_Base_Init_Proc (Typ)
- or else Is_Imported (Defining_Identifier (Decl)))
- then
- return False;
-
- elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
- or else Is_Access_Type (Typ)
- or else
- (Is_Bit_Packed_Array (Typ)
- and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
- then
- return False;
-
- else
-
- -- Otherwise, we require the address clause to be constant because
- -- the call to the initialization procedure (or the attach code) has
- -- to happen at the point of the declaration.
-
- -- Actually the IP call has been moved to the freeze actions anyway,
- -- so maybe we can relax this restriction???
-
- return True;
- end if;
- end Needs_Constant_Address;
-
----------------------------
-- New_Class_Wide_Subtype --
----------------------------
-- elaborated before the original expression Exp, so that there is no need
-- to repeat the checks.
+ function Enclosing_Init_Proc return Entity_Id;
+ -- Obtain the entity associated with the enclosing type Init_Proc by
+ -- examining the current scope. If not inside an Init_Proc at the point of
+ -- call Empty will be returned.
+
procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id);
-- This procedure ensures that type referenced by Typ is defined. For the
-- case of a type other than an Itype, nothing needs to be done, since
-- caller has to check whether stack checking is actually enabled in order
-- to guide the expansion (typically of a function call).
+ function Needs_Conditional_Null_Excluding_Check
+ (Typ : Entity_Id) return Boolean;
+ -- Check if a type meets certain properties that require it to have a
+ -- conditional null-excluding check within its Init_Proc.
+
function Needs_Constant_Address
(Decl : Node_Id;
Typ : Entity_Id) return Boolean;
end if;
-- Ada 2005 (AI-231): Generate the null-excluding check in case of
- -- assignment to a null-excluding object
+ -- assignment to a null-excluding object.
if Ada_Version >= Ada_2005
and then Can_Never_Be_Null (Typ)
and then Nkind (Parent (N)) = N_Assignment_Statement
then
- if not Inside_Init_Proc then
+ if Inside_Init_Proc then
+
+ -- Decide whether to generate an if_statement around our
+ -- null-excluding check to avoid them on certain internal object
+ -- declarations by looking at the type the current Init_Proc
+ -- belongs to.
+
+ -- Generate:
+ -- if T1b_skip_null_excluding_check then
+ -- [constraint_error "access check failed"]
+ -- end if;
+
+ if Needs_Conditional_Null_Excluding_Check
+ (Etype (First_Formal (Enclosing_Init_Proc)))
+ then
+ Insert_Action (N,
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Identifier (Loc,
+ New_External_Name
+ (Chars (Typ), "_skip_null_excluding_check")),
+ Then_Statements =>
+ New_List (
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Access_Check_Failed))));
+
+ -- Otherwise, simply create the check
+
+ else
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Access_Check_Failed));
+ end if;
+ else
Insert_Action
(Compile_Time_Constraint_Error (N,
"(Ada 2005) null not allowed in null-excluding objects??"),
Make_Raise_Constraint_Error (Loc,
Reason => CE_Access_Check_Failed));
- else
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Reason => CE_Access_Check_Failed));
end if;
end if;
+2018-05-28 Justin Squirek <squirek@adacore.com>
+
+ * gnat.dg/array31.adb: New testcase.
+
2018-05-28 Justin Squirek <squirek@adacore.com>
* gnat.dg/warn15-core-main.adb, gnat.dg/warn15-core.ads,
--- /dev/null
+-- { dg-do run }
+
+procedure Array31 is
+
+ type Boolean_Access is access Boolean;
+
+ type Boolean_Access_Array is
+ array (Positive range <>) of not null Boolean_Access;
+
+ X : constant Boolean_Access_Array := (1 => new Boolean'(False));
+ Y : constant Boolean_Access_Array := X & X;
+
+begin
+ null;
+end;
projects / gcc.git / commitdiff