[multiple changes]

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.

From-SVN: r177401

gcc/ada/ChangeLog

+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,

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);
 

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;

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
 

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;

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.

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;

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.

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;

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;
 
    ------------------------

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,

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.
 

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;

gcc/ada/s-atocou.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;

gcc/ada/s-atocou.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;