Skip to content

R
riscv-gcc-1
Commit 26e7e1a0 by Arnaud Charlet
Options

[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
parent 7483c888
Showing with 377 additions and 273 deletions
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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment