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

[multiple changes] 

2011-08-04  Hristian Kirtchev  <kirtchev@adacore.com>

	* a-tags.ads, a-tags.adb (Unregister_Tag): New routine.
	Remove the external tag of a tagged type from the internal hash table.
	* exp_ch7.adb (Build_Cleanup_Statements): Update the comment on the
	expanded usage of the routine. Strenghten the check for Is_Master. Add
	processing for tagged types.
	(Build_Finalizer): Create all the necessary lists used in finalizer
	creation when the processed context is a package that may contain
	tagged types.
	(Expand_Cleanup_Actions): Rename the call to Has_Controlled_Objects to
	Requires_Cleanup_Actions.
	(Expand_N_Package_Body): Package bodies may need clean up code
	depending on whether they contain tagged types.
	(Expand_N_Package_Declaration): Package declarations may need clean up
	code depending on whether they contain tagged types.
	(Unregister_Tagged_Types): New routine. Search through a list of
	declarations or statements, looking for non-abstract Ada tagged types.
	For each such type, generate code to unregister the external tag.
	* exp_util.adb (Has_Controlled_Objects (Node_Id)): Renamed to
	Requires_Cleanup_Actions.
	(Requires_Cleanup_Actions (List_Id, Boolean)): New routine. Search
	through a list of declarations or statements looking for non-abstract
	Ada tagged types or controlled objects.
	* exp_util.ads (Has_Controlled_Objects (Node_Id)): Renamed to
	Requires_Cleanup_Actions.
	(Has_Controlled_Objects (List_Id, Boolean)): Removed.
	* rtsfind.ads: Add entry RE_Unregister_Tag to tables RE_Id and
	RE_Unit_Table.

2011-08-04  Vincent Celier  <celier@adacore.com>

	* prj-env.adb (For_All_Source_Dirs.For_Project): Check if project Prj
	has Ada sources, not project Project, because if the root project
	Project has no sources of its own, all projects will be deemed without
	sources.

2011-08-04  Gary Dismukes  <dismukes@adacore.com>

	* bindgen.adb (Gen_Adainit_Ada): Move the generation of the declaration
	of the No_Param_Proc acc-to-subp type used for initialization of
	__gnat_finalize_library_objects so that it's declared at library level
	rather than nested inside of the adainit routine.

2011-08-04  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Make_DT): Generate code to check the external tag ONLY
	if the tagged type has a representation clause which specifies its
	external tag.

2011-08-04  Ed Schonberg  <schonberg@adacore.com>

	* einfo.ads, einfo.adb (Has_Private_Ancestor): now a flag on types.
	Remove previous procedure with that name.
	* sem_ch3.adb (Build_Derived_Record_Type): set Has_Private_Ancestor
	when appropriate.
	* sem_aggr.adb (Resolve_Extension_Aggregate): if the ancestor part is a
	subtype mark, the ancestor cannot have unknown discriminants.
	(Resolve_Record_Aggregate): if the type has invisible components
	because of a private ancestor, the aggregate is illegal.

2011-08-04  Vincent Celier  <celier@adacore.com>

	* switch-m.adb (Normalize_Compiler_Switches): Recognize and take into
	account switches -gnat2005, -gnat12 and -gnat2012.

2011-08-04  Bob Duff  <duff@adacore.com>

	* s-tasdeb.ads: Minor comment fix.

2011-08-04  Arnaud Charlet  <charlet@adacore.com>

	* gnatlink.adb (Gnatlink): Pass -gnat83/95/05/12 switch to gcc in
	CodePeer mode.
	* switch.ads, switch.adb (Is_Language_Switch): New function.

2011-08-04  Vincent Celier  <celier@adacore.com>

	* switch-c.adb: Minor comment addition.

2011-08-04  Vincent Celier  <celier@adacore.com>

	* vms_conv.adb (Process_Argument): Fail graciously when qualifier
	ending with '=' is followed by a space (missing file name).

2011-08-04  Pascal Obry  <obry@adacore.com>

	* g-regist.ads: Fix size of HKEY on x86_64-windows.

2011-08-04  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Analyze_Associations): New routine
	Check_Overloaded_Formal_Subprogram to reject a formal package when
	there is a named association or a box initialisation for an overloaded
	formal subprogram of the corresponding generic.

2011-08-04  Yannick Moy  <moy@adacore.com>

	* alfa.ads (ALFA_Xref_Record): add component for type of entity
	* get_alfa.adb, put_alfa.adb: Read and write new component of
	cross-reference.
	* lib-xref-alfa.adb (Collect_ALFA): generate new component.

From-SVN: r177378
This commit is contained in:
Arnaud Charlet 2011-08-04 15:13:59 +02:00
parent 88f4728099
commit 87729e5ae1
27 changed files with 831 additions and 332 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
gcc/ada/ChangeLog
View File

@ -1,3 +1,106 @@
2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
* a-tags.ads, a-tags.adb (Unregister_Tag): New routine.
Remove the external tag of a tagged type from the internal hash table.
* exp_ch7.adb (Build_Cleanup_Statements): Update the comment on the
expanded usage of the routine. Strenghten the check for Is_Master. Add
processing for tagged types.
(Build_Finalizer): Create all the necessary lists used in finalizer
creation when the processed context is a package that may contain
tagged types.
(Expand_Cleanup_Actions): Rename the call to Has_Controlled_Objects to
Requires_Cleanup_Actions.
(Expand_N_Package_Body): Package bodies may need clean up code
depending on whether they contain tagged types.
(Expand_N_Package_Declaration): Package declarations may need clean up
code depending on whether they contain tagged types.
(Unregister_Tagged_Types): New routine. Search through a list of
declarations or statements, looking for non-abstract Ada tagged types.
For each such type, generate code to unregister the external tag.
* exp_util.adb (Has_Controlled_Objects (Node_Id)): Renamed to
Requires_Cleanup_Actions.
(Requires_Cleanup_Actions (List_Id, Boolean)): New routine. Search
through a list of declarations or statements looking for non-abstract
Ada tagged types or controlled objects.
* exp_util.ads (Has_Controlled_Objects (Node_Id)): Renamed to
Requires_Cleanup_Actions.
(Has_Controlled_Objects (List_Id, Boolean)): Removed.
* rtsfind.ads: Add entry RE_Unregister_Tag to tables RE_Id and
RE_Unit_Table.
2011-08-04 Vincent Celier <celier@adacore.com>
* prj-env.adb (For_All_Source_Dirs.For_Project): Check if project Prj
has Ada sources, not project Project, because if the root project
Project has no sources of its own, all projects will be deemed without
sources.
2011-08-04 Gary Dismukes <dismukes@adacore.com>
* bindgen.adb (Gen_Adainit_Ada): Move the generation of the declaration
of the No_Param_Proc acc-to-subp type used for initialization of
__gnat_finalize_library_objects so that it's declared at library level
rather than nested inside of the adainit routine.
2011-08-04 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_DT): Generate code to check the external tag ONLY
if the tagged type has a representation clause which specifies its
external tag.
2011-08-04 Ed Schonberg <schonberg@adacore.com>
* einfo.ads, einfo.adb (Has_Private_Ancestor): now a flag on types.
Remove previous procedure with that name.
* sem_ch3.adb (Build_Derived_Record_Type): set Has_Private_Ancestor
when appropriate.
* sem_aggr.adb (Resolve_Extension_Aggregate): if the ancestor part is a
subtype mark, the ancestor cannot have unknown discriminants.
(Resolve_Record_Aggregate): if the type has invisible components
because of a private ancestor, the aggregate is illegal.
2011-08-04 Vincent Celier <celier@adacore.com>
* switch-m.adb (Normalize_Compiler_Switches): Recognize and take into
account switches -gnat2005, -gnat12 and -gnat2012.
2011-08-04 Bob Duff <duff@adacore.com>
* s-tasdeb.ads: Minor comment fix.
2011-08-04 Arnaud Charlet <charlet@adacore.com>
* gnatlink.adb (Gnatlink): Pass -gnat83/95/05/12 switch to gcc in
CodePeer mode.
* switch.ads, switch.adb (Is_Language_Switch): New function.
2011-08-04 Vincent Celier <celier@adacore.com>
* switch-c.adb: Minor comment addition.
2011-08-04 Vincent Celier <celier@adacore.com>
* vms_conv.adb (Process_Argument): Fail graciously when qualifier
ending with '=' is followed by a space (missing file name).
2011-08-04 Pascal Obry <obry@adacore.com>
* g-regist.ads: Fix size of HKEY on x86_64-windows.
2011-08-04 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Associations): New routine
Check_Overloaded_Formal_Subprogram to reject a formal package when
there is a named association or a box initialisation for an overloaded
formal subprogram of the corresponding generic.
2011-08-04 Yannick Moy <moy@adacore.com>
* alfa.ads (ALFA_Xref_Record): add component for type of entity
* get_alfa.adb, put_alfa.adb: Read and write new component of
cross-reference.
* lib-xref-alfa.adb (Collect_ALFA): generate new component.
2011-08-04 Pascal Obry <obry@adacore.com>
* urealp.adb: Minor reformatting.

13
gcc/ada/a-tags.adb
View File

@ -1005,6 +1005,19 @@ package body Ada.Tags is
return TSD.Type_Is_Abstract;
end Type_Is_Abstract;
--------------------
-- Unregister_Tag --
--------------------
procedure Unregister_Tag (T : Tag) is
TSD_Ptr : constant Addr_Ptr :=
To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (TSD_Ptr.all);
begin
External_Tag_HTable.Remove (To_Address (TSD.External_Tag));
end Unregister_Tag;
------------------------
-- Wide_Expanded_Name --
------------------------

3
gcc/ada/a-tags.ads
View File

@ -542,6 +542,9 @@ private
-- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD
-- table indexed by Position.
procedure Unregister_Tag (T : Tag);
-- Remove a particular tag from the external tag hash table
Max_Predef_Prims : constant Positive := 16;
-- Number of reserved slots for the following predefined ada primitives:
--

17
gcc/ada/alfa.ads
View File

@ -133,10 +133,18 @@ package ALFA is
-- entity-number and identity identify a scope entity in FS lines for
-- the file previously identified.
-- line col entity ref*
-- line typ col entity ref*
-- line is the line number of the referenced entity
-- typ is the type of the referenced entity, using a code similar to
-- the one used for cross-references:
-- > = IN parameter
-- < = OUT parameter
-- = = IN OUT parameter
-- * = all other cases
-- col is the column number of the referenced entity
-- entity is the name of the referenced entity as written in the source
@ -186,6 +194,13 @@ package ALFA is
Entity_Line : Nat;
-- Line number for the entity referenced
Etype : Character;
-- Indicates type of entity, using code used in ALI file:
-- > = IN parameter
-- < = OUT parameter
-- = = IN OUT parameter
-- * = all other cases
Entity_Col : Nat;
-- Column number for the entity referenced

17
gcc/ada/bindgen.adb
View File

@ -499,6 +499,22 @@ package body Bindgen is
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
begin
-- Declare the access-to-subprogram type used for initialization of
-- of __gnat_finalize_library_objects. This is declared at library
-- level for compatibility with the type used in System.Soft_Links.
-- The import of the soft link which performs library-level object
-- finalization is not needed for VM targets; regular Ada is used in
-- that case. For restricted run-time libraries (ZFP and Ravenscar)
-- tasks are non-terminating, so we do not want finalization.
if not Suppress_Standard_Library_On_Target
and then VM_Target = No_VM
and then not Configurable_Run_Time_On_Target
then
WBI (" type No_Param_Proc is access procedure;");
WBI ("");
end if;
WBI (" procedure " & Ada_Init_Name.all & " is");
-- If the standard library is suppressed, then the only global variables
@ -621,7 +637,6 @@ package body Bindgen is
if VM_Target = No_VM and then not Configurable_Run_Time_On_Target then
WBI ("");
WBI (" type No_Param_Proc is access procedure;");
WBI (" Finalize_Library_Objects : No_Param_Proc;");
WBI (" pragma Import (C, Finalize_Library_Objects, " &
"""__gnat_finalize_library_objects"");");

36
gcc/ada/einfo.adb
View File

@ -409,6 +409,7 @@ package body Einfo is
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
-- Has_Private_Ancestor Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
@ -1312,7 +1313,9 @@ package body Einfo is
function Has_Invariants (Id : E) return B is
begin
pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
pragma Assert (Is_Type (Id)
or else Ekind (Id) = E_Procedure
or else Ekind (Id) = E_Generic_Procedure);
return Flag232 (Id);
end Has_Invariants;
@ -1445,6 +1448,11 @@ package body Einfo is
return Flag120 (Base_Type (Id));
end Has_Primitive_Operations;
function Has_Private_Ancestor (Id : E) return B is
begin
return Flag151 (Id);
end Has_Private_Ancestor;
function Has_Private_Declaration (Id : E) return B is
begin
return Flag155 (Id);
@ -3936,6 +3944,12 @@ package body Einfo is
Set_Flag120 (Id, V);
end Set_Has_Primitive_Operations;
procedure Set_Has_Private_Ancestor (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag151 (Id, V);
end Set_Has_Private_Ancestor;
procedure Set_Has_Private_Declaration (Id : E; V : B := True) is
begin
Set_Flag155 (Id, V);
@ -6100,25 +6114,6 @@ package body Einfo is
return False;
end Has_Interrupt_Handler;
--------------------------
-- Has_Private_Ancestor --
--------------------------
function Has_Private_Ancestor (Id : E) return B is
R : constant Entity_Id := Root_Type (Id);
T1 : Entity_Id := Id;
begin
loop
if Is_Private_Type (T1) then
return True;
elsif T1 = R then
return False;
else
T1 := Etype (T1);
end if;
end loop;
end Has_Private_Ancestor;
--------------------
-- Has_Rep_Pragma --
--------------------
@ -7461,6 +7456,7 @@ package body Einfo is
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
W ("Has_Predicates", Flag250 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Ancestor", Flag151 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_RACW", Flag214 (Id));

19
gcc/ada/einfo.ads
View File

@ -1690,10 +1690,13 @@ package Einfo is
-- Present in all type entities. Set if at least one primitive operation
-- is defined for the type.
-- Has_Private_Ancestor (synthesized)
-- Applies to all type and subtype entities. Returns True if at least
-- one ancestor is private, and otherwise False if there are no private
-- ancestors.
-- Has_Private_Ancestor (Flag151)
-- Applies to type extensions. True if some ancestor is derived from a
-- private type, making some components invisible and aggregates illegal.
-- This flag is set at the point of derivation. The legality of the
-- aggregate must be rechecked because it also depends on the visibility
-- at the point the aggregate is resolved. See sem_aggr.adb.
-- This is part of AI05-0115.
-- Has_Private_Declaration (Flag155)
-- Present in all entities. Returns True if it is the defining entity
@ -4909,7 +4912,6 @@ package Einfo is
-- Alignment_Clause (synth)
-- Base_Type (synth)
-- Has_Private_Ancestor (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
@ -5581,6 +5583,7 @@ package Einfo is
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Pragma_Pack (Flag121) (impl base type only)
-- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
@ -5607,6 +5610,7 @@ package Einfo is
-- Stored_Constraint (Elist23)
-- Interfaces (Elist25)
-- Has_Completion (Flag26)
-- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Is_Concurrent_Record_Type (Flag20)
@ -6119,6 +6123,7 @@ package Einfo is
function Has_Pragma_Unreferenced_Objects (Id : E) return B;
function Has_Predicates (Id : E) return B;
function Has_Primitive_Operations (Id : E) return B;
function Has_Private_Ancestor (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
function Has_Record_Rep_Clause (Id : E) return B;
@ -6436,7 +6441,6 @@ package Einfo is
function Has_Attach_Handler (Id : E) return B;
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
function Is_Base_Type (Id : E) return B;
@ -6705,6 +6709,7 @@ package Einfo is
procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
procedure Set_Has_Predicates (Id : E; V : B := True);
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_RACW (Id : E; V : B := True);
@ -7400,6 +7405,7 @@ package Einfo is
pragma Inline (Has_Pragma_Unreferenced_Objects);
pragma Inline (Has_Predicates);
pragma Inline (Has_Primitive_Operations);
pragma Inline (Has_Private_Ancestor);
pragma Inline (Has_Private_Declaration);
pragma Inline (Has_Qualified_Name);
pragma Inline (Has_RACW);
@ -7842,6 +7848,7 @@ package Einfo is
pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
pragma Inline (Set_Has_Predicates);
pragma Inline (Set_Has_Primitive_Operations);
pragma Inline (Set_Has_Private_Ancestor);
pragma Inline (Set_Has_Private_Declaration);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_RACW);

122
gcc/ada/exp_ch7.adb
View File

@ -297,8 +297,11 @@ package body Exp_Ch7 is
function Build_Cleanup_Statements (N : Node_Id) return List_Id;
-- Create the clean up calls for an asynchronous call block, task master,
-- protected subprogram body, task allocation block or task body. If N is
-- neither of these constructs, the routine returns a new list.
-- protected subprogram body, task allocation block or task body. Generate
-- code to unregister the external tags of all library-level tagged types
-- found in the declarations and/or statements of N. If the context does
-- not contain the above constructs or types, the routine returns an empty
-- list.
function Build_Exception_Handler
(Loc : Source_Ptr;
@ -486,8 +489,11 @@ package body Exp_Ch7 is
Is_Asynchronous_Call : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Asynchronous_Call_Block (N);
Is_Master : constant Boolean :=
Nkind (N) /= N_Entry_Body
not Nkind_In (N, N_Entry_Body,
N_Package_Body,
N_Package_Declaration)
and then Is_Task_Master (N);
Is_Protected_Body : constant Boolean :=
Nkind (N) = N_Subprogram_Body
@ -501,6 +507,59 @@ package body Exp_Ch7 is
Loc : constant Source_Ptr := Sloc (N);
Stmts : constant List_Id := New_List;
procedure Unregister_Tagged_Types (Decls : List_Id);
-- Unregister the external tag of each tagged type found in the list
-- Decls. The generated statements are added to list Stmts.
-----------------------------
-- Unregister_Tagged_Types --
-----------------------------
procedure Unregister_Tagged_Types (Decls : List_Id) is
Decl : Node_Id;
DT_Ptr : Entity_Id;
Typ : Entity_Id;
begin
if No (Decls) or else Is_Empty_List (Decls) then
return;
end if;
-- Process all declarations or statements in reverse order
Decl := Last_Non_Pragma (Decls);
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration then
Typ := Defining_Identifier (Decl);
if Is_Tagged_Type (Typ)
and then Is_Library_Level_Entity (Typ)
and then Convention (Typ) = Convention_Ada
and then Present (Access_Disp_Table (Typ))
and then RTE_Available (RE_Unregister_Tag)
and then not No_Run_Time_Mode
and then not Is_Abstract_Type (Typ)
then
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Typ)));
-- Generate:
-- Ada.Tags.Unregister_Tag (<Typ>P);
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Unregister_Tag), Loc),
Parameter_Associations => New_List (
New_Reference_To (DT_Ptr, Loc))));
end if;
end if;
Prev_Non_Pragma (Decl);
end loop;
end Unregister_Tagged_Types;
-- Start of processing for Build_Cleanup_Statements
begin
if Is_Task_Body then
if Restricted_Profile then
@ -711,6 +770,26 @@ package body Exp_Ch7 is
end;
end if;
-- Inspect all declaration and/or statement lists of N for library-level
-- tagged types. Generate code to unregister the external tag of such a
-- type.
if Nkind (N) = N_Package_Declaration then
Unregister_Tagged_Types (Private_Declarations (Specification (N)));
Unregister_Tagged_Types (Visible_Declarations (Specification (N)));
-- Accept statement, block, entry body, package body, protected body,
-- subprogram body or task body.
else
if Present (Handled_Statement_Sequence (N)) then
Unregister_Tagged_Types
(Statements (Handled_Statement_Sequence (N)));
end if;
Unregister_Tagged_Types (Declarations (N));
end if;
return Stmts;
end Build_Cleanup_Statements;
@ -2686,22 +2765,29 @@ package body Exp_Ch7 is
if For_Package_Spec then
Process_Declarations
(Priv_Decls, Preprocess => True, Top_Level => True);
-- The preprocessing has determined that the context has objects
-- that need finalization actions. Private declarations are
-- processed first in order to preserve possible dependencies
-- between public and private objects.
if Has_Ctrl_Objs then
Build_Components;
Process_Declarations (Priv_Decls);
end if;
end if;
-- Process the public declarations
-- The current context may lack controlled objects, but require some
-- other form of completion (task termination for instance). In such
-- cases, the finalizer must be created and carry the additional
-- statements.
if Acts_As_Clean or else Has_Ctrl_Objs then
Build_Components;
end if;
-- The preprocessing has determined that the context has objects that
-- need finalization actions.
if Has_Ctrl_Objs then
Build_Components;
-- Private declarations are processed first in order to preserve
-- possible dependencies between public and private objects.
if For_Package_Spec then
Process_Declarations (Priv_Decls);
end if;
Process_Declarations (Decls);
end if;
@ -3495,7 +3581,7 @@ package body Exp_Ch7 is
and then VM_Target = No_VM;
Actions_Required : constant Boolean :=
Has_Controlled_Objects (N)
Requires_Cleanup_Actions (N)
or else Is_Asynchronous_Call
or else Is_Master
or else Is_Protected_Body
@ -3770,7 +3856,7 @@ package body Exp_Ch7 is
if Ekind (Spec_Ent) /= E_Generic_Package then
Build_Finalizer
(N => N,
Clean_Stmts => No_List,
Clean_Stmts => Build_Cleanup_Statements (N),
Mark_Id => Empty,
Top_Decls => No_List,
Defer_Abort => False,
@ -3924,7 +4010,7 @@ package body Exp_Ch7 is
if Ekind (Id) /= E_Generic_Package then
Build_Finalizer
(N => N,
Clean_Stmts => No_List,
Clean_Stmts => Build_Cleanup_Statements (N),
Mark_Id => Empty,
Top_Decls => No_List,
Defer_Abort => False,

6
gcc/ada/exp_disp.adb
View File

@ -6172,8 +6172,9 @@ package body Exp_Disp is
end if;
end if;
-- Generate code to check if the external tag of this type is the same
-- as the external tag of some other declaration.
-- If the type has a representation clause which specifies its external
-- tag then generate code to check if the external tag of this type is
-- the same as the external tag of some other declaration.
-- Check_TSD (TSD'Unrestricted_Access);
@ -6188,6 +6189,7 @@ package body Exp_Disp is
if not No_Run_Time_Mode
and then Ada_Version >= Ada_2005
and then Has_External_Tag_Rep_Clause (Typ)
and then RTE_Available (RE_Check_TSD)
and then not Debug_Flag_QQ
then

489
gcc/ada/exp_util.adb
View File

@ -147,6 +147,17 @@ package body Exp_Util is
N : Node_Id) return Entity_Id;
-- Create an implicit subtype of CW_Typ attached to node N
function Requires_Cleanup_Actions
(L : List_Id;
For_Package : Boolean) return Boolean;
-- Given a list L, determine whether it contains one of the following:
--
-- 1) controlled objects
-- 2) library-level tagged types
--
-- Flag For_Package should be set when the list comes from a package spec
-- or body.
----------------------
-- Adjust_Condition --
----------------------
@ -2579,238 +2590,6 @@ package body Exp_Util is
end if;
end Has_Access_Constraint;
----------------------------
-- Has_Controlled_Objects --
----------------------------
function Has_Controlled_Objects (N : Node_Id) return Boolean is
For_Pkg : constant Boolean :=
Nkind_In (N, N_Package_Body, N_Package_Specification);
begin
case Nkind (N) is
when N_Accept_Statement |
N_Block_Statement |
N_Entry_Body |
N_Package_Body |
N_Protected_Body |
N_Subprogram_Body |
N_Task_Body =>
return Has_Controlled_Objects (Declarations (N), For_Pkg)
or else
-- An expanded sequence of statements may introduce
-- controlled objects.
(Present (Handled_Statement_Sequence (N))
and then
Has_Controlled_Objects
(Statements (Handled_Statement_Sequence (N)), For_Pkg));
when N_Package_Specification =>
return Has_Controlled_Objects (Visible_Declarations (N), For_Pkg)
or else
Has_Controlled_Objects (Private_Declarations (N), For_Pkg);
when others =>
return False;
end case;
end Has_Controlled_Objects;
----------------------------
-- Has_Controlled_Objects --
----------------------------
function Has_Controlled_Objects
(L : List_Id;
For_Package : Boolean) return Boolean
is
Decl : Node_Id;
Expr : Node_Id;
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
Typ : Entity_Id;
begin
if No (L)
or else Is_Empty_List (L)
then
return False;
end if;
Decl := First (L);
while Present (Decl) loop
-- Regular object declarations
if Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
Expr := Expression (Decl);
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
-- library level.
if For_Package
and then Finalize_Storage_Only (Obj_Typ)
then
null;
-- Transient variables are treated separately in order to minimize
-- the size of the generated code. See Exp_Ch7.Process_Transient_
-- Objects.
elsif Is_Processed_Transient (Obj_Id) then
null;
-- The object is of the form:
-- Obj : Typ [:= Expr];
--
-- Do not process the incomplete view of a deferred constant. Do
-- not consider tag-to-class-wide conversions.
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
and then not (Ekind (Obj_Id) = E_Constant
and then not Has_Completion (Obj_Id))
and then not Is_Tag_To_CW_Conversion (Obj_Id)
then
return True;
-- The object is of the form:
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
--
-- Obj : Access_Typ :=
-- BIP_Function_Call
-- (..., BIPaccess => null, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
(Is_Null_Access_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
then
return True;
-- Processing for "hook" objects generated for controlled
-- transients declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
and then Is_Finalizable_Transient
(Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
return True;
-- Simple protected objects which use type System.Tasking.
-- Protected_Objects.Protection to manage their locks should be
-- treated as controlled since they require manual cleanup.
elsif Ekind (Obj_Id) = E_Variable
and then
(Is_Simple_Protected_Type (Obj_Typ)
or else Has_Simple_Protected_Object (Obj_Typ))
then
return True;
end if;
-- Specific cases of object renamings
elsif Nkind (Decl) = N_Object_Renaming_Declaration
and then Nkind (Name (Decl)) = N_Explicit_Dereference
and then Nkind (Prefix (Name (Decl))) = N_Identifier
then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
-- library level.
if For_Package
and then Finalize_Storage_Only (Obj_Typ)
then
null;
-- Return object of a build-in-place function. This case is
-- recognized and marked by the expansion of an extended return
-- statement (see Expand_N_Extended_Return_Statement).
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
return True;
end if;
-- Inspect the freeze node of an access-to-controlled type and
-- look for a delayed finalization collection. This case arises
-- when the freeze actions are inserted at a later time than the
-- expansion of the context. Since Build_Finalizer is never called
-- on a single construct twice, the collection will be ultimately
-- left out and never finalized. This is also needed for freeze
-- actions of designated types themselves, since in some cases the
-- finalization collection is associated with a designated type's
-- freeze node rather than that of the access type (see handling
-- for freeze actions in Build_Finalization_Collection).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
then
Typ := Entity (Decl);
if (Is_Access_Type (Typ)
and then not Is_Access_Subprogram_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
or else
(Is_Type (Typ)
and then Needs_Finalization (Typ))
then
return True;
end if;
-- Nested package declarations
elsif Nkind (Decl) = N_Package_Declaration then
Pack_Id := Defining_Unit_Name (Specification (Decl));
if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
Pack_Id := Defining_Identifier (Pack_Id);
end if;
if Ekind (Pack_Id) /= E_Generic_Package
and then Has_Controlled_Objects (Specification (Decl))
then
return True;
end if;
-- Nested package bodies
elsif Nkind (Decl) = N_Package_Body then
Pack_Id := Corresponding_Spec (Decl);
if Ekind (Pack_Id) /= E_Generic_Package
and then Has_Controlled_Objects (Decl)
then
return True;
end if;
end if;
Next (Decl);
end loop;
return False;
end Has_Controlled_Objects;
----------------------------------
-- Has_Following_Address_Clause --
----------------------------------
@ -6346,6 +6125,252 @@ package body Exp_Util is
and then Is_Scalar_Type (Packed_Array_Type (UT)));
end Represented_As_Scalar;
------------------------------
-- Requires_Cleanup_Actions --
------------------------------
function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
For_Pkg : constant Boolean :=
Nkind_In (N, N_Package_Body, N_Package_Specification);
begin
case Nkind (N) is
when N_Accept_Statement |
N_Block_Statement |
N_Entry_Body |
N_Package_Body |
N_Protected_Body |
N_Subprogram_Body |
N_Task_Body =>
return
Requires_Cleanup_Actions (Declarations (N), For_Pkg)
or else
(Present (Handled_Statement_Sequence (N))
and then
Requires_Cleanup_Actions
(Statements (Handled_Statement_Sequence (N)), For_Pkg));
when N_Package_Specification =>
return
Requires_Cleanup_Actions (Visible_Declarations (N), For_Pkg)
or else
Requires_Cleanup_Actions (Private_Declarations (N), For_Pkg);
when others =>
return False;
end case;
end Requires_Cleanup_Actions;
------------------------------
-- Requires_Cleanup_Actions --
------------------------------
function Requires_Cleanup_Actions
(L : List_Id;
For_Package : Boolean) return Boolean
is
Decl : Node_Id;
Expr : Node_Id;
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
Typ : Entity_Id;
begin
if No (L)
or else Is_Empty_List (L)
then
return False;
end if;
Decl := First (L);
while Present (Decl) loop
-- Library-level tagged types
if Nkind (Decl) = N_Full_Type_Declaration then
Typ := Defining_Identifier (Decl);
if Is_Tagged_Type (Typ)
and then Is_Library_Level_Entity (Typ)
and then Convention (Typ) = Convention_Ada
and then Present (Access_Disp_Table (Typ))
and then RTE_Available (RE_Unregister_Tag)
and then not No_Run_Time_Mode
and then not Is_Abstract_Type (Typ)
then
return True;
end if;
-- Regular object declarations
elsif Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
Expr := Expression (Decl);
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
-- library level.
if For_Package
and then Finalize_Storage_Only (Obj_Typ)
then
null;
-- Transient variables are treated separately in order to minimize
-- the size of the generated code. See Exp_Ch7.Process_Transient_
-- Objects.
elsif Is_Processed_Transient (Obj_Id) then
null;
-- The object is of the form:
-- Obj : Typ [:= Expr];
--
-- Do not process the incomplete view of a deferred constant. Do
-- not consider tag-to-class-wide conversions.
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
and then not (Ekind (Obj_Id) = E_Constant
and then not Has_Completion (Obj_Id))
and then not Is_Tag_To_CW_Conversion (Obj_Id)
then
return True;
-- The object is of the form:
-- Obj : Access_Typ := Non_BIP_Function_Call'reference;
--
-- Obj : Access_Typ :=
-- BIP_Function_Call
-- (..., BIPaccess => null, ...)'reference;
elsif Is_Access_Type (Obj_Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Obj_Typ)))
and then Present (Expr)
and then
(Is_Null_Access_BIP_Func_Call (Expr)
or else
(Is_Non_BIP_Func_Call (Expr)
and then not Is_Related_To_Func_Return (Obj_Id)))
then
return True;
-- Processing for "hook" objects generated for controlled
-- transients declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
and then Is_Finalizable_Transient
(Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
return True;
-- Simple protected objects which use type System.Tasking.
-- Protected_Objects.Protection to manage their locks should be
-- treated as controlled since they require manual cleanup.
elsif Ekind (Obj_Id) = E_Variable
and then
(Is_Simple_Protected_Type (Obj_Typ)
or else Has_Simple_Protected_Object (Obj_Typ))
then
return True;
end if;
-- Specific cases of object renamings
elsif Nkind (Decl) = N_Object_Renaming_Declaration
and then Nkind (Name (Decl)) = N_Explicit_Dereference
and then Nkind (Prefix (Name (Decl))) = N_Identifier
then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
-- library level.
if For_Package
and then Finalize_Storage_Only (Obj_Typ)
then
null;
-- Return object of a build-in-place function. This case is
-- recognized and marked by the expansion of an extended return
-- statement (see Expand_N_Extended_Return_Statement).
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
return True;
end if;
-- Inspect the freeze node of an access-to-controlled type and
-- look for a delayed finalization collection. This case arises
-- when the freeze actions are inserted at a later time than the
-- expansion of the context. Since Build_Finalizer is never called
-- on a single construct twice, the collection will be ultimately
-- left out and never finalized. This is also needed for freeze
-- actions of designated types themselves, since in some cases the
-- finalization collection is associated with a designated type's
-- freeze node rather than that of the access type (see handling
-- for freeze actions in Build_Finalization_Collection).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
then
Typ := Entity (Decl);
if (Is_Access_Type (Typ)
and then not Is_Access_Subprogram_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
or else
(Is_Type (Typ)
and then Needs_Finalization (Typ))
then
return True;
end if;
-- Nested package declarations
elsif Nkind (Decl) = N_Package_Declaration then
Pack_Id := Defining_Unit_Name (Specification (Decl));
if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
Pack_Id := Defining_Identifier (Pack_Id);
end if;
if Ekind (Pack_Id) /= E_Generic_Package
and then Requires_Cleanup_Actions (Specification (Decl))
then
return True;
end if;
-- Nested package bodies
elsif Nkind (Decl) = N_Package_Body then
Pack_Id := Corresponding_Spec (Decl);
if Ekind (Pack_Id) /= E_Generic_Package
and then Requires_Cleanup_Actions (Decl)
then
return True;
end if;
end if;
Next (Decl);
end loop;
return False;
end Requires_Cleanup_Actions;
------------------------------------
-- Safe_Unchecked_Type_Conversion --
------------------------------------

20
gcc/ada/exp_util.ads
View File

@ -486,17 +486,6 @@ package Exp_Util is
function Has_Access_Constraint (E : Entity_Id) return Boolean;
-- Given object or type E, determine if a discriminant is of an access type
function Has_Controlled_Objects (N : Node_Id) return Boolean;
-- Given a node N, determine if it has a declarative or a statement part
-- and whether those lists contain at least one controlled object.
function Has_Controlled_Objects
(L : List_Id;
For_Package : Boolean) return Boolean;
-- Given a list, determine whether L contains at least one controlled
-- object. Flag For_Package should be set when the list comes from a
-- package spec or body.
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
@ -738,6 +727,15 @@ package Exp_Util is
-- terms is scalar. This is true for scalars in the Ada sense, and for
-- packed arrays which are represented by a scalar (modular) type.
function Requires_Cleanup_Actions (N : Node_Id) return Boolean;
-- Given a node N, determine whether its declarative and/or statement list
-- contains one of the following:
--
-- 1) controlled objects
-- 2) library-level tagged types
--
-- The above cases require special actions on scope exit.
function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean;
-- Given the node for an N_Unchecked_Type_Conversion, return True if this
-- is an unchecked conversion that Gigi can handle directly. Otherwise

4
gcc/ada/g-regist.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -145,7 +145,7 @@ package GNAT.Registry is
private
type HKEY is mod 2 ** Integer'Size;
type HKEY is mod 2 ** Standard'Address_Size;
HKEY_CLASSES_ROOT : constant HKEY := 16#80000000#;
HKEY_CURRENT_USER : constant HKEY := 16#80000001#;

4
gcc/ada/get_alfa.adb
View File

@ -371,6 +371,7 @@ begin
XR_Entity : String_Ptr;
XR_Entity_Line : Nat;
XR_Entity_Col : Nat;
XR_Entity_Typ : Character;
XR_File : Nat;
-- Keeps track of the current file (changed by nn|)
@ -383,7 +384,7 @@ begin
XR_Scope := Cur_Scope;
XR_Entity_Line := Get_Nat;
Check (' ');
XR_Entity_Typ := Getc;
XR_Entity_Col := Get_Nat;
Skip_Spaces;
@ -439,6 +440,7 @@ begin
ALFA_Xref_Table.Append (
(Entity_Name => XR_Entity,
Entity_Line => XR_Entity_Line,
Etype => XR_Entity_Typ,
Entity_Col => XR_Entity_Col,
File_Num => XR_File,
Scope_Num => XR_Scope,

7
gcc/ada/gnatlink.adb
View File

@ -1594,11 +1594,16 @@ begin
-- is to be dealt with specially because it needs to be passed
-- if the binder-generated file is in Ada and may also be used
-- to drive the linker.
-- Also in CodePeer mode, we need to pass the -gnat05 or
-- -gnat12 switches to be able to compile the binder file.
declare
Arg : String_Ptr renames Args.Table (Index);
begin
if not Is_Front_End_Switch (Arg.all) then
if not Is_Front_End_Switch (Arg.all)
or else (Opt.CodePeer_Mode
and then Is_Language_Switch (Arg.all))
then
Binder_Options_From_ALI.Increment_Last;
Binder_Options_From_ALI.Table
(Binder_Options_From_ALI.Last) := String_Access (Arg);

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

@ -635,6 +635,9 @@ package body ALFA is
-- Return scope entity which corresponds to index Cur_Scope_Idx in
-- table ALFA_Scope_Table.
function Get_Entity_Type (E : Entity_Id) return Character;
-- Return a character representing the type of entity
function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;
-- Check whether entity E is in ALFA_Scope_Table at index
-- Cur_Scope_Idx or higher.
@ -652,6 +655,22 @@ package body ALFA is
return ALFA_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity;
end Cur_Scope;
---------------------
-- Get_Entity_Type --
---------------------
function Get_Entity_Type (E : Entity_Id) return Character is
C : Character;
begin
case Ekind (E) is
when E_Out_Parameter => C := '<';
when E_In_Out_Parameter => C := '=';
when E_In_Parameter => C := '>';
when others => C := '*';
end case;
return C;
end Get_Entity_Type;
----------------------------
-- Is_Future_Scope_Entity --
----------------------------
@ -729,6 +748,7 @@ package body ALFA is
ALFA_Xref_Table.Append (
(Entity_Name => Cur_Entity_Name,
Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
Etype => Get_Entity_Type (XE.Ent),
Entity_Col => Int (Get_Column_Number (XE.Def)),
File_Num => Dependency_Num (XE.Lun),
Scope_Num => Get_Scope_Num (XE.Ref_Scope),

2
gcc/ada/prj-env.adb
View File

@ -1281,7 +1281,7 @@ package body Prj.Env is
-- If there are Ada sources, call action with the name of every
-- source directory.
if Has_Ada_Sources (Project) then
if Has_Ada_Sources (Prj) then
while Current /= Nil_String loop
The_String := In_Tree.Shared.String_Elements.Table (Current);
Action (Get_Name_String (The_String.Display_Value));

2
gcc/ada/put_alfa.adb
View File

@ -173,7 +173,7 @@ begin
Write_Info_Initiate ('F');
Write_Info_Char (' ');
Write_Info_Nat (R.Entity_Line);
Write_Info_Char (' ');
Write_Info_Char (R.Etype);
Write_Info_Nat (R.Entity_Col);
Write_Info_Char (' ');

2
gcc/ada/rtsfind.ads
View File

@ -642,6 +642,7 @@ package Rtsfind is
RE_TK_Protected, -- Ada.Tags
RE_TK_Tagged, -- Ada.Tags
RE_TK_Task, -- Ada.Tags
RE_Unregister_Tag, -- Ada.Tags
RE_Set_Specific_Handler, -- Ada.Task_Termination
RE_Specific_Handler, -- Ada.Task_Termination
@ -1823,6 +1824,7 @@ package Rtsfind is
RE_TK_Protected => Ada_Tags,
RE_TK_Tagged => Ada_Tags,
RE_TK_Task => Ada_Tags,
RE_Unregister_Tag => Ada_Tags,
RE_Set_Specific_Handler => Ada_Task_Termination,
RE_Specific_Handler => Ada_Task_Termination,

4
gcc/ada/s-tasdeb.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1997-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -83,7 +83,7 @@ package System.Tasking.Debug is
subtype Event_Kind_Type is Positive range 1 .. 11;
-- Event kinds currently defined for debugging, used globally
-- below and on a per taak basis.
-- below and on a per task basis.
procedure Signal_Debug_Event
(Event_Kind : Event_Kind_Type;

98
gcc/ada/sem_aggr.adb
View File

@ -45,6 +45,7 @@ with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@ -2573,6 +2574,15 @@ package body Sem_Aggr is
and then Is_Type (Entity (A))
then
Check_SPARK_Restriction ("ancestor part cannot be a type mark", A);
-- AI05-0115: if the ancestor part is a subtype mark, the ancestor
-- must not have unknown discriminants.
if Has_Unknown_Discriminants (Root_Type (Typ)) then
Error_Msg_NE
("aggregate not available for type& whose ancestor "
& "has unknown discriminants", N, Typ);
end if;
end if;
if not Is_Tagged_Type (Typ) then
@ -3405,6 +3415,18 @@ package body Sem_Aggr is
Positional_Expr := Empty;
end if;
-- AI05-0115: if the ancestor part is a subtype mark, the ancestor
-- must npt have unknown discriminants.
if Is_Derived_Type (Typ)
and then Has_Unknown_Discriminants (Root_Type (Typ))
and then Nkind (N) /= N_Extension_Aggregate
then
Error_Msg_NE
("aggregate not available for type& whose ancestor "
& "has unknown discriminants ", N, Typ);
end if;
if Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
@ -3558,6 +3580,35 @@ package body Sem_Aggr is
Errors_Found : Boolean := False;
Dnode : Node_Id;
function Find_Private_Ancestor return Entity_Id;
-- AI05-0115: Find earlier ancestor in the derivation chain that is
-- derived from a private view. Whether the aggregate is legal
-- depends on the current visibility of the type as well as that
-- of the parent of the ancestor.
---------------------------
-- Find_Private_Ancestor --
---------------------------
function Find_Private_Ancestor return Entity_Id is
Par : Entity_Id;
begin
Par := Typ;
loop
if Has_Private_Ancestor (Par)
and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
then
return Par;
elsif not Is_Derived_Type (Par) then
return Empty;
else
Par := Etype (Base_Type (Par));
end if;
end loop;
end Find_Private_Ancestor;
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
@ -3571,16 +3622,45 @@ package body Sem_Aggr is
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
Root_Typ := Root_Type (Typ);
-- AI05-0115: check legality of aggregate for type with
-- aa private ancestor.
if Nkind (Parent (Base_Type (Root_Typ))) =
N_Private_Type_Declaration
then
Error_Msg_NE
("type of aggregate has private ancestor&!",
N, Root_Typ);
Error_Msg_N ("must use extension aggregate!", N);
return;
Root_Typ := Root_Type (Typ);
if Has_Private_Ancestor (Typ) then
declare
Ancestor : constant Entity_Id :=
Find_Private_Ancestor;
Ancestor_Unit : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
Cunit_Entity
(Get_Source_Unit (Base_Type (Etype (Ancestor))));
begin
-- check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can
-- only happen if the derivation takes place in a child
-- unit of the unit that declares the parent, and we are
-- in the private part or body of that child unit, else
-- the aggregate is illegal.
if Is_Child_Unit (Ancestor_Unit)
and then Scope (Ancestor_Unit) = Parent_Unit
and then In_Open_Scopes (Scope (Ancestor))
and then
(In_Private_Part (Scope (Ancestor))
or else In_Package_Body (Scope (Ancestor)))
then
null;
else
Error_Msg_NE
("type of aggregate has private ancestor&!",
N, Root_Typ);
Error_Msg_N ("must use extension aggregate!", N);
return;
end if;
end;
end if;
Dnode := Declaration_Node (Base_Type (Root_Typ));

66
gcc/ada/sem_ch12.adb
View File

@ -888,7 +888,6 @@ package body Sem_Ch12 is
Actual : Node_Id;
Formal : Node_Id;
Next_Formal : Node_Id;
Temp_Formal : Node_Id;
Analyzed_Formal : Node_Id;
Match : Node_Id;
Named : Node_Id;
@ -910,9 +909,16 @@ package body Sem_Ch12 is
Num_Actuals : Int := 0;
Others_Present : Boolean := False;
Others_Choice : Node_Id := Empty;
-- In Ada 2005, indicates partial parametrization of a formal
-- package. As usual an other association must be last in the list.
procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
-- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
-- cannot have a named association for it. AI05-0025 extends this rule
-- to formals of formal packages by AI05-0025, and it also applies to
-- box-initialized formals.
function Matching_Actual
(F : Entity_Id;
A_F : Entity_Id) return Node_Id;
@ -946,6 +952,40 @@ package body Sem_Ch12 is
-- anonymous types, the presence a formal equality will introduce an
-- implicit declaration for the corresponding inequality.
----------------------------------------
-- Check_Overloaded_Formal_Subprogram --
----------------------------------------
procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is
Temp_Formal : Entity_Id;
begin
Temp_Formal := First (Formals);
while Present (Temp_Formal) loop
if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration
and then Temp_Formal /= Formal
and then
Chars (Defining_Unit_Name (Specification (Formal))) =
Chars (Defining_Unit_Name (Specification (Temp_Formal)))
then
if Present (Found_Assoc) then
Error_Msg_N
("named association not allowed for overloaded formal",
Found_Assoc);
else
Error_Msg_N
("named association not allowed for overloaded formal",
Others_Choice);
end if;
Abandon_Instantiation (Instantiation_Node);
end if;
Next (Temp_Formal);
end loop;
end Check_Overloaded_Formal_Subprogram;
---------------------
-- Matching_Actual --
---------------------
@ -1131,6 +1171,7 @@ package body Sem_Ch12 is
while Present (Actual) loop
if Nkind (Actual) = N_Others_Choice then
Others_Present := True;
Others_Choice := Actual;
if Present (Next (Actual)) then
Error_Msg_N ("others must be last association", Actual);
@ -1293,24 +1334,7 @@ package body Sem_Ch12 is
and then Is_Named_Assoc
and then Comes_From_Source (Found_Assoc)
then
Temp_Formal := First (Formals);
while Present (Temp_Formal) loop
if Nkind (Temp_Formal) in
N_Formal_Subprogram_Declaration
and then Temp_Formal /= Formal
and then
Chars (Selector_Name (Found_Assoc)) =
Chars (Defining_Unit_Name
(Specification (Temp_Formal)))
then
Error_Msg_N
("name not allowed for overloaded formal",
Found_Assoc);
Abandon_Instantiation (Instantiation_Node);
end if;
Next (Temp_Formal);
end loop;
Check_Overloaded_Formal_Subprogram (Formal);
end if;
-- If there is no corresponding actual, this may be case of
@ -1321,6 +1345,10 @@ package body Sem_Ch12 is
and then Partial_Parametrization
then
Process_Default (Formal);
if Nkind (I_Node) = N_Formal_Package_Declaration then
Check_Overloaded_Formal_Subprogram (Formal);
end if;
else
Append_To (Assoc,
Instantiate_Formal_Subprogram

22
gcc/ada/sem_ch3.adb
View File

@ -7006,6 +7006,28 @@ package body Sem_Ch3 is
Parent_Base := Base_Type (Parent_Type);
end if;
-- AI05-0115 : if this is a derivation from a private type in some
-- other scope that may lead to invisible components for the derived
-- type, mark it accordingly.
if Is_Private_Type (Parent_Type) then
if Scope (Parent_Type) = Scope (Derived_Type) then
null;
elsif In_Open_Scopes (Scope (Parent_Type))
and then In_Private_Part (Scope (Parent_Type))
then
null;
else
Set_Has_Private_Ancestor (Derived_Type);
end if;
else
Set_Has_Private_Ancestor
(Derived_Type, Has_Private_Ancestor (Parent_Type));
end if;
-- Before we start the previously documented transformations, here is
-- little fix for size and alignment of tagged types. Normally when we
-- derive type D from type P, we copy the size and alignment of P as the

6
gcc/ada/switch-c.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -1058,6 +1058,10 @@ package body Switch.C is
Osint.Fail
("-gnatZ is no longer supported: consider using --RTS=zcx");
-- Note on language version switches: whenever a new language
-- version switch is added, function Switch.Is_Language_Switch and
-- procedure Switch.M.Normalize_Compiler_Switches must be updated.
-- Processing for 83 switch
when '8' =>

52
gcc/ada/switch-m.adb
View File

@ -548,6 +548,58 @@ package body Switch.M is
Ptr := Ptr + 1;
end if;
-- -gnat12
when '1' =>
Last_Stored := First_Stored;
Storing (Last_Stored) := C;
Ptr := Ptr + 1;
if Ptr /= Max or else Switch_Chars (Ptr) /= '2' then
-- Invalid switch
Last := 0;
return;
else
Last_Stored := Last_Stored + 1;
Storing (Last_Stored) := '2';
Add_Switch_Component
(Storing (Storing'First .. Last_Stored));
Ptr := Ptr + 1;
end if;
-- -gnat2005 -gnat2012
when '2' =>
if Ptr + 3 /= Max then
Last := 0;
return;
elsif Switch_Chars (Ptr + 1 .. Ptr + 3) = "005" then
Last_Stored := First_Stored + 3;
Storing (First_Stored .. Last_Stored) := "2005";
Add_Switch_Component
(Storing (Storing'First .. Last_Stored));
Ptr := Max + 1;
elsif Switch_Chars (Ptr + 1 .. Ptr + 3) = "012" then
Last_Stored := First_Stored + 3;
Storing (First_Stored .. Last_Stored) := "2012";
Add_Switch_Component
(Storing (Storing'First .. Last_Stored));
Ptr := Max + 1;
else
-- Invalid switch
Last := 0;
return;
end if;
-- -gnat83
when '8' =>

19
gcc/ada/switch.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- 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- --
@ -138,6 +138,23 @@ package body Switch is
and then Switch_Chars (Ptr + 2 .. Ptr + 4) = "RTS"));
end Is_Front_End_Switch;
-------------------------
-- Is_Language_Switch --
-------------------------
function Is_Language_Switch (Switch_Chars : String) return Boolean is
Ptr : constant Positive := Switch_Chars'First;
begin
return Is_Switch (Switch_Chars)
and then
(Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat83"
or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat95"
or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat05"
or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat2005"
or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat12"
or else Switch_Chars (Ptr + 1 .. Switch_Chars'Last) = "gnat2012");
end Is_Language_Switch;
----------------------------
-- Is_Internal_GCC_Switch --
----------------------------

6
gcc/ada/switch.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- --
@ -72,6 +72,10 @@ package Switch is
-- Returns True iff Switch_Chars represents a front-end switch, i.e. it
-- starts with -I, -gnat or -?RTS.
function Is_Language_Switch (Switch_Chars : String) return Boolean;
-- Returns True iff Switch_Chars represents a language switch, i.e. it
-- specifies -gnat83/95/2005/2012.
function Is_Internal_GCC_Switch (Switch_Chars : String) return Boolean;
-- Returns True iff Switch_Chars represents an internal GCC switch to be
-- followed by a single argument, such as -dumpbase, --param or -auxbase.

4
gcc/ada/vms_conv.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
@ -1962,7 +1962,7 @@ package body VMS_Conv is
end if;
when T_File | T_No_Space_File =>
if SwP + 1 > Arg'Last then
if SwP + 2 > Arg'Last then
Put (Standard_Error,
"missing file for: ");
Put_Line (Standard_Error, Arg.all);