+2011-10-06 Thomas Quinot <quinot@adacore.com>
+
+ * einfo.ads, exp_attr.adb, exp_ch3.adb, exp_ch4.adb, exp_ch7.adb,
+ exp_ch9.adb, exp_ch9.ads, exp_strm.adb, exp_util.adb, freeze.adb,
+ g-debpoo.ads, opt.ads, par-ch12.adb, par-ch2.adb, par-ch3.adb,
+ par-ch5.adb, par-ch6.adb, sem_aggr.adb, sem_attr.adb, sem_cat.adb,
+ sem_ch10.adb, sem_ch12.adb, sem_ch3.adb, sem_ch4.adb, sem_ch5.adb,
+ sem_ch6.adb, sem_intr.adb, sem_res.ads, sem_type.adb, sem_util.adb,
+ s-regpat.adb, s-tpopde-vms.ads: Minor reformatting.
+ * s-osinte-freebsd.ads: Fix for tasking failures on FreeBSD.
+
+2011-10-06 Ed Schonberg <schonberg@adacore.com>
+
+ * a-cihase.adb, a-ciorma.adb: Avoid accessibility checks in container
+ references.
+
+2011-10-06 Matthew Heaney <heaney@adacore.com>
+
+ * a-cuprqu.ads, a-cuprqu.adb, a-cbprqu.ads, a-cbprqu.adb
+ (Dequeue_Only_High_Priority): Protected procedure now implemented.
+
+2011-10-06 Vincent Celier <celier@adacore.com>
+
+ * g-trasym.adb: Replace old implementation with the default
+ implementation that returns list of addresses as "0x...".
+ * g-trasym.ads: Update the list of platforms with the full
+ capability. Indicate that there is a default implementation
+ for other platforms.
+ * g-trasym-unimplemented.ads, g-trasym-unimplemented.adb: Remove.
+ * gcc-interface/Makefile.in: Remove g-trasym-unimplemented, as there
+ is now a default implementation for all platforms without the full
+ capability.
+
2011-10-06 Robert Dewar <dewar@adacore.com>
* a-ciorse.adb, a-cihase.adb, a-cihase.ads, a-coorse.adb,
List.Container.Delete_First;
end Dequeue;
+ procedure Dequeue
+ (List : in out List_Type;
+ At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean)
+ is
+ begin
+ if List.Length = 0
+ or else not Before (At_Least, Get_Priority (List.First_Element))
+ then
+ Success := False;
+ return;
+ end if;
+
+ List.Dequeue (Element);
+ Success := True;
+ end Dequeue;
+
-------------
-- Enqueue --
-------------
end if;
end Enqueue;
+ -------------------
+ -- First_Element --
+ -------------------
+
+ function First_Element
+ (List : List_Type) return Queue_Interfaces.Element_Type
+ is
+ begin
+ -- Use Constant_Reference for this. ???
+ return List.Container.First_Element;
+ end First_Element;
+
------------
-- Length --
------------
List.Dequeue (Element);
end Dequeue;
- -- ???
- -- entry Dequeue_Only_High_Priority
- -- (Low_Priority : Queue_Priority;
- -- Element : out Queue_Interfaces.Element_Type) when True
- -- is
- -- begin
- -- null;
- -- end Dequeue_Only_High_Priority;
+ --------------------------------
+ -- Dequeue_Only_High_Priority --
+ --------------------------------
+
+ procedure Dequeue_Only_High_Priority
+ (At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean)
+ is
+ begin
+ List.Dequeue (At_Least, Element, Success);
+ end Dequeue_Only_High_Priority;
--------------
-- Enqueue --
(List : in out List_Type;
Element : out Queue_Interfaces.Element_Type);
+ procedure Dequeue
+ (List : in out List_Type;
+ At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean);
+
+ function First_Element
+ (List : List_Type) return Queue_Interfaces.Element_Type;
+
function Length (List : List_Type) return Count_Type;
function Max_Length (List : List_Type) return Count_Type;
overriding
entry Dequeue (Element : out Queue_Interfaces.Element_Type);
- -- ???
- -- not overriding
- -- entry Dequeue_Only_High_Priority
- -- (Low_Priority : Queue_Priority;
- -- Element : out Queue_Interfaces.Element_Type);
+ -- The priority queue operation Dequeue_Only_High_Priority had been a
+ -- protected entry in early drafts of AI05-0159, but it was discovered
+ -- that that operation as specified was not in fact implementable. The
+ -- operation was changed from an entry to a protected procedure per the
+ -- ARG meeting in Edinburgh (June 2011), with a different signature and
+ -- semantics.
+
+ not overriding
+ procedure Dequeue_Only_High_Priority
+ (At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean);
overriding
function Current_Use return Count_Type;
function Peak_Use return Count_Type;
private
+
List : Implementation.List_Type (Capacity);
end Queue;
is
pragma Unreferenced (Container);
begin
- return (Element => Position.Node.Element);
+ return (Element => Position.Node.Element.all'Access);
end Constant_Reference;
-------------
is
pragma Unreferenced (Container);
begin
- return (Element => Position.Node.Element);
+ return (Element => Position.Node.Element.all'Access);
end Reference_Preserving_Key;
function Reference_Preserving_Key
is
Position : constant Cursor := Find (Container, Key);
begin
- return (Element => Position.Node.Element);
+ return (Element => Position.Node.Element.all'Access);
end Reference_Preserving_Key;
end Generic_Keys;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys);
package body Ada.Containers.Indefinite_Ordered_Maps is
+ pragma Suppress (All_Checks);
type Iterator is new
Map_Iterator_Interfaces.Reversible_Iterator with record
(Container : Map;
Key : Key_Type) return Constant_Reference_Type
is
+ Node : aliased Element_Type := Element (Container, Key);
begin
- return (Element => Container.Element (Key)'Unrestricted_Access);
+ return (Element => Node'Access);
end Constant_Reference;
--------------
Key : Key_Type)
return Reference_Type
is
+ Node : aliased Element_Type := Element (Container, Key);
+
begin
- return (Element => Container.Element (Key)'Unrestricted_Access);
+ return (Element => Node'Access);
end Reference;
-------------
Free (X);
end Dequeue;
+ procedure Dequeue
+ (List : in out List_Type;
+ At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean)
+ is
+ begin
+ if List.Length = 0
+ or else not Before (At_Least, Get_Priority (List.First.Element))
+ then
+ Success := False;
+ return;
+ end if;
+
+ List.Dequeue (Element);
+ Success := True;
+ end Dequeue;
+
-------------
-- Enqueue --
-------------
end loop;
end Finalize;
- ------------------------
- -- Have_High_Priority --
- ------------------------
-
- -- ???
- -- function Have_High_Priority
- -- (List : List_Type;
- -- Low_Priority : Queue_Priority) return Boolean
- -- is
- -- begin
- -- if List.Length = 0 then
- -- return False;
- -- end if;
- -- return Before (Get_Priority (List.First.Element), Low_Priority);
- -- end Have_High_Priority;
-
------------
-- Length --
------------
List.Dequeue (Element);
end Dequeue;
- -- ???
- -- entry Dequeue_Only_High_Priority
- -- (Low_Priority : Queue_Priority;
- -- Element : out Queue_Interfaces.Element_Type) when True
- -- is
- -- begin
- -- null;
- -- end Dequeue_Only_High_Priority;
+ --------------------------------
+ -- Dequeue_Only_High_Priority --
+ --------------------------------
+
+ procedure Dequeue_Only_High_Priority
+ (At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean)
+ is
+ begin
+ List.Dequeue (At_Least, Element, Success);
+ end Dequeue_Only_High_Priority;
-------------
-- Enqueue --
(List : in out List_Type;
Element : out Queue_Interfaces.Element_Type);
+ procedure Dequeue
+ (List : in out List_Type;
+ At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean);
+
function Length (List : List_Type) return Count_Type;
function Max_Length (List : List_Type) return Count_Type;
overriding
procedure Finalize (List : in out List_Type);
- -- ???
- -- not overriding
- -- function Have_High_Priority
- -- (List : List_Type;
- -- Low_Priority : Queue_Priority) return Boolean;
-
end Implementation;
protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling)
- -- ???
- -- with Priority => Ceiling is new Queue_Interfaces.Queue with
- is new Queue_Interfaces.Queue with
+ -- ???
+ -- with Priority => Ceiling is new Queue_Interfaces.Queue with
+ is new Queue_Interfaces.Queue with
- overriding
- entry Enqueue (New_Item : Queue_Interfaces.Element_Type);
+ overriding
+ entry Enqueue (New_Item : Queue_Interfaces.Element_Type);
- overriding
- entry Dequeue (Element : out Queue_Interfaces.Element_Type);
+ overriding
+ entry Dequeue (Element : out Queue_Interfaces.Element_Type);
- -- ???
- -- not overriding
- -- entry Dequeue_Only_High_Priority
- -- (Low_Priority : Queue_Priority;
- -- Element : out Queue_Interfaces.Element_Type);
+ -- The priority queue operation Dequeue_Only_High_Priority had been a
+ -- protected entry in early drafts of AI05-0159, but it was discovered
+ -- that that operation as specified was not in fact implementable. The
+ -- operation was changed from an entry to a protected procedure per the
+ -- ARG meeting in Edinburgh (June 2011), with a different signature and
+ -- semantics.
- overriding
- function Current_Use return Count_Type;
+ not overriding
+ procedure Dequeue_Only_High_Priority
+ (At_Least : Queue_Priority;
+ Element : in out Queue_Interfaces.Element_Type;
+ Success : out Boolean);
- overriding
- function Peak_Use return Count_Type;
+ overriding
+ function Current_Use return Count_Type;
+
+ overriding
+ function Peak_Use return Count_Type;
private
-- Is_Local_Anonymous_Access (Flag194)
-- Present in access types. Set for an anonymous access type to indicate
-- that the type is created for a record component with an access
--- definition, an array component, or (pre-Ada2012) a stand-alone object.
+-- definition, an array component, or (pre-Ada 2012) a standalone object.
-- Such anonymous types have an accessibility level equal to that of the
-- declaration in which they appear, unlike the anonymous access types
-- that are created for access parameters, access discriminants, and
--- (as of Ada2012) stand-alone objects.
+-- (as of Ada 2012) stand-alone objects.
-- Is_Machine_Code_Subprogram (Flag137)
-- Present in subprogram entities. Set to indicate that the subprogram
case Id is
- -- Attributes related to Ada2012 iterators (placeholder ???)
+ -- Attributes related to Ada 2012 iterators (placeholder ???)
when Attribute_Constant_Indexing => null;
when Attribute_Default_Iterator => null;
end if;
end if;
- -- In the non-tagged case, ever since Ada83 an equality function must
+ -- In the non-tagged case, ever since Ada 83 an equality function must
-- be provided for variant records that are not unchecked unions.
-- In Ada 2012 the equality function composes, and thus must be built
-- explicitly just as for tagged records.
-- Start of processing for Expand_Allocator_Expression
begin
- -- In the case of an Ada2012 allocator whose initial value comes from a
+ -- In the case of an Ada 2012 allocator whose initial value comes from a
-- function call, pass "the accessibility level determined by the point
-- of call" (AI05-0234) to the function. Conceptually, this belongs in
-- Expand_Call but it couldn't be done there (because the Etype of the
----------------------------------
-- Add call to Activate_Tasks if there are tasks declared and the package
- -- has no body. Note that in Ada83, this may result in premature activation
+ -- has no body. Note that in Ada 83 this may result in premature activation
-- of some tasks, given that we cannot tell whether a body will eventually
-- appear.
-- body or an accept body. The renamed object is a component of the
-- parameter block that is a parameter in the entry call.
- -- In Ada2012, If the formal is an incomplete tagged type, the renaming
+ -- In Ada 2012, if the formal is an incomplete tagged type, the renaming
-- does not dereference the corresponding component to prevent an illegal
-- use of the incomplete type (AI05-0151).
S : Entity_Id;
begin
- -- In Ada2005, the master is the innermost enclosing scope that is not
+ -- In Ada 2005, the master is the innermost enclosing scope that is not
-- transient. If the enclosing block is the rewriting of a call or the
-- scope is an extended return statement this is valid master. The
-- master in an extended return is only used within the return, and is
-- --
-- S p e c --
-- --
--- 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- --
function Find_Master_Scope (E : Entity_Id) return Entity_Id;
-- When a type includes tasks, a master entity is created in the scope, to
-- be used by the runtime during activation. In general the master is the
- -- immediate scope in which the type is declared, but in Ada2005, in the
+ -- immediate scope in which the type is declared, but in Ada 2005, in the
-- presence of synchronized classwide interfaces, the immediate scope of
-- an anonymous access type may be a transient scope, which has no run-time
-- presence. In this case, the scope of the master is the innermost scope
begin
-- (Ada 2005: AI-441): Set the null-excluding attribute because it has
- -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
+ -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
Profile := New_List (
Make_Parameter_Specification (Loc,
-- Construct function specification
-- (Ada 2005: AI-441): Set the null-excluding attribute because it has
- -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
+ -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
Spec :=
Make_Function_Specification (Loc,
-- Construct procedure specification
-- (Ada 2005: AI-441): Set the null-excluding attribute because it has
- -- no semantic meaning in Ada 95 but it is a requirement in Ada2005.
+ -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
Spec :=
Make_Procedure_Specification (Loc,
then
null;
- -- In Ada95 nothing to be done if the type of the expression is limited,
+ -- In Ada 95 nothing to be done if the type of the expression is limited
-- because in this case the expression cannot be copied, and its use can
-- only be by reference.
- -- In Ada2005, the context can be an object declaration whose expression
+ -- In Ada 2005 the context can be an object declaration whose expression
-- is a function that returns in place. If the nominal subtype has
-- unknown discriminants, the call still provides constraints on the
-- object, and we have to create an actual subtype from it.
-- Start of processing for Check_Current_Instance
begin
- -- In Ada95, the (imprecise) rule is that the current instance of a
- -- limited type is aliased. In Ada2005, limitedness must be explicit:
- -- either a tagged type, or a limited record.
+ -- In Ada 95, the (imprecise) rule is that the current instance of a
+ -- limited type is aliased. In Ada 2005, limitedness must be
+ -- explicit: either a tagged type, or a limited record.
if Is_Limited_Type (Rec_Type)
and then (Ada_Version < Ada_2005 or else Is_Tagged_Type (Rec_Type))
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This packages provides a special implementation of the Ada95 storage pools
+-- This packages provides a special implementation of the Ada 95 storage pools
-- The goal of this debug pool is to detect incorrect uses of memory
-- (multiple deallocations, access to invalid memory,...). Errors are reported
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- G N A T . T R A C E B A C K . S Y M B O L I C --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2010, 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. --
--- --
-------------------------------------------------------------------------------
-
--- Version used on unimplemented targets
-
--- Run-time symbolic traceback is currently supported on the following
--- targets:
-
--- HP-UX
--- IRIX
--- GNU/Linux x86
--- AIX
--- Solaris sparc
--- Tru64
--- OpenVMS/Alpha
--- Windows NT/XP/Vista
-
--- This version is used on all other targets, it generates a warning at
--- compile time if it is with'ed, and the bodies generate messages saying
--- that the functions are not implemented.
-
-package body GNAT.Traceback.Symbolic is
-
- ------------------------
- -- Symbolic_Traceback --
- ------------------------
-
- function Symbolic_Traceback (Traceback : Tracebacks_Array) return String
- is
- pragma Unreferenced (Traceback);
- begin
- return "Symbolic_Traceback not implemented on this target";
- end Symbolic_Traceback;
-
- function Symbolic_Traceback (E : Exception_Occurrence) return String
- is
- pragma Unreferenced (E);
- begin
- return "Symbolic_Traceback not implemented on this target";
- end Symbolic_Traceback;
-
-end GNAT.Traceback.Symbolic;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- G N A T . T R A C E B A C K . S Y M B O L I C --
--- --
--- S p e c --
--- --
--- Copyright (C) 1999-2010, 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. --
--- --
-------------------------------------------------------------------------------
-
--- Version used on unimplemented targets
-
--- Run-time symbolic traceback is currently supported on the following
--- targets:
-
--- HP-UX hppa and ia64
--- IRIX
--- GNU/Linux x86, x86_64, ia64
--- AIX
--- Solaris sparc and x86
--- Tru64
--- OpenVMS/Alpha
--- Windows NT/XP/Vista
-
--- This version is used on all other targets, it generates a warning at
--- compile time if it is with'ed, and the bodies generate messages saying
--- that the functions are not implemented.
-
-with Ada.Exceptions; use Ada.Exceptions;
-
-package GNAT.Traceback.Symbolic is
- pragma Elaborate_Body;
-
--- pragma Compile_Time_Warning
--- (True, "symbolic traceback not implemented on this target");
-
- function Symbolic_Traceback (Traceback : Tracebacks_Array) return String;
- -- Build a string containing a symbolic traceback of the given call chain
-
- function Symbolic_Traceback (E : Exception_Occurrence) return String;
- -- Build string containing symbolic traceback of given exception occurrence
-
-end GNAT.Traceback.Symbolic;
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2010, AdaCore --
+-- Copyright (C) 1999-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- --
-- --
------------------------------------------------------------------------------
--- Run-time symbolic traceback support
+-- This is the default implementation for platforms where the full capability
+-- is not supported. It returns tracebacks as lists of "0x..." strings
+-- corresponding to the addresses.
-with System.Soft_Links;
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
+with System.Address_Image;
package body GNAT.Traceback.Symbolic is
- pragma Linker_Options ("-laddr2line");
- pragma Linker_Options ("-lbfd");
- pragma Linker_Options ("-liberty");
-
- package TSL renames System.Soft_Links;
-
- -- To perform the raw addresses to symbolic form translation we rely on a
- -- libaddr2line symbolizer which examines debug info from a provided
- -- executable file name, and an absolute path is needed to ensure the file
- -- is always found. This is "__gnat_locate_exec_on_path (gnat_argv [0])"
- -- for our executable file, a fairly heavy operation so we cache the
- -- result.
-
- Exename : System.Address;
- -- Pointer to the name of the executable file to be used on all
- -- invocations of the libaddr2line symbolization service.
-
- Exename_Resolved : Boolean := False;
- -- Flag to indicate whether we have performed the executable file name
- -- resolution already. Relying on a not null Exename for this purpose
- -- would be potentially inefficient as this is what we will get if the
- -- resolution attempt fails.
-
------------------------
-- Symbolic_Traceback --
------------------------
- function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
-
- procedure convert_addresses
- (filename : System.Address;
- addrs : System.Address;
- n_addrs : Integer;
- buf : System.Address;
- len : System.Address);
- pragma Import (C, convert_addresses, "convert_addresses");
- -- This is the procedure version of the Ada-aware addr2line. It places
- -- in BUF a string representing the symbolic translation of the N_ADDRS
- -- raw addresses provided in ADDRS, looked up in debug information from
- -- FILENAME. LEN points to an integer which contains the size of the
- -- BUF buffer at input and the result length at output.
- --
- -- This procedure is provided by libaddr2line on targets that support
- -- it. A dummy version is in adaint.c for other targets so that build
- -- of shared libraries doesn't generate unresolved symbols.
- --
- -- Note that this procedure is *not* thread-safe.
-
- type Argv_Array is array (0 .. 0) of System.Address;
- gnat_argv : access Argv_Array;
- pragma Import (C, gnat_argv, "gnat_argv");
-
- function locate_exec_on_path
- (c_exename : System.Address) return System.Address;
- pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
-
- Res : String (1 .. 256 * Traceback'Length);
- Len : Integer;
-
- use type System.Address;
-
+ function Symbolic_Traceback (Traceback : Tracebacks_Array) return String
+ is
begin
- -- The symbolic translation of an empty set of addresses is an empty
- -- string.
-
if Traceback'Length = 0 then
return "";
- end if;
- -- If our input set of raw addresses is not empty, resort to the
- -- libaddr2line service to symbolize it all.
-
- -- Compute, cache and provide the absolute path to our executable file
- -- name as the binary file where the relevant debug information is to be
- -- found. If the executable file name resolution fails, we have no
- -- sensible basis to invoke the symbolizer at all.
-
- -- Protect all this against concurrent accesses explicitly, as the
- -- underlying services are potentially thread unsafe.
-
- TSL.Lock_Task.all;
-
- if not Exename_Resolved then
- Exename := locate_exec_on_path (gnat_argv (0));
- Exename_Resolved := True;
- end if;
-
- if Exename /= System.Null_Address then
- Len := Res'Length;
- convert_addresses
- (Exename, Traceback'Address, Traceback'Length,
- Res (1)'Address, Len'Address);
- end if;
-
- TSL.Unlock_Task.all;
-
- -- Return what the addr2line symbolizer has produced if we have called
- -- it (the executable name resolution succeeded), or an empty string
- -- otherwise.
-
- if Exename /= System.Null_Address then
- return Res (1 .. Len);
else
- return "";
+ declare
+ Img : String := System.Address_Image (Traceback (Traceback'First));
+ Result : String (1 .. (Img'Length + 3) * Traceback'Length);
+ Last : Natural := 0;
+ begin
+ for J in Traceback'Range loop
+ Img := System.Address_Image (Traceback (J));
+ Result (Last + 1 .. Last + 2) := "0x";
+ Last := Last + 2;
+ Result (Last + 1 .. Last + Img'Length) := Img;
+ Last := Last + Img'Length + 1;
+ Result (Last) := ASCII.LF;
+ end loop;
+
+ return Result (1 .. Last);
+ end;
end if;
-
end Symbolic_Traceback;
- function Symbolic_Traceback (E : Exception_Occurrence) return String is
+ function Symbolic_Traceback (E : Exception_Occurrence) return String
+ is
begin
return Symbolic_Traceback (Tracebacks (E));
end Symbolic_Traceback;
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2010, AdaCore --
+-- Copyright (C) 1999-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- --
-- Run-time symbolic traceback support
--- This capability is currently supported on the following targets:
+-- The full capability is currently supported on the following targets:
--- HP-UX hppa and ia64
+-- HP-UX ia64
-- IRIX
-- GNU/Linux x86, x86_64, ia64
--- AIX
+-- FreeBSD x86, x86_64
-- Solaris sparc and x86
-- Tru64
--- OpenVMS/Alpha
--- Windows NT/XP/Vista
+-- OpenVMS Alpha and ia64
+-- Windows
-- The routines provided in this package assume that your application has
-- been compiled with debugging information turned on, since this information
-- libraries. However, the OS should be at least v7.3-1 and OS patch
-- VMS731_TRACE-V0100 must be applied in order to use this package.
+-- On platforms where the full capability is not supported, function
+-- Symbolic_Traceback return a list of addresses expressed as "0x..."
+-- separated by line feed.
+
with Ada.Exceptions; use Ada.Exceptions;
package GNAT.Traceback.Symbolic is
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-m68k.ads
TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
s-vxwext.adb<s-vxwext-noints.adb \
s-vxwext.ads<s-vxwext-vthreads.ads \
s-vxwork.ads<s-vxwork-ppc.ads \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-ppc-vthread.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
s-thread.adb<s-thread-ae653.adb \
s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<s-vxwork-ppc.ads \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-ppc.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
s-vxwext.adb<s-vxwext-noints.adb \
s-vxwext.ads<s-vxwext-vthreads.ads \
s-vxwork.ads<s-vxwork-x86.ads \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_TARGET_PAIRS) \
system.ads<system-vxworks-x86.ads
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-sparcv9.ads \
TOOLS_TARGET_PAIRS=\
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_TARGET_PAIRS)
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-arm.ads
TOOLS_TARGET_PAIRS=\
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-mips.ads
TOOLS_TARGET_PAIRS=\
s-tasinf.ads<s-tasinf-linux.ads \
s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb
+ s-tpopsp.adb<s-tpopsp-posix-foreign.adb
LIBGNAT_TARGET_PAIRS_32 = \
system.ads<system-linux-s390.ads
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-rtems.adb \
s-stchop.adb<s-stchop-rtems.adb \
- s-interr.adb<s-interr-hwint.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb
+ s-interr.adb<s-interr-hwint.adb
endif
ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
s-tpopsp.adb<s-tpopsp-tls.adb
LIBGNAT_TARGET_PAIRS_32 = \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-linux-sparc.ads
LIBGNAT_TARGET_PAIRS_64 = \
s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-linux-hppa.ads
TOOLS_TARGET_PAIRS = \
s-tasinf.adb<s-tasinf-linux.adb \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-linux-alpha.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
s-osinte.ads<s-osinte-darwin.ads \
s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- g-trasym.ads<g-trasym-unimplemented.ads \
- g-trasym.adb<g-trasym-unimplemented.adb
+ s-tpopsp.adb<s-tpopsp-posix-foreign.adb
ifeq ($(strip $(filter-out %86,$(arch))),)
LIBGNAT_TARGET_PAIRS += \
-- GNAT
-- This is the value of the configuration switch for the Ada 83 mode, as
-- set by the command line switches -gnat83/95/05, and possibly modified by
- -- the use of configuration pragmas Ada_83/Ada95/Ada05. This switch is used
- -- to set the initial value for Ada_Version mode at the start of analysis
- -- of a unit. Note however, that the setting of this flag is ignored for
- -- internal and predefined units (which are always compiled in the most up
- -- to date version of Ada).
+ -- the use of configuration pragmas Ada_*. This switch is used to set the
+ -- initial value for Ada_Version mode at the start of analysis of a unit.
+ -- Note however that the setting of this flag is ignored for internal and
+ -- predefined units (which are always compiled in the most up to date
+ -- version of Ada).
Ada_Version_Explicit_Config : Ada_Version_Type;
-- GNAT
begin
Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr);
- -- Ada2005: an association can be given by: others => <>
+ -- Ada 2005: an association can be given by: others => <>
if Token = Tok_Others then
if Ada_Version < Ada_2005 then
begin
-- All set if we do indeed have an identifier
+ -- Code duplication, see Par_Ch3.P_Defining_Identifier???
+
if Token = Tok_Identifier then
- -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
- -- OVERRIDING, and SYNCHRONIZED are new reserved words.
+ -- Shouldn't the warnings below be emitted when in Ada 83 mode???
+
+ -- Ada 2005 (AI-284): If compiling in Ada 95 mode, we warn that
+ -- INTERFACE, OVERRIDING, and SYNCHRONIZED are new reserved words.
if Ada_Version = Ada_95
and then Warn_On_Ada_2005_Compatibility
-- we set Force_Msg to True, since we want at least one message for each
-- separate declaration (but not use) of a reserved identifier.
+ -- Duplication should be removed, common code should be factored???
+
if Token = Tok_Identifier then
- -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
- -- OVERRIDING, and SYNCHRONIZED are new reserved words. Note that
- -- in the case where these keywords are misused in Ada 95 mode,
- -- this routine will generally not be called at all.
+ -- Shouldn't the warnings below be emitted when in Ada 83 mode???
+
+ -- Ada 2005 (AI-284): If compiling in Ada 95 mode, we warn that
+ -- INTERFACE, OVERRIDING, and SYNCHRONIZED are new reserved words.
+ -- Note that in the case where these keywords are misused in Ada 95
+ -- mode, this routine will generally not be called at all.
+
+ -- What sort of misuse is this comment talking about??? These are
+ -- perfectly legitimate defining identifiers in Ada 95???
if Ada_Version = Ada_95
and then Warn_On_Ada_2005_Compatibility
Error_Msg_SP
("(Ada 83) limited record declaration not allowed!");
- -- In Ada2005, "abstract limited" can appear before "new",
+ -- In Ada 2005, "abstract limited" can appear before "new",
-- but it cannot be part of an untagged record declaration.
elsif Abstract_Present
P_Identifier_Declarations (Decls, Done, In_Spec);
end if;
- -- Ada2005: A subprogram declaration can start with "not" or
+ -- Ada 2005: A subprogram declaration can start with "not" or
-- "overriding". In older versions, "overriding" is handled
-- like an identifier, with the appropriate messages.
if Token = Tok_Of or else Token = Tok_Colon then
if Ada_Version < Ada_2012 then
- Error_Msg_SC ("iterator is an Ada2012 feature");
+ Error_Msg_SC ("iterator is an Ada 2012 feature");
end if;
return P_Iterator_Specification (ID_Node);
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Lreq := False;
- -- Ada2005: scan leading NOT OVERRIDING indicator
+ -- Ada 2005: scan leading NOT OVERRIDING indicator
if Token = Tok_Not then
Scan; -- past NOT
if Token = Tok_Aliased then
if Ada_Version < Ada_2012 then
- Error_Msg_SC ("ALIASED parameter is an Ada2012 feature");
+ Error_Msg_SC ("ALIASED parameter is an Ada 2012 feature");
else
Set_Aliased_Present (Specification_Node);
end if;
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 0;
- CLOCK_MONOTONIC : constant clockid_t := 4;
+ CLOCK_MONOTONIC : constant clockid_t := 0;
+ -- On FreeBSD, pthread_cond_timedwait assumes a CLOCK_REALTIME time by
+ -- default (unless pthread_condattr_setclock is used to set an alternate
+ -- clock).
type pthread_t is new System.Address;
type pthread_attr_t is new System.Address;
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1999-2010, AdaCore --
+-- Copyright (C) 1999-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- --
(Dummy.Program'First .. Dummy.Program'First + Size - 1));
else
-- We have to recompile now that we know the size
- -- ??? Can we use Ada05's return construct ?
+ -- ??? Can we use Ada 05's return construct ?
declare
Result : Pattern_Matcher (Size);
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2011, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Interrupt_AST_Handler (ID : Address);
pragma Convention (C, Interrupt_AST_Handler);
- -- Handles the AST for Ada95 Interrupts
+ -- Handles the AST for Ada 95 Interrupts
procedure RMS_AST_Handler (ID : Address);
-- Handles the AST for RMS_Asynch_Operations
Selector_Name);
return;
- -- (Ada2005): If this is an association with a box,
+ -- (Ada 2005): If this is an association with a box,
-- indicate that the association need not represent
-- any component.
case Attr_Id is
- -- Attributes related to Ada2012 iterators. Attribute specifications
+ -- Attributes related to Ada 2012 iterators. Attribute specifications
-- exist for these, but they cannot be queried.
when Attribute_Constant_Indexing |
case Id is
- -- Attributes related to Ada2012 iterators (placeholder ???)
+ -- Attributes related to Ada 2012 iterators (placeholder ???)
when Attribute_Constant_Indexing => null;
when Attribute_Default_Iterator => null;
-- If the type is private, it must have the Ada 2005 pragma
-- Has_Preelaborable_Initialization.
-- The check is omitted within predefined units. This is probably
- -- obsolete code to fix the Ada95 weakness in this area ???
+ -- obsolete code to fix the Ada 95 weakness in this area ???
if Is_Private_Type (T)
and then not Has_Pragma_Preelab_Init (T)
-- Limited_With_Clauses --
--------------------------
- -- Limited_With clauses are the mechanism chosen for Ada05 to support
+ -- Limited_With clauses are the mechanism chosen for Ada 05 to support
-- mutually recursive types declared in different units. A limited_with
-- clause that names package P in the context of unit U makes the types
-- declared in the visible part of P available within U, but with the
-- are not accessible outside of the instance.
-- In a generic, a formal package is treated like a special instantiation.
- -- Our Ada95 compiler handled formals with and without box in different
+ -- Our Ada 95 compiler handled formals with and without box in different
-- ways. With partial parametrization, we use a single model for both.
-- We create a package declaration that consists of the specification of
-- the generic package, and a set of declarations that map the actuals
-- The partial view of T may have been a private extension, for
-- which inherited functions dispatching on result are abstract.
-- If the full view is a null extension, there is no need for
- -- overriding in Ada2005, but wrappers need to be built for them
+ -- overriding in Ada 2005, but wrappers need to be built for them
-- (see exp_ch3, Build_Controlling_Function_Wrappers).
if Is_Null_Extension (T)
-- Look up tree to find an appropriate insertion point. We
-- can't just use insert_actions because later processing
- -- depends on the insertion node. Prior to Ada2012 the
+ -- depends on the insertion node. Prior to Ada 2012 the
-- insertion point could only be a declaration or a loop, but
-- quantified expressions can appear within any context in an
-- expression, and the insertion point can be any statement,
-- of the high bound.
procedure Check_Universal_Expression (N : Node_Id);
- -- In Ada83, reject bounds of a universal range that are not
+ -- In Ada 83, reject bounds of a universal range that are not
-- literals or entity names.
-----------------------
Set_Parent (D_Copy, Parent (DS));
Pre_Analyze_Range (D_Copy);
- -- Ada2012: If the domain of iteration is a function call,
+ -- Ada 2012: If the domain of iteration is a function call,
-- it is the new iterator form.
-- We have also implemented the shorter form : for X in S
begin
Analyze (P);
- -- A call of the form A.B (X) may be an Ada05 call, which is rewritten
+ -- A call of the form A.B (X) may be an Ada 05 call, which is rewritten
-- as B (A, X). If the rewriting is successful, the call has been
-- analyzed and we just return.
elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
if Inside_A_Generic then
Error_Msg_N
- ("return of limited object not permitted in Ada2005 "
+ ("return of limited object not permitted in Ada 2005 "
& "(RM-2005 6.5(5.5/2))?", Expr);
elsif Is_Immutably_Limited_Type (R_Type) then
-- expansion has generated an equivalent type that is used when
-- elaborating the body.
- -- An exception in the case of Ada2012, AI05-177: The bodies
+ -- An exception in the case of Ada 2012, AI05-177: The bodies
-- created for expression functions do not freeze.
if No (Spec_Id)
Desig_2 : Entity_Id;
begin
- -- In Ada2005, access constant indicators must match for
+ -- In Ada 2005, access constant indicators must match for
-- subtype conformance.
if Ada_Version >= Ada_2005
-- inherited in a derivation, or when an inherited operation
-- of a tagged full type overrides the inherited operation of
-- a private extension. Ada 83 had a special rule for the
- -- literal case. In Ada95, the later implicit operation hides
+ -- literal case. In Ada 95, the later implicit operation hides
-- the former, and the literal is always the former. In the
-- odd case where both are derived operations declared at the
-- same point, both operations should be declared, and in that
if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
- -- Ada 2005 (AI-231): In Ada95, access parameters are always non-
+ -- Ada 2005 (AI-231): In Ada 95, access parameters are always non-
-- null; In Ada 2005, only if then null_exclusion is explicit.
if Ada_Version < Ada_2005
-- --
-- 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- --
end if;
-- For Import_xxx calls, argument must be static string. A string
- -- literal is legal even in Ada83 mode, where such literals are
+ -- literal is legal even in Ada 83 mode, where such literals are
-- not static.
if Cnam = Name_Import_Address
procedure Ambiguous_Character (C : Node_Id);
-- Give list of candidate interpretations when a character literal cannot
-- be resolved, for example in a (useless) comparison such as 'A' = 'B'.
- -- In Ada95 the literals in question can be of type Character or Wide_
- -- Character. In Ada2005 Wide_Wide_Character is also a candidate. The
+ -- In Ada 95 the literals in question can be of type Character or Wide_
+ -- Character. In Ada 2005 Wide_Wide_Character is also a candidate. The
-- node may also be overloaded with user-defined character types.
procedure Check_Parameterless_Call (N : Node_Id);
-- Otherwise, the predefined operator has precedence, or if the user-
-- defined operation is directly visible we have a true ambiguity.
- -- If this is a fixed-point multiplication and division in Ada83 mode,
+ -- If this is a fixed-point multiplication and division in Ada 83 mode,
-- exclude the universal_fixed operator, which often causes ambiguities
-- in legacy code.
- -- Ditto in Ada2012, where an ambiguity may arise for an operation on
+ -- Ditto in Ada 2012, where an ambiguity may arise for an operation on
-- a partial view that is completed with a fixed point type. See
-- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
-- user-defined subprogram so that a client of the package has the
if not Is_Local_Anonymous_Access (Etype (Expr)) then
-- Handle type conversions introduced for a rename of an
- -- Ada2012 stand-alone object of an anonymous access type.
+ -- Ada 2012 stand-alone object of an anonymous access type.
return Dynamic_Accessibility_Level (Expression (Expr));
end if;
Is_Object_Reference (Prefix (N))
or else Is_Access_Type (Etype (Prefix (N)));
- -- In Ada95, a function call is a constant object; a procedure
+ -- In Ada 95, a function call is a constant object; a procedure
-- call is not.
when N_Function_Call =>
elsif Original_Node (AV) /= AV then
- -- In Ada2012, the explicit dereference may be a rewritten call to a
+ -- In Ada 2012, the explicit dereference may be a rewritten call to a
-- Reference function.
if Ada_Version >= Ada_2012
OSDN Git Service
