+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,
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;
begin
if Container.Element = null then
raise Constraint_Error with "container is empty";
-
else
return Container.Element.all;
end if;
begin
Process (Container.Element.all);
-
exception
when others =>
B := B - 1;
-
raise;
end;
procedure Read
(Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Container : out Holder) is
+ Container : out Holder)
+ is
begin
Clear (Container);
---------------------
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";
begin
Process (Container.Element.all);
-
exception
when others =>
B := B - 1;
-
raise;
end;
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);
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;
-- --
-- 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- --
-- 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
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);
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;
---------------------
-----------------
procedure Unreference (Item : not null Shared_String_Access) is
- use Interfaces;
procedure Free is
new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access);
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
-- --
-- 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 --
with Ada.Strings.Maps;
private with Ada.Finalization;
-private with Interfaces;
+private with System.Atomic_Counters;
package Ada.Strings.Unbounded is
pragma Preelaborate;
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;
-- --
-- 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- --
-- 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
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);
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;
---------------------
-----------------
procedure Unreference (Item : not null Shared_Wide_String_Access) is
- use Interfaces;
procedure Free is
new Ada.Unchecked_Deallocation
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.
-- --
-- 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 --
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;
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;
-- --
-- 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- --
-- 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
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);
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;
---------------------
-----------------
procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is
- use Interfaces;
procedure Free is
new Ada.Unchecked_Deallocation
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.
-- --
-- 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 --
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;
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;
--------------------
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;
------------------------
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;
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
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
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;
-- 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)
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 --
-----------------------
-- 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 --
----------------------
else
Finalizer_Stmts := New_List;
end if;
+
+ if Has_Tagged_Types then
+ Tagged_Type_Stmts := New_List;
+ end if;
end Build_Components;
----------------------
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.
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;
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);
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));
-- 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.
-- 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;
-- 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;
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,
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,
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;
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
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.
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;
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.
-- 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;
end if;
end Add_Lib_Dir;
- -- -----------------
+ --------------------
-- Add_Source_Dir --
--------------------
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;
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
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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / platform / upstream / gcc.git / commitdiff