diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 51 | ||||
| -rw-r--r-- | gcc/ada/a-coinho.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/a-coinho.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/a-strunb-shared.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/a-strunb-shared.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/a-stwiun-shared.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/a-stwiun-shared.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/a-stzunb-shared.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/a-stzunb-shared.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/a-tags.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 218 | ||||
| -rw-r--r-- | gcc/ada/exp_strm.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/gnatls.adb | 106 | ||||
| -rw-r--r-- | gcc/ada/s-atocou.adb | 74 | ||||
| -rw-r--r-- | gcc/ada/s-atocou.ads | 70 |
15 files changed, 377 insertions, 273 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9f3bcb56e17..4611e705ced 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,54 @@ +2011-08-04 Thomas Quinot <quinot@adacore.com> + + * gnatls.adb: Use Prj.Env.Initialize_Default_Project_Path to retrieve + the project path. + +2011-08-04 Robert Dewar <dewar@adacore.com> + + * a-coinho.adb: Minor reformatting. + +2011-08-04 Robert Dewar <dewar@adacore.com> + + * a-coinho.ads: Minor reformatting. + +2011-08-04 Vadim Godunko <godunko@adacore.com> + + * s-atocou.ads, s-atocou.adb: New files. + * a-strunb-shared.ads, a-strunb-shared.adb, a-stwiun-shared.ads, + a-stwiun-shared.adb, a-stzunb-shared.ads, a-stzunb-shared.adb: Remove + direct use of GCC's atomic builtins and replace them by use of new + atomic counter package. + +2011-08-04 Ed Schonberg <schonberg@adacore.com> + + * exp_strm.adb: better error message for No_Default_Stream_Attributes. + +2011-08-04 Hristian Kirtchev <kirtchev@adacore.com> + + * a-tags.adb (Unregister_Tag): Replace the complex address arithmetic + with a call to Get_External_Tag. + * exp_ch7.adb (Build_Cleanup_Statements): Update the comment on + subprogram usage. Remove the guard against package declarations and + bodies since Build_Cleanup_Statements is no longer invoked in that + context. + (Build_Components): Initialize Tagged_Type_Stmts when the context + contains at least one library-level tagged type. + (Build_Finalizer): New local variables Has_Tagged_Types and + Tagged_Type_Stmts along with associated comments on usage. Update the + logic to include tagged type processing. + (Create_Finalizer): Insert all library-level tagged type unregistration + code before the jump block circuitry. + (Expand_N_Package_Body): Remove the call to Build_Cleanup_Statements. + (Expand_N_Package_Declaration): Remove the call to + Build_Cleanup_Statements. + (Process_Tagged_Type_Declaration): New routine. Generate a call to + unregister the external tag of a tagged type. + (Processing_Actions): Reimplemented to handle tagged types. + (Process_Declarations): Detect the declaration of a library-level + tagged type and carry out the appropriate actions. + (Unregister_Tagged_Types): Removed. The machinery has been directly + merged with Build_Finalizer. + 2011-08-04 Robert Dewar <dewar@adacore.com> * bindgen.ads, gnatlink.adb, sem_ch4.adb, gnatbind.adb, put_alfa.adb, diff --git a/gcc/ada/a-coinho.adb b/gcc/ada/a-coinho.adb index 539c3b1b792..b6c38b098b6 100644 --- a/gcc/ada/a-coinho.adb +++ b/gcc/ada/a-coinho.adb @@ -102,7 +102,6 @@ package body Ada.Containers.Indefinite_Holders is begin if Source.Element = null then return (AF.Controlled with null, 0); - else return (AF.Controlled with new Element_Type'(Source.Element.all), 0); end if; @@ -116,7 +115,6 @@ package body Ada.Containers.Indefinite_Holders is begin if Container.Element = null then raise Constraint_Error with "container is empty"; - else return Container.Element.all; end if; @@ -184,11 +182,9 @@ package body Ada.Containers.Indefinite_Holders is begin Process (Container.Element.all); - exception when others => B := B - 1; - raise; end; @@ -201,7 +197,8 @@ package body Ada.Containers.Indefinite_Holders is procedure Read (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : out Holder) is + Container : out Holder) + is begin Clear (Container); @@ -215,7 +212,9 @@ package body Ada.Containers.Indefinite_Holders is --------------------- procedure Replace_Element - (Container : in out Holder; New_Item : Element_Type) is + (Container : in out Holder; + New_Item : Element_Type) + is begin if Container.Busy /= 0 then raise Program_Error with "attempt to tamper with elements"; @@ -253,11 +252,9 @@ package body Ada.Containers.Indefinite_Holders is begin Process (Container.Element.all); - exception when others => B := B - 1; - raise; end; @@ -270,7 +267,8 @@ package body Ada.Containers.Indefinite_Holders is procedure Write (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : Holder) is + Container : Holder) + is begin Boolean'Output (Stream, Container.Element = null); diff --git a/gcc/ada/a-coinho.ads b/gcc/ada/a-coinho.ads index 63bcb34c031..d5d0cf40478 100644 --- a/gcc/ada/a-coinho.ads +++ b/gcc/ada/a-coinho.ads @@ -56,7 +56,8 @@ package Ada.Containers.Indefinite_Holders is function Element (Container : Holder) return Element_Type; procedure Replace_Element - (Container : in out Holder; New_Item : Element_Type); + (Container : in out Holder; + New_Item : Element_Type); procedure Query_Element (Container : Holder; diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb index b0e413dde8b..cf2582a7dea 100644 --- a/gcc/ada/a-strunb-shared.adb +++ b/gcc/ada/a-strunb-shared.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, 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- -- @@ -50,16 +50,6 @@ package body Ada.Strings.Unbounded is -- align the returned memory on the maximum alignment as malloc does not -- know the target alignment. - procedure Sync_Add_And_Fetch - (Ptr : access Interfaces.Unsigned_32; - Value : Interfaces.Unsigned_32); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); - - function Sync_Sub_And_Fetch - (Ptr : access Interfaces.Unsigned_32; - Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; - pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); - function Aligned_Max_Length (Max_Length : Natural) return Natural; -- Returns recommended length of the shared string which is greater or -- equal to specified length. Calculation take in sense alignment of the @@ -633,12 +623,10 @@ package body Ada.Strings.Unbounded is function Can_Be_Reused (Item : Shared_String_Access; - Length : Natural) return Boolean - is - use Interfaces; + Length : Natural) return Boolean is begin return - Item.Counter = 1 + System.Atomic_Counters.Is_One (Item.Counter) and then Item.Max_Length >= Length and then Item.Max_Length <= Aligned_Max_Length (Length + Length / Growth_Factor); @@ -1282,7 +1270,7 @@ package body Ada.Strings.Unbounded is procedure Reference (Item : not null Shared_String_Access) is begin - Sync_Add_And_Fetch (Item.Counter'Access, 1); + System.Atomic_Counters.Increment (Item.Counter); end Reference; --------------------- @@ -2082,7 +2070,6 @@ package body Ada.Strings.Unbounded is ----------------- procedure Unreference (Item : not null Shared_String_Access) is - use Interfaces; procedure Free is new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); @@ -2090,7 +2077,7 @@ package body Ada.Strings.Unbounded is Aux : Shared_String_Access := Item; begin - if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + if System.Atomic_Counters.Decrement (Aux.Counter) then -- Reference counter of Empty_Shared_String must never reach zero diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads index 617e210bbb1..e952b8e849d 100644 --- a/gcc/ada/a-strunb-shared.ads +++ b/gcc/ada/a-strunb-shared.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -70,7 +70,7 @@ with Ada.Strings.Maps; private with Ada.Finalization; -private with Interfaces; +private with System.Atomic_Counters; package Ada.Strings.Unbounded is pragma Preelaborate; @@ -430,7 +430,7 @@ private package AF renames Ada.Finalization; type Shared_String (Max_Length : Natural) is limited record - Counter : aliased Interfaces.Unsigned_32 := 1; + Counter : System.Atomic_Counters.Atomic_Counter; -- Reference counter Last : Natural := 0; diff --git a/gcc/ada/a-stwiun-shared.adb b/gcc/ada/a-stwiun-shared.adb index 95b17eff5f8..5ee93e85ff3 100644 --- a/gcc/ada/a-stwiun-shared.adb +++ b/gcc/ada/a-stwiun-shared.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, 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- -- @@ -50,16 +50,6 @@ package body Ada.Strings.Wide_Unbounded is -- align the returned memory on the maximum alignment as malloc does not -- know the target alignment. - procedure Sync_Add_And_Fetch - (Ptr : access Interfaces.Unsigned_32; - Value : Interfaces.Unsigned_32); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); - - function Sync_Sub_And_Fetch - (Ptr : access Interfaces.Unsigned_32; - Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; - pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); - function Aligned_Max_Length (Max_Length : Natural) return Natural; -- Returns recommended length of the shared string which is greater or -- equal to specified length. Calculation take in sense alignment of @@ -636,12 +626,10 @@ package body Ada.Strings.Wide_Unbounded is function Can_Be_Reused (Item : Shared_Wide_String_Access; - Length : Natural) return Boolean - is - use Interfaces; + Length : Natural) return Boolean is begin return - Item.Counter = 1 + System.Atomic_Counters.Is_One (Item.Counter) and then Item.Max_Length >= Length and then Item.Max_Length <= Aligned_Max_Length (Length + Length / Growth_Factor); @@ -1294,7 +1282,7 @@ package body Ada.Strings.Wide_Unbounded is procedure Reference (Item : not null Shared_Wide_String_Access) is begin - Sync_Add_And_Fetch (Item.Counter'Access, 1); + System.Atomic_Counters.Increment (Item.Counter); end Reference; --------------------- @@ -2100,7 +2088,6 @@ package body Ada.Strings.Wide_Unbounded is ----------------- procedure Unreference (Item : not null Shared_Wide_String_Access) is - use Interfaces; procedure Free is new Ada.Unchecked_Deallocation @@ -2109,7 +2096,7 @@ package body Ada.Strings.Wide_Unbounded is Aux : Shared_Wide_String_Access := Item; begin - if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + if System.Atomic_Counters.Decrement (Aux.Counter) then -- Reference counter of Empty_Shared_Wide_String must never reach -- zero. diff --git a/gcc/ada/a-stwiun-shared.ads b/gcc/ada/a-stwiun-shared.ads index 3535e070ca0..feaad8ed4e5 100644 --- a/gcc/ada/a-stwiun-shared.ads +++ b/gcc/ada/a-stwiun-shared.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -42,7 +42,7 @@ with Ada.Strings.Wide_Maps; private with Ada.Finalization; -private with Interfaces; +private with System.Atomic_Counters; package Ada.Strings.Wide_Unbounded is pragma Preelaborate; @@ -408,7 +408,7 @@ private package AF renames Ada.Finalization; type Shared_Wide_String (Max_Length : Natural) is limited record - Counter : aliased Interfaces.Unsigned_32 := 1; + Counter : System.Atomic_Counters.Atomic_Counter; -- Reference counter. Last : Natural := 0; diff --git a/gcc/ada/a-stzunb-shared.adb b/gcc/ada/a-stzunb-shared.adb index 965d856e182..18fe75b8c54 100644 --- a/gcc/ada/a-stzunb-shared.adb +++ b/gcc/ada/a-stzunb-shared.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, 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- -- @@ -50,16 +50,6 @@ package body Ada.Strings.Wide_Wide_Unbounded is -- align the returned memory on the maximum alignment as malloc does not -- know the target alignment. - procedure Sync_Add_And_Fetch - (Ptr : access Interfaces.Unsigned_32; - Value : Interfaces.Unsigned_32); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); - - function Sync_Sub_And_Fetch - (Ptr : access Interfaces.Unsigned_32; - Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; - pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); - function Aligned_Max_Length (Max_Length : Natural) return Natural; -- Returns recommended length of the shared string which is greater or -- equal to specified length. Calculation take in sense alignment of @@ -638,12 +628,10 @@ package body Ada.Strings.Wide_Wide_Unbounded is function Can_Be_Reused (Item : Shared_Wide_Wide_String_Access; - Length : Natural) return Boolean - is - use Interfaces; + Length : Natural) return Boolean is begin return - Item.Counter = 1 + System.Atomic_Counters.Is_One (Item.Counter) and then Item.Max_Length >= Length and then Item.Max_Length <= Aligned_Max_Length (Length + Length / Growth_Factor); @@ -1304,7 +1292,7 @@ package body Ada.Strings.Wide_Wide_Unbounded is procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is begin - Sync_Add_And_Fetch (Item.Counter'Access, 1); + System.Atomic_Counters.Increment (Item.Counter); end Reference; --------------------- @@ -2113,7 +2101,6 @@ package body Ada.Strings.Wide_Wide_Unbounded is ----------------- procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is - use Interfaces; procedure Free is new Ada.Unchecked_Deallocation @@ -2122,7 +2109,7 @@ package body Ada.Strings.Wide_Wide_Unbounded is Aux : Shared_Wide_Wide_String_Access := Item; begin - if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + if System.Atomic_Counters.Decrement (Aux.Counter) then -- Reference counter of Empty_Shared_Wide_Wide_String must never -- reach zero. diff --git a/gcc/ada/a-stzunb-shared.ads b/gcc/ada/a-stzunb-shared.ads index e8376093e57..6b4bb6c8789 100644 --- a/gcc/ada/a-stzunb-shared.ads +++ b/gcc/ada/a-stzunb-shared.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -42,7 +42,7 @@ with Ada.Strings.Wide_Wide_Maps; private with Ada.Finalization; -private with Interfaces; +private with System.Atomic_Counters; package Ada.Strings.Wide_Wide_Unbounded is pragma Preelaborate; @@ -417,7 +417,7 @@ private package AF renames Ada.Finalization; type Shared_Wide_Wide_String (Max_Length : Natural) is limited record - Counter : aliased Interfaces.Unsigned_32 := 1; + Counter : System.Atomic_Counters.Atomic_Counter; -- Reference counter. Last : Natural := 0; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index b9f1491dacf..4731bb90900 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -1010,12 +1010,8 @@ package body Ada.Tags is -------------------- 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)); + External_Tag_HTable.Remove (Get_External_Tag (T)); end Unregister_Tag; ------------------------ diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index aef06214b2f..40499bc7c79 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -297,11 +297,9 @@ 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. 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. + -- protected subprogram body, task allocation block or task body. If the + -- context does not contain the above constructs, the routine returns an + -- empty list. function Build_Exception_Handler (Loc : Source_Ptr; @@ -489,11 +487,8 @@ 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 := - not Nkind_In (N, N_Entry_Body, - N_Package_Body, - N_Package_Declaration) + Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); Is_Protected_Body : constant Boolean := Nkind (N) = N_Subprogram_Body @@ -507,59 +502,6 @@ 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 @@ -770,26 +712,6 @@ 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; @@ -1207,6 +1129,10 @@ package body Exp_Ch7 is -- A general flag which denotes whether N has at least one controlled -- object. + Has_Tagged_Types : Boolean := False; + -- A general flag which denotes whether N has at least one library-level + -- tagged type declaration. + HSS : Node_Id := Empty; -- The sequence of statements of N (if available) @@ -1241,6 +1167,10 @@ package body Exp_Ch7 is Spec_Decls : List_Id := Top_Decls; Stmts : List_Id := No_List; + Tagged_Type_Stmts : List_Id := No_List; + -- Contains calls to Ada.Tags.Unregister_Tag for all library-level + -- tagged types found in N. + ----------------------- -- Local subprograms -- ----------------------- @@ -1272,6 +1202,10 @@ package body Exp_Ch7 is -- where Decl does not have initialization call(s). Flag Is_Protected -- is set when Decl denotes a simple protected object. + procedure Process_Tagged_Type_Declaration (Decl : Node_Id); + -- Generate all the code necessary to unregister the external tag of a + -- tagged type. + ---------------------- -- Build_Components -- ---------------------- @@ -1378,6 +1312,10 @@ package body Exp_Ch7 is else Finalizer_Stmts := New_List; end if; + + if Has_Tagged_Types then + Tagged_Type_Stmts := New_List; + end if; end Build_Components; ---------------------- @@ -1543,6 +1481,14 @@ package body Exp_Ch7 is end if; end if; + -- Add the library-level tagged type unregistration machinery before + -- the jump block circuitry. This ensures that external tags will be + -- removed even if a finalization exception occurs at some point. + + if Has_Tagged_Types then + Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts); + end if; + -- Add a call to the previous At_End handler if it exists. The call -- must always precede the jump block. @@ -1784,17 +1730,36 @@ package body Exp_Ch7 is Is_Protected : Boolean := False) is begin - if Preprocess then - Counter_Val := Counter_Val + 1; - Has_Ctrl_Objs := True; + -- Library-level tagged type - if Top_Level - and then No (Last_Top_Level_Ctrl_Construct) - then - Last_Top_Level_Ctrl_Construct := Decl; + if Nkind (Decl) = N_Full_Type_Declaration then + if Preprocess then + Has_Tagged_Types := True; + + if Top_Level + and then No (Last_Top_Level_Ctrl_Construct) + then + Last_Top_Level_Ctrl_Construct := Decl; + end if; + else + Process_Tagged_Type_Declaration (Decl); end if; + + -- Controlled object declaration + else - Process_Object_Declaration (Decl, Has_No_Init, Is_Protected); + if Preprocess then + Counter_Val := Counter_Val + 1; + Has_Ctrl_Objs := True; + + if Top_Level + and then No (Last_Top_Level_Ctrl_Construct) + then + Last_Top_Level_Ctrl_Construct := Decl; + end if; + else + Process_Object_Declaration (Decl, Has_No_Init, Is_Protected); + end if; end if; end Processing_Actions; @@ -1810,9 +1775,25 @@ package body Exp_Ch7 is Decl := Last_Non_Pragma (Decls); 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_Register_Tag) + and then not No_Run_Time_Mode + and then not Is_Abstract_Type (Typ) + then + Processing_Actions; + end if; + -- Regular object declarations - if Nkind (Decl) = N_Object_Declaration then + elsif Nkind (Decl) = N_Object_Declaration then Obj_Id := Defining_Identifier (Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); Expr := Expression (Decl); @@ -2687,12 +2668,33 @@ package body Exp_Ch7 is Counter_Val := Counter_Val - 1; end Process_Object_Declaration; + ------------------------------------- + -- Process_Tagged_Type_Declaration -- + ------------------------------------- + + procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is + Typ : constant Entity_Id := Defining_Identifier (Decl); + DT_Ptr : constant Entity_Id := + Node (First_Elmt (Access_Disp_Table (Typ))); + begin + -- Generate: + -- Ada.Tags.Unregister_Tag (<Typ>P); + + Append_To (Tagged_Type_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 Process_Tagged_Type_Declaration; + -- Start of processing for Build_Finalizer begin Fin_Id := Empty; - -- Step 1: Extract all lists which may contain controlled objects + -- Step 1: Extract all lists which may contain controlled objects or + -- library-level tagged types. if For_Package_Spec then Decls := Visible_Declarations (Specification (N)); @@ -2772,15 +2774,19 @@ package body Exp_Ch7 is -- cases, the finalizer must be created and carry the additional -- statements. - if Acts_As_Clean or else Has_Ctrl_Objs then + if Acts_As_Clean + or else Has_Ctrl_Objs + or else Has_Tagged_Types + then Build_Components; end if; - -- The preprocessing has determined that the context has objects that - -- need finalization actions. - - if Has_Ctrl_Objs then + -- The preprocessing has determined that the context has controlled + -- objects or library-level tagged types. + if Has_Ctrl_Objs + or else Has_Tagged_Types + then -- Private declarations are processed first in order to preserve -- possible dependencies between public and private objects. @@ -2814,11 +2820,16 @@ package body Exp_Ch7 is -- cases, the finalizer must be created and carry the additional -- statements. - if Acts_As_Clean or else Has_Ctrl_Objs then + if Acts_As_Clean + or else Has_Ctrl_Objs + or else Has_Tagged_Types + then Build_Components; end if; - if Has_Ctrl_Objs then + if Has_Ctrl_Objs + or else Has_Tagged_Types + then Process_Declarations (Stmts); Process_Declarations (Decls); end if; @@ -2826,7 +2837,10 @@ package body Exp_Ch7 is -- Step 3: Finalizer creation - if Acts_As_Clean or else Has_Ctrl_Objs then + if Acts_As_Clean + or else Has_Ctrl_Objs + or else Has_Tagged_Types + then Create_Finalizer; end if; end Build_Finalizer; @@ -3830,7 +3844,7 @@ package body Exp_Ch7 is if Ekind (Spec_Ent) /= E_Generic_Package then Build_Finalizer (N => N, - Clean_Stmts => Build_Cleanup_Statements (N), + Clean_Stmts => No_List, Mark_Id => Empty, Top_Decls => No_List, Defer_Abort => False, @@ -3954,7 +3968,7 @@ package body Exp_Ch7 is if Ekind (Id) /= E_Generic_Package then Build_Finalizer (N => N, - Clean_Stmts => Build_Cleanup_Statements (N), + Clean_Stmts => No_List, Mark_Id => Empty, Top_Decls => No_List, Defer_Abort => False, diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index f70ec41eac6..907c32add5c 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Einfo; use Einfo; +with Errout; use Errout; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; @@ -476,6 +477,15 @@ package body Exp_Strm is begin Check_Restriction (No_Default_Stream_Attributes, N); + if Restriction_Active (No_Default_Stream_Attributes) then + Error_Msg_NE + ("missing user-defined Input for type&", N, Etype (Targ)); + if Nkind (Targ) = N_Selected_Component then + Error_Msg_NE + ("\which is a component of type&", N, Etype (Prefix (Targ))); + end if; + end if; + -- Check first for Boolean and Character. These are enumeration types, -- but we treat them specially, since they may require special handling -- in the transfer protocol. However, this special handling only applies @@ -686,6 +696,15 @@ package body Exp_Strm is begin Check_Restriction (No_Default_Stream_Attributes, N); + if Restriction_Active (No_Default_Stream_Attributes) then + Error_Msg_NE + ("missing user-defined Write for type&", N, Etype (Item)); + if Nkind (Item) = N_Selected_Component then + Error_Msg_NE + ("\which is a component of type&", N, Etype (Prefix (Item))); + end if; + end if; + -- Compute the size of the stream element. This is either the size of -- the first subtype or if given the size of the Stream_Size attribute. diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index a2612861c08..f7f4ddb45fe 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -36,6 +36,7 @@ with Opt; use Opt; with Osint; use Osint; with Osint.L; use Osint.L; with Output; use Output; +with Prj.Env; use Prj.Env; with Rident; use Rident; with Sdefault; with Snames; @@ -47,12 +48,6 @@ with GNAT.Case_Util; use GNAT.Case_Util; procedure Gnatls is pragma Ident (Gnat_Static_Version_String); - Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; - Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; - -- Names of the env. variables that contains path name(s) of directories - -- where project files may reside. If GPR_PROJECT_PATH is defined, its - -- value is used, otherwise ADA_PROJECT_PATH is used, if defined. - -- NOTE : The following string may be used by other tools, such as GPS. So -- it can only be modified if these other uses are checked and coordinated. @@ -60,7 +55,7 @@ procedure Gnatls is -- Label displayed in verbose mode before the directories in the project -- search path. Do not modify without checking NOTE above. - No_Project_Default_Dir : constant String := "-"; + Prj_Path : Prj.Env.Project_Search_Path; Max_Column : constant := 80; @@ -223,7 +218,7 @@ procedure Gnatls is end if; end Add_Lib_Dir; - -- ----------------- + -------------------- -- Add_Source_Dir -- -------------------- @@ -1614,27 +1609,16 @@ begin Write_Str (" <Current_Directory>"); Write_Eol; - -- The code below reproduces Prj.Env.Initialize_Default_Project_Path, - -- shouldn't we reuse that instead??? + Initialize_Default_Project_Path + (Prj_Path, Target_Name => Sdefault.Target_Name.all); declare - Project_Path : String_Access := Getenv (Gpr_Project_Path); - - Lib : constant String := - Directory_Separator & "lib" & Directory_Separator; - - First : Natural; - Last : Natural; - - Add_Default_Dir : Boolean := True; - Prefix_Name_Len : Integer; + Project_Path : String_Access; + First : Natural; + Last : Natural; begin - -- If there is a project path, display each directory in the path - - if Project_Path.all = "" then - Project_Path := Getenv (Ada_Project_Path); - end if; + Get_Path (Prj_Path, Project_Path); if Project_Path.all /= "" then First := Project_Path'First; @@ -1654,13 +1638,7 @@ begin Last := Last + 1; end loop; - -- If the directory is No_Default_Project_Dir, set - -- Add_Default_Dir to False. - - if Project_Path (First .. Last) = No_Project_Default_Dir then - Add_Default_Dir := False; - - elsif First /= Last or else Project_Path (First) /= '.' then + if First /= Last or else Project_Path (First) /= '.' then -- If the directory is ".", skip it as it is the current -- directory and it is already the first directory in the @@ -1668,73 +1646,15 @@ begin Write_Str (" "); Write_Str - (To_Host_Dir_Spec - (Project_Path (First .. Last), True).all); + (Normalize_Pathname + (To_Host_Dir_Spec + (Project_Path (First .. Last), True).all)); Write_Eol; end if; First := Last + 1; end loop; end if; - - -- Add the default dir, except if "-" was one of the "directories" - -- specified in ADA_PROJECT_DIR. - - if Add_Default_Dir then - Name_Len := 0; - Add_Str_To_Name_Buffer (Sdefault.Search_Dir_Prefix.all); - - -- On Windows, make sure that all directory separators are '\' - - if Directory_Separator /= '/' then - for J in 1 .. Name_Len loop - if Name_Buffer (J) = '/' then - Name_Buffer (J) := Directory_Separator; - end if; - end loop; - end if; - - -- Find the sequence "/lib/" - - while Name_Len >= Lib'Length - and then Name_Buffer (Name_Len - 4 .. Name_Len) /= Lib - loop - Name_Len := Name_Len - 1; - end loop; - - -- If the sequence "/lib"/ was found, display the default - -- directories <prefix>/<target>/lib/gnat and <prefix>/lib/gnat/. - - if Name_Len >= 5 then - Prefix_Name_Len := Name_Len - 4; - - Name_Len := Prefix_Name_Len; - - Name_Len := Prefix_Name_Len; - Add_Str_To_Name_Buffer (Sdefault.Target_Name.all); - Name_Len := Name_Len - 1; - Add_Str_To_Name_Buffer (Directory_Separator - & "lib" & Directory_Separator - & "gnat" & Directory_Separator); - Write_Str (" "); - Write_Line - (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all); - - Name_Len := Prefix_Name_Len; - Add_Str_To_Name_Buffer ("share" & Directory_Separator - & "gpr" & Directory_Separator); - Write_Str (" "); - Write_Line - (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all); - - Name_Len := Prefix_Name_Len; - Add_Str_To_Name_Buffer ("lib" & Directory_Separator - & "gnat" & Directory_Separator); - Write_Str (" "); - Write_Line - (To_Host_Dir_Spec (Name_Buffer (1 .. Name_Len), True).all); - end if; - end if; end; Write_Eol; diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb new file mode 100644 index 00000000000..38ef24a202b --- /dev/null +++ b/gcc/ada/s-atocou.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, AdaCore -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides implementation of atomic counter for platforms where +-- GCC supports __sync_add_and_fetch_4 and __sync_sub_and_fetch_4 builtins. + +package body System.Atomic_Counters is + + procedure Sync_Add_And_Fetch + (Ptr : access Unsigned_32; + Value : Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Unsigned_32; + Value : Unsigned_32) return Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + --------------- + -- Decrement -- + --------------- + + function Decrement (Item : in out Atomic_Counter) return Boolean is + begin + return Sync_Sub_And_Fetch (Item.Value'Access, 1) = 0; + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Item : in out Atomic_Counter) is + begin + Sync_Add_And_Fetch (Item.Value'Access, 1); + end Increment; + + ------------ + -- Is_One -- + ------------ + + function Is_One (Item : Atomic_Counter) return Boolean is + begin + return Item.Value = 1; + end Is_One; + +end System.Atomic_Counters; diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads new file mode 100644 index 00000000000..20ef9e50144 --- /dev/null +++ b/gcc/ada/s-atocou.ads @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011, AdaCore -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides atomic counter on platforms where it is supported. + +package System.Atomic_Counters is + + pragma Preelaborate; + + type Atomic_Counter is limited private; + -- Type for atomic counter objects. Note, initial value of the counter is + -- one. This allows to use atomic counter as member of record types when + -- object of these types are created at library level on preelaboratable + -- compilation units. + -- + -- Atomic counter is declared as private limited type to provide highest + -- level of protection from unexpected use. All available operations are + -- declared below, and this set should be as small as possible. + + procedure Increment (Item : in out Atomic_Counter); + pragma Inline_Always (Increment); + -- Increments value of atomic counter. + + function Decrement (Item : in out Atomic_Counter) return Boolean; + pragma Inline_Always (Decrement); + -- Decrements value of atomic counter, returns True when value reach zero. + + function Is_One (Item : Atomic_Counter) return Boolean; + pragma Inline_Always (Is_One); + -- Returns True when value of the atomic counter is one. + +private + + type Unsigned_32 is mod 2 ** 32; + + type Atomic_Counter is limited record + Value : aliased Unsigned_32 := 1; + pragma Atomic (Value); + pragma Volatile (Value); + end record; + +end System.Atomic_Counters; |
