diff options
| author | Arnaud Charlet <charlet@adacore.com> | 2011-08-04 13:13:59 +0000 |
|---|---|---|
| committer | Arnaud Charlet <charlet@adacore.com> | 2011-08-04 13:13:59 +0000 |
| commit | 56ef2271ebb96d9d697b05f288a71e0cca524573 (patch) | |
| tree | eebd9dc812e5d2083834dcc4dc232956690041f3 | |
| parent | 04d6e2dd3ca494ca3dfeac3907d46946767e3a88 (diff) | |
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.
git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@177378 138bc75d-0d04-0410-961f-82ee72b054a4
| -rw-r--r-- | gcc/ada/ChangeLog | 103 | ||||
| -rw-r--r-- | gcc/ada/a-tags.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/a-tags.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/alfa.ads | 17 | ||||
| -rw-r--r-- | gcc/ada/bindgen.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 118 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 489 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 20 | ||||
| -rw-r--r-- | gcc/ada/g-regist.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/get_alfa.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/gnatlink.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/lib-xref-alfa.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/prj-env.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/put_alfa.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/s-tasdeb.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 96 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 66 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/switch-m.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/switch.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/switch.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/vms_conv.adb | 4 |
27 files changed, 828 insertions, 329 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2895bd877c1..0321d69127a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 0fbb6025ffc..b9f1491dacf 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -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 -- ------------------------ diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 99ee5aa1aec..5170793f981 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -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: -- diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads index 71220e46bda..39bddabf29d 100644 --- a/gcc/ada/alfa.ads +++ b/gcc/ada/alfa.ads @@ -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 diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index a31b0e266ab..3f88f66f9ab 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -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"");"); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 54f7c87acdb..383ec9cdd13 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c870728026a..3fb2e41b93b 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 9a648e5fb5d..678948ad879 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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); + end if; - -- 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. + -- 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 Has_Ctrl_Objs then - Build_Components; - Process_Declarations (Priv_Decls); - end if; + if Acts_As_Clean or else Has_Ctrl_Objs then + Build_Components; end if; - -- Process the public declarations + -- 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, diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index e3304a41d16..4df6eff6021 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 83682e73652..83fed95a675 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 -- ------------------------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 67cdceba0b9..a60f40ffd32 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -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 diff --git a/gcc/ada/g-regist.ads b/gcc/ada/g-regist.ads index 52dc6aadb3f..c7ad4dcfe11 100644 --- a/gcc/ada/g-regist.ads +++ b/gcc/ada/g-regist.ads @@ -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#; diff --git a/gcc/ada/get_alfa.adb b/gcc/ada/get_alfa.adb index 0fc967a0b3d..6c2391ec9d1 100644 --- a/gcc/ada/get_alfa.adb +++ b/gcc/ada/get_alfa.adb @@ -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, diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 6a0a34e78ff..c2e2de74f49 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -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); diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 701de0b8624..4f52676474f 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -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), diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 15a443698fa..f2c8500f9ee 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -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)); diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_alfa.adb index bf35cbbabf5..dad65b91460 100644 --- a/gcc/ada/put_alfa.adb +++ b/gcc/ada/put_alfa.adb @@ -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 (' '); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 9ccb5d36d89..1d545dfe596 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads index 806fe0ee7b6..0d0df436ad6 100644 --- a/gcc/ada/s-tasdeb.ads +++ b/gcc/ada/s-tasdeb.ads @@ -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; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index e8ce47de534..a226c4810e7 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -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 + -- AI05-0115: check legality of aggregate for type with + -- aa private ancestor. + 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 - 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; + -- 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)); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index de9f5781fc9..f2d8a35ea46 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 3f09dd63aae..721ded18548 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index a5528810654..b0be8908b90 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -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' => diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 4d2751c53d6..93583f0ada7 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -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' => diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb index cb5c4d11f49..e2987060858 100644 --- a/gcc/ada/switch.adb +++ b/gcc/ada/switch.adb @@ -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 -- ---------------------------- diff --git a/gcc/ada/switch.ads b/gcc/ada/switch.ads index f7c62cba233..d7afa9aa44a 100644 --- a/gcc/ada/switch.ads +++ b/gcc/ada/switch.ads @@ -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. diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index b8060531477..3f5421ee4d7 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -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); |