Commit a5d83d61 by Arnaud Charlet

[multiple changes]

2010-06-14  Robert Dewar  <dewar@adacore.com>

	* opt.ads, sem.adb, sem_elab.adb: Minor reformatting

2010-06-14  Robert Dewar  <dewar@adacore.com>

	* exp_aggr.adb (Has_Address_Clause): Moved to Exp_Util, and there it
	is renamed as Has_Following_Address_Clause.
	* exp_ch3.adb (Needs_Simple_Initialization): Add Consider_IS argument
	to allow the caller to avoid Initialize_Scalars having an effect.
	(Expand_N_Object_Declaration): Do not do Initialize_Scalars stuff for
	scalars with an address clause specified.
	* exp_ch3.ads (Needs_Simple_Initialization): Add Consider_IS argument
	to allow the caller to avoid Initialize_Scalars having an effect.
	* exp_util.adb (Has_Following_Address_Clause): Moved here from Exp_Aggr
	(where it was called Has_Address_Clause).
	* exp_util.ads (Has_Following_Address_Clause): Moved here from Exp_Aggr
	(where it was called Has_Address_Clause).
	* freeze.adb (Warn_Overlay): Suppress message about overlaying causing
	problems for Initialize_Scalars (since we no longer initialize objects
	with an address clause.

2010-06-14  Robert Dewar  <dewar@adacore.com>

	* exp_prag.adb (Expand_Pragma_Check): Set Loc of generated code from
	condition.

2010-06-14  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Debug_Info_Needed
	on the entity of an implicitly generated postcondition procedure.

2010-06-14  Thomas Quinot  <quinot@adacore.com>

	* sem_ch7.adb (Preserve_Full_Attributes): Propagate
	Discriminant_Constraint elist from full view to private view.

From-SVN: r160720
parent be8e26ba
2010-06-14 Robert Dewar <dewar@adacore.com> 2010-06-14 Robert Dewar <dewar@adacore.com>
* opt.ads, sem.adb, sem_elab.adb: Minor reformatting
2010-06-14 Robert Dewar <dewar@adacore.com>
* exp_aggr.adb (Has_Address_Clause): Moved to Exp_Util, and there it
is renamed as Has_Following_Address_Clause.
* exp_ch3.adb (Needs_Simple_Initialization): Add Consider_IS argument
to allow the caller to avoid Initialize_Scalars having an effect.
(Expand_N_Object_Declaration): Do not do Initialize_Scalars stuff for
scalars with an address clause specified.
* exp_ch3.ads (Needs_Simple_Initialization): Add Consider_IS argument
to allow the caller to avoid Initialize_Scalars having an effect.
* exp_util.adb (Has_Following_Address_Clause): Moved here from Exp_Aggr
(where it was called Has_Address_Clause).
* exp_util.ads (Has_Following_Address_Clause): Moved here from Exp_Aggr
(where it was called Has_Address_Clause).
* freeze.adb (Warn_Overlay): Suppress message about overlaying causing
problems for Initialize_Scalars (since we no longer initialize objects
with an address clause.
2010-06-14 Robert Dewar <dewar@adacore.com>
* exp_prag.adb (Expand_Pragma_Check): Set Loc of generated code from
condition.
2010-06-14 Gary Dismukes <dismukes@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Debug_Info_Needed
on the entity of an implicitly generated postcondition procedure.
2010-06-14 Thomas Quinot <quinot@adacore.com>
* sem_ch7.adb (Preserve_Full_Attributes): Propagate
Discriminant_Constraint elist from full view to private view.
2010-06-14 Robert Dewar <dewar@adacore.com>
* sem_res.adb: Minor reformatting * sem_res.adb: Minor reformatting
2010-06-14 Ed Schonberg <schonberg@adacore.com> 2010-06-14 Ed Schonberg <schonberg@adacore.com>
......
...@@ -4122,12 +4122,6 @@ package body Exp_Aggr is ...@@ -4122,12 +4122,6 @@ package body Exp_Aggr is
-- array sub-aggregate we start the computation from. Dim is the -- array sub-aggregate we start the computation from. Dim is the
-- dimension corresponding to the sub-aggregate. -- dimension corresponding to the sub-aggregate.
function Has_Address_Clause (D : Node_Id) return Boolean;
-- If the aggregate is the expression in an object declaration, it
-- cannot be expanded in place. This function does a lookahead in the
-- current declarative part to find an address clause for the object
-- being declared.
function In_Place_Assign_OK return Boolean; function In_Place_Assign_OK return Boolean;
-- Simple predicate to determine whether an aggregate assignment can -- Simple predicate to determine whether an aggregate assignment can
-- be done in place, because none of the new values can depend on the -- be done in place, because none of the new values can depend on the
...@@ -4435,35 +4429,6 @@ package body Exp_Aggr is ...@@ -4435,35 +4429,6 @@ package body Exp_Aggr is
end Compute_Others_Present; end Compute_Others_Present;
------------------------ ------------------------
-- Has_Address_Clause --
------------------------
function Has_Address_Clause (D : Node_Id) return Boolean is
Id : constant Entity_Id := Defining_Identifier (D);
Decl : Node_Id;
begin
Decl := Next (D);
while Present (Decl) loop
if Nkind (Decl) = N_At_Clause
and then Chars (Identifier (Decl)) = Chars (Id)
then
return True;
elsif Nkind (Decl) = N_Attribute_Definition_Clause
and then Chars (Decl) = Name_Address
and then Chars (Name (Decl)) = Chars (Id)
then
return True;
end if;
Next (Decl);
end loop;
return False;
end Has_Address_Clause;
------------------------
-- In_Place_Assign_OK -- -- In_Place_Assign_OK --
------------------------ ------------------------
...@@ -5162,6 +5127,8 @@ package body Exp_Aggr is ...@@ -5162,6 +5127,8 @@ package body Exp_Aggr is
Build_Activation_Chain_Entity (N); Build_Activation_Chain_Entity (N);
end if; end if;
-- Should document these individual tests ???
if not Has_Default_Init_Comps (N) if not Has_Default_Init_Comps (N)
and then Comes_From_Source (Parent (N)) and then Comes_From_Source (Parent (N))
and then Nkind (Parent (N)) = N_Object_Declaration and then Nkind (Parent (N)) = N_Object_Declaration
...@@ -5170,7 +5137,13 @@ package body Exp_Aggr is ...@@ -5170,7 +5137,13 @@ package body Exp_Aggr is
and then N = Expression (Parent (N)) and then N = Expression (Parent (N))
and then not Is_Bit_Packed_Array (Typ) and then not Is_Bit_Packed_Array (Typ)
and then not Has_Controlled_Component (Typ) and then not Has_Controlled_Component (Typ)
and then not Has_Address_Clause (Parent (N))
-- If the aggregate is the expression in an object declaration, it
-- cannot be expanded in place. Lookahead in the current declarative
-- part to find an address clause for the object being declared. If
-- one is present, we cannot build in place. Unclear comment???
and then not Has_Following_Address_Clause (Parent (N))
then then
Tmp := Defining_Identifier (Parent (N)); Tmp := Defining_Identifier (Parent (N));
Set_No_Initialization (Parent (N)); Set_No_Initialization (Parent (N));
......
...@@ -4466,7 +4466,10 @@ package body Exp_Ch3 is ...@@ -4466,7 +4466,10 @@ package body Exp_Ch3 is
-- it will be assigned subsequently. In particular, there is no point -- it will be assigned subsequently. In particular, there is no point
-- in applying Initialize_Scalars to such a temporary. -- in applying Initialize_Scalars to such a temporary.
elsif Needs_Simple_Initialization (Typ) elsif Needs_Simple_Initialization
(Typ,
Initialize_Scalars
and then not Has_Following_Address_Clause (N))
and then not Is_Internal (Def_Id) and then not Is_Internal (Def_Id)
and then not Has_Init_Expression (N) and then not Has_Init_Expression (N)
then then
...@@ -8145,7 +8148,14 @@ package body Exp_Ch3 is ...@@ -8145,7 +8148,14 @@ package body Exp_Ch3 is
-- Needs_Simple_Initialization -- -- Needs_Simple_Initialization --
--------------------------------- ---------------------------------
function Needs_Simple_Initialization (T : Entity_Id) return Boolean is function Needs_Simple_Initialization
(T : Entity_Id;
Consider_IS : Boolean := True) return Boolean
is
Consider_IS_NS : constant Boolean :=
Normalize_Scalars
or (Initialize_Scalars and Consider_IS);
begin begin
-- Check for private type, in which case test applies to the underlying -- Check for private type, in which case test applies to the underlying
-- type of the private type. -- type of the private type.
...@@ -8167,7 +8177,7 @@ package body Exp_Ch3 is ...@@ -8167,7 +8177,7 @@ package body Exp_Ch3 is
-- types. -- types.
elsif Is_Access_Type (T) elsif Is_Access_Type (T)
or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) or else (Consider_IS_NS and then (Is_Scalar_Type (T)))
then then
return True; return True;
...@@ -8176,7 +8186,7 @@ package body Exp_Ch3 is ...@@ -8176,7 +8186,7 @@ package body Exp_Ch3 is
-- expanding an aggregate (since in the latter case they will be -- expanding an aggregate (since in the latter case they will be
-- filled with appropriate initializing values before they are used). -- filled with appropriate initializing values before they are used).
elsif Init_Or_Norm_Scalars elsif Consider_IS_NS
and then and then
(Root_Type (T) = Standard_String (Root_Type (T) = Standard_String
or else Root_Type (T) = Standard_Wide_String or else Root_Type (T) = Standard_Wide_String
......
...@@ -126,14 +126,18 @@ package Exp_Ch3 is ...@@ -126,14 +126,18 @@ package Exp_Ch3 is
-- then tags components located at variable positions of Target are -- then tags components located at variable positions of Target are
-- initialized. -- initialized.
function Needs_Simple_Initialization (T : Entity_Id) return Boolean; function Needs_Simple_Initialization
(T : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
-- Certain types need initialization even though there is no specific -- Certain types need initialization even though there is no specific
-- initialization routine. In this category are access types (which need -- initialization routine. In this category are access types (which need
-- initializing to null), packed array types whose implementation is a -- initializing to null), packed array types whose implementation is a
-- modular type, and all scalar types if Normalize_Scalars is set, as well -- modular type, and all scalar types if Normalize_Scalars is set, as well
-- as private types whose underlying type is present and meets any of these -- as private types whose underlying type is present and meets any of these
-- criteria. Finally, descendants of String and Wide_String also need -- criteria. Finally, descendants of String and Wide_String also need
-- initialization in Initialize/Normalize_Scalars mode. -- initialization in Initialize/Normalize_Scalars mode. Consider_IS is
-- normally True. If it is False, the Initialize_Scalars is not considered
-- in determining whether simple initialization is needed.
function Get_Simple_Init_Val function Get_Simple_Init_Val
(T : Entity_Id; (T : Entity_Id;
......
...@@ -269,8 +269,8 @@ package body Exp_Prag is ...@@ -269,8 +269,8 @@ package body Exp_Prag is
-------------------------- --------------------------
procedure Expand_Pragma_Check (N : Node_Id) is procedure Expand_Pragma_Check (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := Arg2 (N); Cond : constant Node_Id := Arg2 (N);
Loc : constant Source_Ptr := Sloc (Cond);
Nam : constant Name_Id := Chars (Arg1 (N)); Nam : constant Name_Id := Chars (Arg1 (N));
Msg : Node_Id; Msg : Node_Id;
......
...@@ -2143,6 +2143,37 @@ package body Exp_Util is ...@@ -2143,6 +2143,37 @@ package body Exp_Util is
return False; return False;
end Has_Controlled_Coextensions; end Has_Controlled_Coextensions;
------------------------
-- Has_Address_Clause --
------------------------
-- Should this function check the private part in a package ???
function Has_Following_Address_Clause (D : Node_Id) return Boolean is
Id : constant Entity_Id := Defining_Identifier (D);
Decl : Node_Id;
begin
Decl := Next (D);
while Present (Decl) loop
if Nkind (Decl) = N_At_Clause
and then Chars (Identifier (Decl)) = Chars (Id)
then
return True;
elsif Nkind (Decl) = N_Attribute_Definition_Clause
and then Chars (Decl) = Name_Address
and then Chars (Name (Decl)) = Chars (Id)
then
return True;
end if;
Next (Decl);
end loop;
return False;
end Has_Following_Address_Clause;
-------------------- --------------------
-- Homonym_Number -- -- Homonym_Number --
-------------------- --------------------
......
...@@ -444,6 +444,11 @@ package Exp_Util is ...@@ -444,6 +444,11 @@ package Exp_Util is
-- Determine whether a record type has anonymous access discriminants with -- Determine whether a record type has anonymous access discriminants with
-- a controlled designated type. -- a controlled designated type.
function Has_Following_Address_Clause (D : Node_Id) return Boolean;
-- D is the node for an object declaration. This function searches the
-- current declarative part to look for an address clause for the object
-- being declared, and returns True if one is found.
function Homonym_Number (Subp : Entity_Id) return Nat; function Homonym_Number (Subp : Entity_Id) return Nat;
-- Here subp is the entity for a subprogram. This routine returns the -- Here subp is the entity for a subprogram. This routine returns the
-- homonym number used to disambiguate overloaded subprograms in the same -- homonym number used to disambiguate overloaded subprograms in the same
......
...@@ -5659,16 +5659,18 @@ package body Freeze is ...@@ -5659,16 +5659,18 @@ package body Freeze is
-- We only give the warning for non-imported entities of a type for -- We only give the warning for non-imported entities of a type for
-- which a non-null base init proc is defined, or for objects of access -- which a non-null base init proc is defined, or for objects of access
-- types with implicit null initialization, or when Initialize_Scalars -- types with implicit null initialization, or when Normalize_Scalars
-- applies and the type is scalar or a string type (the latter being -- applies and the type is scalar or a string type (the latter being
-- tested for because predefined String types are initialized by inline -- tested for because predefined String types are initialized by inline
-- code rather than by an init_proc). -- code rather than by an init_proc). Note that we do not give the
-- warning for Initialize_Scalars, since we suppressed initialization
-- in this case.
if Present (Expr) if Present (Expr)
and then not Is_Imported (Ent) and then not Is_Imported (Ent)
and then (Has_Non_Null_Base_Init_Proc (Typ) and then (Has_Non_Null_Base_Init_Proc (Typ)
or else Is_Access_Type (Typ) or else Is_Access_Type (Typ)
or else (Init_Or_Norm_Scalars or else (Normalize_Scalars
and then (Is_Scalar_Type (Typ) and then (Is_Scalar_Type (Typ)
or else Is_String_Type (Typ)))) or else Is_String_Type (Typ))))
then then
......
...@@ -183,8 +183,8 @@ package Opt is ...@@ -183,8 +183,8 @@ package Opt is
Bind_For_Library : Boolean := False; Bind_For_Library : Boolean := False;
-- GNATBIND -- GNATBIND
-- Set to True if the binder needs to generate a file designed for -- Set to True if the binder needs to generate a file designed for building
-- building a library. May be set to True by Gnatbind.Scan_Bind_Arg. -- a library. May be set to True by Gnatbind.Scan_Bind_Arg.
Bind_Only : Boolean := False; Bind_Only : Boolean := False;
-- GNATMAKE, GPRMAKE, GPRBUILD -- GNATMAKE, GPRMAKE, GPRBUILD
......
...@@ -1936,7 +1936,6 @@ package body Sem is ...@@ -1936,7 +1936,6 @@ package body Sem is
if Is_Child_Unit (Cunit_Entity (Main_Unit)) then if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
Child := Cunit_Entity (Main_Unit); Child := Cunit_Entity (Main_Unit);
while Is_Child_Unit (Child) loop while Is_Child_Unit (Child) loop
Parent_CU := Parent_CU :=
Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child))); Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
......
...@@ -2030,10 +2030,13 @@ package body Sem_Ch6 is ...@@ -2030,10 +2030,13 @@ package body Sem_Ch6 is
end if; end if;
end if; end if;
-- Mark presence of postcondition proc in current scope -- Mark presence of postcondition procedure in current scope and mark
-- the procedure itself as needing debug info. The latter is important
-- when analyzing decision coverage (for example, for MC/DC coverage).
if Chars (Body_Id) = Name_uPostconditions then if Chars (Body_Id) = Name_uPostconditions then
Set_Has_Postconditions (Current_Scope); Set_Has_Postconditions (Current_Scope);
Set_Debug_Info_Needed (Body_Id);
end if; end if;
-- Place subprogram on scope stack, and make formals visible. If there -- Place subprogram on scope stack, and make formals visible. If there
......
...@@ -2032,6 +2032,10 @@ package body Sem_Ch7 is ...@@ -2032,6 +2032,10 @@ package body Sem_Ch7 is
end if; end if;
Set_Has_Discriminants (Priv, Has_Discriminants (Full)); Set_Has_Discriminants (Priv, Has_Discriminants (Full));
if Has_Discriminants (Full) then
Set_Discriminant_Constraint (Priv,
Discriminant_Constraint (Full));
end if;
end if; end if;
end Preserve_Full_Attributes; end Preserve_Full_Attributes;
......
...@@ -1892,7 +1892,7 @@ package body Sem_Elab is ...@@ -1892,7 +1892,7 @@ package body Sem_Elab is
elsif In_Task_Activation then elsif In_Task_Activation then
return; return;
-- Nothing to do if call is within a generic unit. -- Nothing to do if call is within a generic unit
elsif Inside_A_Generic then elsif Inside_A_Generic then
return; return;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment