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

[multiple changes] 

2011-09-02  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb, sem_ch10.adb, sem_attr.adb, s-htable.adb,
	g-comlin.adb, g-comlin.ads, lib-xref-alfa.adb, lib-xref.adb: Minor
	reformatting.

2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb: (Set_Anonymous_Type): Associate the itype of an
	inherited component with the enclosing derived type. Code reformatting.

2011-09-02  Gary Dismukes  <dismukes@adacore.com>

	* checks.adb: (Determine_Range): Add test of OK1 to prevent the early
	return done when overflow checks are enabled, since comparisons against
	Lor and Hir should not be done when OK1 is False.

2011-09-02  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
	Add new formal Master_Exp. When present, add that expression to the
	call as an extra actual.
	(Make_Build_In_Place_Call_In_Object_Declaration): Add variable
	Fmaster_Actual and in the case of a BIP call initializing a return
	object of an enclosing BIP function set it to a
	new reference to the implicit finalization master
	formal of the enclosing function. Fmaster_Actual is
	then passed to the new formal Master_Exp on the call to
	Add_Finalization_Master_Actual_To_Build_ In_Place_Call. Move
	initializations of Enclosing_Func to its declaration.

2011-09-02  Thomas Quinot  <quinot@adacore.com>

	* csets.ads: Minor reformatting

2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_aggr.adb: (Get_Constraint_Association): Add code to retrieve
	the full view of a private type coming from an instantiation.
	* exp_ch4.adb: (Current_Anonymous_Master): Reimplement the search
	loop to iterate over the declarations rather than use the
	First_Entity / Next_Entity scheme.

From-SVN: r178438
This commit is contained in:
Arnaud Charlet 2011-09-02 09:42:02 +02:00
parent ed32b82e77
commit 2c17ca0a2f
15 changed files with 193 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gcc/ada/ChangeLog
View File

@ -1,3 +1,46 @@
2011-09-02 Robert Dewar <dewar@adacore.com>
* exp_util.adb, sem_ch10.adb, sem_attr.adb, s-htable.adb,
g-comlin.adb, g-comlin.ads, lib-xref-alfa.adb, lib-xref.adb: Minor
reformatting.
2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb: (Set_Anonymous_Type): Associate the itype of an
inherited component with the enclosing derived type. Code reformatting.
2011-09-02 Gary Dismukes <dismukes@adacore.com>
* checks.adb: (Determine_Range): Add test of OK1 to prevent the early
return done when overflow checks are enabled, since comparisons against
Lor and Hir should not be done when OK1 is False.
2011-09-02 Gary Dismukes <dismukes@adacore.com>
* exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
Add new formal Master_Exp. When present, add that expression to the
call as an extra actual.
(Make_Build_In_Place_Call_In_Object_Declaration): Add variable
Fmaster_Actual and in the case of a BIP call initializing a return
object of an enclosing BIP function set it to a
new reference to the implicit finalization master
formal of the enclosing function. Fmaster_Actual is
then passed to the new formal Master_Exp on the call to
Add_Finalization_Master_Actual_To_Build_ In_Place_Call. Move
initializations of Enclosing_Func to its declaration.
2011-09-02 Thomas Quinot <quinot@adacore.com>
* csets.ads: Minor reformatting
2011-09-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_aggr.adb: (Get_Constraint_Association): Add code to retrieve
the full view of a private type coming from an instantiation.
* exp_ch4.adb: (Current_Anonymous_Master): Reimplement the search
loop to iterate over the declarations rather than use the
First_Entity / Next_Entity scheme.
2011-09-02 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb: (Analyze_Attribute, case 'Range): when expanding

5
gcc/ada/checks.adb
View File

@ -3479,10 +3479,11 @@ package body Checks is
-- to restrict the possible range of results.
-- If one of the computed bounds is outside the range of the base type,
-- the expression may raise an exception and we better indicate that
-- the expression may raise an exception and we had better indicate that
-- the evaluation has failed, at least if checks are enabled.
if Enable_Overflow_Checks
if OK1
and then Enable_Overflow_Checks
and then not Is_Entity_Name (N)
and then (Lor < Lo or else Hir > Hi)
then

4
gcc/ada/csets.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -90,7 +90,7 @@ package Csets is
-- This table has True entries for all characters that can legally appear
-- in identifiers, including digits, the underline character, all letters
-- including upper and lower case and extended letters (as controlled by
-- the setting of Opt.Identifier_Character_Set, left bracket for brackets
-- the setting of Opt.Identifier_Character_Set), left bracket for brackets
-- notation wide characters and also ESC if wide characters are permitted
-- in identifiers using escape sequences starting with ESC.

17
gcc/ada/exp_aggr.adb
View File

@ -1984,10 +1984,23 @@ package body Exp_Aggr is
--------------------------------
function Get_Constraint_Association (T : Entity_Id) return Node_Id is
Typ_Def : constant Node_Id := Type_Definition (Parent (T));
Indic : constant Node_Id := Subtype_Indication (Typ_Def);
Indic : Node_Id;
Typ : Entity_Id;
begin
Typ := T;
-- Handle private types in instances
if In_Instance
and then Is_Private_Type (Typ)
and then Present (Full_View (Typ))
then
Typ := Full_View (Typ);
end if;
Indic := Subtype_Indication (Type_Definition (Parent (Typ)));
-- ??? Also need to cover case of a type mark denoting a subtype
-- with constraint.

48
gcc/ada/exp_ch4.adb
View File

@ -380,12 +380,11 @@ package body Exp_Ch4 is
------------------------------
function Current_Anonymous_Master return Entity_Id is
Decls : List_Id;
Fin_Mas_Id : Entity_Id;
Loc : Source_Ptr;
Subp_Body : Node_Id;
Unit_Decl : Node_Id;
Unit_Id : Entity_Id;
Decls : List_Id;
Loc : Source_Ptr;
Subp_Body : Node_Id;
Unit_Decl : Node_Id;
Unit_Id : Entity_Id;
begin
Unit_Id := Cunit_Entity (Current_Sem_Unit);
@ -440,21 +439,35 @@ package body Exp_Ch4 is
-- declarations and locate the entity.
if Has_Anonymous_Master (Unit_Id) then
Fin_Mas_Id := First_Entity (Unit_Id);
while Present (Fin_Mas_Id) loop
declare
Decl : Node_Id;
Fin_Mas_Id : Entity_Id;
-- Look for the first variable whose type is Finalization_Master
begin
Decl := First (Decls);
while Present (Decl) loop
if Ekind (Fin_Mas_Id) = E_Variable
and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
then
return Fin_Mas_Id;
end if;
-- Look for the first variable in the declarations whole type
-- is Finalization_Master.
Next_Entity (Fin_Mas_Id);
end loop;
if Nkind (Decl) = N_Object_Declaration then
Fin_Mas_Id := Defining_Identifier (Decl);
raise Program_Error;
if Ekind (Fin_Mas_Id) = E_Variable
and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
then
return Fin_Mas_Id;
end if;
end if;
Next (Decl);
end loop;
-- The master was not found even though the unit was labeled as
-- having one.
raise Program_Error;
end;
-- Create a new anonymous master
@ -462,6 +475,7 @@ package body Exp_Ch4 is
declare
First_Decl : constant Node_Id := First (Decls);
Action : Node_Id;
Fin_Mas_Id : Entity_Id;
begin
-- Since the master and its associated initialization is inserted

51
gcc/ada/exp_ch6.adb
View File

@ -111,13 +111,15 @@ package body Exp_Ch6 is
-- Extra_Formal in Subprogram_Call.
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty);
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty;
Master_Exp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
-- finalization actions, add an actual parameter which is a pointer to the
-- finalization master of the caller. If Ptr_Typ is left Empty, this will
-- result in an automatic "null" value for the actual.
-- finalization master of the caller. If Master_Exp is not Empty, then that
-- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this
-- will result in an automatic "null" value for the actual.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
@ -311,9 +313,10 @@ package body Exp_Ch6 is
-----------------------------------------------------------
procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty)
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty;
Master_Exp : Node_Id := Empty)
is
begin
if not Needs_BIP_Finalization_Master (Func_Id) then
@ -329,9 +332,16 @@ package body Exp_Ch6 is
Desig_Typ : Entity_Id;
begin
-- If there is a finalization master actual, such as the implicit
-- finalization master of an enclosing build-in-place function,
-- then this must be added as an extra actual of the call.
if Present (Master_Exp) then
Actual := Master_Exp;
-- Case where the context does not require an actual master
if No (Ptr_Typ) then
elsif No (Ptr_Typ) then
Actual := Make_Null (Loc);
else
@ -7561,7 +7571,9 @@ package body Exp_Ch6 is
Ptr_Typ_Decl : Node_Id;
Def_Id : Entity_Id;
New_Expr : Node_Id;
Enclosing_Func : Entity_Id;
Enclosing_Func : constant Entity_Id :=
Enclosing_Subprogram (Obj_Def_Id);
Fmaster_Actual : Node_Id := Empty;
Pass_Caller_Acc : Boolean := False;
begin
@ -7613,8 +7625,6 @@ package body Exp_Ch6 is
if Is_Return_Object (Defining_Identifier (Object_Decl)) then
Pass_Caller_Acc := True;
Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
-- When the enclosing function has a BIP_Alloc_Form formal then we
-- pass it along to the callee (such as when the enclosing function
-- has an unconstrained or tagged result type).
@ -7636,6 +7646,13 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
end if;
if Needs_BIP_Finalization_Master (Enclosing_Func) then
Fmaster_Actual :=
New_Reference_To
(Build_In_Place_Formal
(Enclosing_Func, BIP_Finalization_Master), Loc);
end if;
-- Retrieve the BIPacc formal from the enclosing function and convert
-- it to the access type of the callee's BIP_Object_Access formal.
@ -7686,14 +7703,18 @@ package body Exp_Ch6 is
Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
end if;
-- Pass along any finalization master actual, which is needed in the
-- case where the called function initializes a return object of an
-- enclosing build-in-place function.
Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id);
(Func_Call => Func_Call,
Func_Id => Function_Id,
Master_Exp => Fmaster_Actual);
if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
and then Has_Task (Result_Subt)
then
Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
-- Here we're passing along the master that was passed in to this
-- function.

27
gcc/ada/exp_util.adb
View File

@ -3901,7 +3901,6 @@ package body Exp_Util is
begin
Change := True;
Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl));
while Change loop
Change := False;
@ -3971,7 +3970,6 @@ package body Exp_Util is
function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
Expr : constant Node_Id := Expression (Parent (Trans_Id));
begin
return
Is_Access_Type (Etype (Trans_Id))
@ -3994,30 +3992,30 @@ package body Exp_Util is
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
-- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime.
-- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime.
and then not Is_Aliased (Obj_Id, Decl)
-- Do not consider transient objects allocated on the heap since they
-- are attached to a finalization master.
-- Do not consider transient objects allocated on the heap since
-- they are attached to a finalization master.
and then not Is_Allocated (Obj_Id)
-- If the transient object is a pointer, check that it is not
-- initialized by a function which returns a pointer or acts as a
-- renaming of another pointer.
-- If the transient object is a pointer, check that it is not
-- initialized by a function which returns a pointer or acts as a
-- renaming of another pointer.
and then
(not Is_Access_Type (Obj_Typ)
or else not Initialized_By_Access (Obj_Id))
-- Do not consider transient objects which act as indirect aliases of
-- build-in-place function results.
-- Do not consider transient objects which act as indirect aliases
-- of build-in-place function results.
and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
-- Do not consider conversions of tags to class-wide types
-- Do not consider conversions of tags to class-wide types
and then not Is_Tag_To_CW_Conversion (Obj_Id);
end Is_Finalizable_Transient;
@ -4200,8 +4198,7 @@ package body Exp_Util is
begin
-- If component reference is for an array with non-static bounds,
-- then it is always aligned: we can only process unaligned arrays
-- with static bounds (more accurately bounds known at compile
-- time).
-- with static bounds (more precisely compile time known bounds).
if Is_Array_Type (T)
and then not Compile_Time_Known_Bounds (T)
@ -4262,6 +4259,8 @@ package body Exp_Util is
-- alignment, and we either know it is too small, or cannot tell,
-- then the component may be unaligned.
-- What is the following commented out code ???
-- if Known_Alignment (Etype (P))
-- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
-- and then M > Alignment (Etype (P))

1
gcc/ada/g-comlin.adb
View File

@ -3291,6 +3291,7 @@ package body GNAT.Command_Line is
with "Expected integer parameter for '"
& Switch & "'";
end;
return;
when Switch_String =>

25
gcc/ada/g-comlin.ads
View File

@ -707,9 +707,9 @@ package GNAT.Command_Line is
Callback : Switch_Handler := null;
Parser : Opt_Parser := Command_Line_Parser;
Concatenate : Boolean := True);
-- Similar to the standard Getopt function.
-- For each switch found on the command line, this calls Callback, if the
-- switch is not handled automatically.
-- Similar to the standard Getopt function. For each switch found on the
-- command line, this calls Callback, if the switch is not handled
-- automatically.
--
-- The list of valid switches are the ones from the configuration. The
-- switches that were declared through Define_Switch with an Output
@ -726,12 +726,15 @@ package GNAT.Command_Line is
-- will display an error message and raises Invalid_Switch again.
--
-- This function automatically expands switches:
-- * If Define_Prefix was called (for instance "-gnaty") and the user
-- specifies "-gnatycb" on the command line, then Getopt returns
-- "-gnatyc" and "-gnatyb" separately.
-- * If Define_Alias was called (for instance "-gnatya = -gnatycb") then
-- the latter is returned (in this case it also expands -gnaty as per
-- the above.
--
-- If Define_Prefix was called (for instance "-gnaty") and the user
-- specifies "-gnatycb" on the command line, then Getopt returns
-- "-gnatyc" and "-gnatyb" separately.
--
-- If Define_Alias was called (for instance "-gnatya = -gnatycb") then
-- the latter is returned (in this case it also expands -gnaty as per
-- the above.
--
-- The goal is to make handling as easy as possible by leaving as much
-- work as possible to this package.
--
@ -753,15 +756,17 @@ package GNAT.Command_Line is
-- way to remove a switch from an existing command line.
-- For instance:
-- declare
-- Config : Command_Line_Configuration;
-- Line : Command_Line;
-- Args : Argument_List_Access;
-- begin
-- Define_Switch (Config, "-gnatyc");
-- Define_Switch (Config, ...); -- for all valid switches
-- Define_Prefix (Config, "-gnaty");
--
-- Set_Configuration (Line, Config);
-- Add_Switch (Line, "-O2");
-- Add_Switch (Line, "-gnatyc");

4
gcc/ada/lib-xref-alfa.adb
View File

@ -457,7 +457,7 @@ package body Alfa is
-- the entity definition.
elsif Get_Scope_Num (T1.Key.Ent_Scope) /=
Get_Scope_Num (T2.Key.Ent_Scope)
Get_Scope_Num (T2.Key.Ent_Scope)
then
return Get_Scope_Num (T1.Key.Ent_Scope) <
Get_Scope_Num (T2.Key.Ent_Scope);
@ -503,7 +503,7 @@ package body Alfa is
-- Seventh test: for same entity, sort by reference location scope
elsif Get_Scope_Num (T1.Key.Ref_Scope) /=
Get_Scope_Num (T2.Key.Ref_Scope)
Get_Scope_Num (T2.Key.Ref_Scope)
then
return Get_Scope_Num (T1.Key.Ref_Scope) <
Get_Scope_Num (T2.Key.Ref_Scope);

20
gcc/ada/lib-xref.adb
View File

@ -205,7 +205,7 @@ package body Lib.Xref is
function Equal (F1, F2 : Xref_Entry_Number) return Boolean is
Result : constant Boolean :=
Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;
Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;
begin
return Result;
end Equal;
@ -373,12 +373,12 @@ package body Lib.Xref is
Set_Ref : Boolean := True;
Force : Boolean := False)
is
Nod : Node_Id;
Ref : Source_Ptr;
Def : Source_Ptr;
Ent : Entity_Id;
Nod : Node_Id;
Ref : Source_Ptr;
Def : Source_Ptr;
Ent : Entity_Id;
Actual_Typ : Character := Typ;
Actual_Typ : Character := Typ;
Ref_Scope : Entity_Id;
Ent_Scope : Entity_Id;
@ -1882,10 +1882,10 @@ package body Lib.Xref is
if XE.Key.Typ = 'e'
and then Ent /= Curent
and then (Refno = Nrefs or else
Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
and then
not In_Extended_Main_Source_Unit (Ent)
and then (Refno = Nrefs
or else
Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
and then not In_Extended_Main_Source_Unit (Ent)
then
goto Continue;
end if;

6
gcc/ada/s-htable.adb
View File

@ -195,16 +195,16 @@ package body System.HTable is
------------------------
function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
K : constant Key := Get_Key (E);
K : constant Key := Get_Key (E);
Index : constant Header_Num := Hash (K);
Elmt : Elmt_Ptr := Table (Index);
Elmt : Elmt_Ptr;
begin
Elmt := Table (Index);
loop
if Elmt = Null_Ptr then
Set_Next (E, Table (Index));
Table (Index) := E;
return True;
elsif Equal (Get_Key (Elmt), K) then

4
gcc/ada/sem_attr.adb
View File

@ -8892,8 +8892,8 @@ package body Sem_Attr is
LB :=
Make_Attribute_Reference (Loc,
Prefix => P,
Attribute_Name => Name_First,
Expressions => (Dims));
Attribute_Name => Name_First,
Expressions => (Dims));
-- Do not share the dimension indicator, if present. Even
-- though it is a static constant, its source location

2
gcc/ada/sem_ch10.adb
View File

@ -2537,7 +2537,7 @@ package body Sem_Ch10 is
Change_Selected_Component_To_Expanded_Name (Name (N));
-- If this is a child unit without a spec, and it has benn analyzed
-- If this is a child unit without a spec, and it has been analyzed
-- already, a declaration has been created for it. The with_clause
-- must reflect the actual body, and not the generated declaration,
-- to prevent spurious binding errors involving an out-of-date spec.

22
gcc/ada/sem_ch3.adb
View File

@ -15691,20 +15691,30 @@ package body Sem_Ch3 is
------------------------
procedure Set_Anonymous_Type (Id : Entity_Id) is
Typ : constant Entity_Id := Etype (Old_C);
Old_Typ : constant Entity_Id := Etype (Old_C);
begin
if Scope (Parent_Base) = Scope (Derived_Base) then
Set_Etype (Id, Typ);
Set_Etype (Id, Old_Typ);
-- The parent and the derived type are in two different scopes.
-- Reuse the type of the original discriminant / component by
-- copying it in order to preserve all attributes and update the
-- scope.
-- copying it in order to preserve all attributes.
else
Set_Etype (Id, New_Copy (Typ));
Set_Scope (Etype (Id), Current_Scope);
declare
Typ : constant Entity_Id := New_Copy (Old_Typ);
begin
Set_Etype (Id, Typ);
-- Since we do not generate component declarations for
-- inherited components, associate the itype with the
-- derived type.
Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
Set_Scope (Typ, Derived_Base);
end;
end if;
end Set_Anonymous_Type;