2012-07-09 Vincent Pucci <pucci@adacore.com>
* sem_ch9.adb (Check_Node): Allow attributes
that denote static function for lock-free implementation.
(Is_Static_Function): New routine.
2012-07-09 Tristan Gingold <gingold@adacore.com>
* tracebak.c: Adjust skip_frames on Win64.
2012-07-09 Tristan Gingold <gingold@adacore.com>
* init.c: Add __gnat_adjust_context_for_raise for ia64/hpux.
* raise-gcc.c: __gnat_cleanupunwind_handler: Do not call
_Unwind_GetGR on hpux when using libgcc unwinder. Part of
2012-07-09 Vincent Pucci <pucci@adacore.com>
* exp_attr.adb, sem_attr.adb: Minor reformatting.
* par-ch13.adb, par-ch4.adb, par-util.adb: Reformatting
considering that internal attribute names are not defined anymore
in the main attribute names list.
* snames.adb-tmpl (Get_Attribute_Id): Special processinf
for names CPU, Dispatching_Domain and Interrupt_Priority.
(Is_Internal_Attribute_Name): Minor reformatting.
* snames.ads-tmpl: New list of internal attribute names. Internal
attributes moved at the end of the attribute Id list.
From-SVN: r189380
+2012-07-09 Vincent Pucci <pucci@adacore.com>
+
+ * sem_ch9.adb (Check_Node): Allow attributes
+ that denote static function for lock-free implementation.
+ (Is_Static_Function): New routine.
+
+2012-07-09 Tristan Gingold <gingold@adacore.com>
+
+ * tracebak.c: Adjust skip_frames on Win64.
+
+2012-07-09 Tristan Gingold <gingold@adacore.com>
+
+ * init.c: Add __gnat_adjust_context_for_raise for ia64/hpux.
+ * raise-gcc.c: __gnat_cleanupunwind_handler: Do not call
+ _Unwind_GetGR on hpux when using libgcc unwinder. Part of
+
+2012-07-09 Vincent Pucci <pucci@adacore.com>
+
+ * exp_attr.adb, sem_attr.adb: Minor reformatting.
+ * par-ch13.adb, par-ch4.adb, par-util.adb: Reformatting
+ considering that internal attribute names are not defined anymore
+ in the main attribute names list.
+ * snames.adb-tmpl (Get_Attribute_Id): Special processinf
+ for names CPU, Dispatching_Domain and Interrupt_Priority.
+ (Is_Internal_Attribute_Name): Minor reformatting.
+ * snames.ads-tmpl: New list of internal attribute names. Internal
+ attributes moved at the end of the attribute Id list.
+
2012-07-09 Robert Dewar <dewar@adacore.com>
* freeze.adb: Minor code reorganization (use Ekind_In).
-- Internal attributes used to deal with Ada 2012 delayed aspects. These
-- were already rejected by the parser. Thus they shouldn't appear here.
- when Attribute_CPU |
- Attribute_Dispatching_Domain |
- Attribute_Interrupt_Priority =>
+ when Internal_Attribute_Id =>
raise Program_Error;
------------
#include <signal.h>
#include <sys/ucontext.h>
+#if defined(__ia64__)
+#include <sys/uc_access.h>
+#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
+
+void
+__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
+{
+ ucontext_t *uc = (ucontext_t *) ucontext;
+ uint64_t ip;
+
+ /* Adjust on itanium, as GetIPInfo is not supported. */
+ __uc_get_ip (uc, &ip);
+ __uc_set_ip (uc, ip + 1);
+}
+#endif /* __ia64__ */
+
+/* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception
+ propagation after the required low level adjustments. */
+
static void
__gnat_error_handler (int sig,
siginfo_t *si ATTRIBUTE_UNUSED,
struct Exception_Data *exception;
const char *msg;
+#if defined(__ia64__)
+ __gnat_adjust_context_for_raise (sig, ucontext);
+#endif
+
switch (sig)
{
case SIGSEGV:
-- are meant to be used only by the compiler.
if not Is_Attribute_Name (Attr_Name)
- or else (Is_Internal_Attribute_Name (Attr_Name)
- and then Comes_From_Source (Token_Node))
+ and then (not Is_Internal_Attribute_Name (Attr_Name)
+ or else Comes_From_Source (Token_Node))
then
Signal_Bad_Attribute;
end if;
elsif Token = Tok_Identifier then
Attr_Name := Token_Name;
- -- Note that internal attributes names don't denote real
- -- attributes, so do not count in this error test. We just
- -- want to consider them as not being attribute names.
-
- if not Is_Attribute_Name (Attr_Name)
- or else Is_Internal_Attribute_Name (Attr_Name)
- then
+ if not Is_Attribute_Name (Attr_Name) then
if Apostrophe_Should_Be_Semicolon then
Expr_Form := EF_Name;
return Name_Node;
Error_Msg_Name_1 := First_Attribute_Name;
while Error_Msg_Name_1 <= Last_Attribute_Name loop
-
- -- No mispelling possible with internal attribute names since they
- -- don't denote real attributes.
-
- if not Is_Internal_Attribute_Name (Error_Msg_Name_1)
- and then Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1)
- then
+ if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then
Error_Msg_N -- CODEFIX
("\possible misspelling of %", Token_Node);
exit;
{
/* Terminate when the end of the stack is reached. */
if ((phases & _UA_END_OF_STACK) != 0
-#if defined (__ia64__) && defined (__hpux__)
+#if defined (__ia64__) && defined (__hpux__) && defined (USE_LIBUNWIND_EXCEPTIONS)
/* Strictely follow the ia64 ABI: when end of stack is reached,
the callback will be called with a NULL stack pointer.
No need for that when using libgcc unwinder. */
-- Internal attributes used to deal with Ada 2012 delayed aspects. These
-- were already rejected by the parser. Thus they shouldn't appear here.
- when Attribute_CPU |
- Attribute_Dispatching_Domain |
- Attribute_Interrupt_Priority =>
+ when Internal_Attribute_Id =>
raise Program_Error;
------------------
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
+ function Is_Static_Function (Attr : Node_Id) return Boolean;
+ -- Given an attribute reference node Attr, return True if
+ -- Attr denotes a static function according to the rules in
+ -- (RM 4.9 (22)).
+
+ ------------------------
+ -- Is_Static_Function --
+ ------------------------
+
+ function Is_Static_Function
+ (Attr : Node_Id) return Boolean
+ is
+ Para : Node_Id;
+
+ begin
+ pragma Assert (Nkind (Attr) = N_Attribute_Reference);
+
+ case Attribute_Name (Attr) is
+ when Name_Min |
+ Name_Max |
+ Name_Pred |
+ Name_Succ |
+ Name_Value |
+ Name_Wide_Value |
+ Name_Wide_Wide_Value =>
+
+ -- A language-defined attribute denotes a static
+ -- function if the prefix denotes a static scalar
+ -- subtype, and if the parameter and result types
+ -- are scalar (RM 4.9 (22)).
+
+ if Is_Scalar_Type (Etype (Attr))
+ and then Is_Scalar_Type (Etype (Prefix (Attr)))
+ and then Is_Static_Subtype (Etype (Prefix (Attr)))
+ then
+ Para := First (Expressions (Attr));
+
+ while Present (Para) loop
+ if not Is_Scalar_Type (Etype (Para)) then
+ return False;
+ end if;
+
+ Next (Para);
+ end loop;
+
+ return True;
+
+ else
+ return False;
+ end if;
+
+ when others => return False;
+ end case;
+ end Is_Static_Function;
+
+ -- Start of processing for Check_Node
+
begin
if Is_Procedure then
- -- Function calls and attribute references must be static
+ -- Attribute references must be static or denote a static
+ -- function.
if Nkind (N) = N_Attribute_Reference
and then not Is_Static_Expression (N)
+ and then not Is_Static_Function (N)
then
if Complain then
Error_Msg_N
return Abandon;
+ -- Function calls must be static
+
elsif Nkind (N) = N_Function_Call
and then not Is_Static_Expression (N)
then
function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
begin
- return Attribute_Id'Val (N - First_Attribute_Name);
+ if N = Name_CPU then
+ return Attribute_CPU;
+ elsif N = Name_Dispatching_Domain then
+ return Attribute_Dispatching_Domain;
+ elsif N = Name_Interrupt_Priority then
+ return Attribute_Interrupt_Priority;
+ else
+ return Attribute_Id'Val (N - First_Attribute_Name);
+ end if;
end Get_Attribute_Id;
-----------------------
function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is
begin
return
- N = Name_CPU or else
- N = Name_Interrupt_Priority or else
- N = Name_Dispatching_Domain;
+ N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name;
end Is_Internal_Attribute_Name;
----------------------------
-- implementation dependent attributes may be found in the appropriate
-- section in Sem_Attr.
- -- The entries marked INT are not real attributes. They are special names
- -- used internally by GNAT in order to deal with certain delayed aspects
- -- (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority) that
- -- don't have corresponding pragmas or user-referencable attributes. It is
- -- convenient to have these internal attributes available in processing
- -- the aspects, since the normal approach is to convert an aspect into its
- -- corresponding pragma or attribute specification.
-
-- The entries marked VMS are recognized only in OpenVMS implementations
-- of GNAT, and are treated as illegal in all other contexts.
Name_Constant_Indexing : constant Name_Id := N + $; -- GNAT
Name_Constrained : constant Name_Id := N + $;
Name_Count : constant Name_Id := N + $;
- Name_CPU : constant Name_Id := N + $; -- INT
Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT
Name_Default_Iterator : constant Name_Id := N + $; -- GNAT
Name_Definite : constant Name_Id := N + $;
Name_Denorm : constant Name_Id := N + $;
Name_Descriptor_Size : constant Name_Id := N + $;
Name_Digits : constant Name_Id := N + $;
- Name_Dispatching_Domain : constant Name_Id := N + $; -- INT
Name_Elaborated : constant Name_Id := N + $; -- GNAT
Name_Emax : constant Name_Id := N + $; -- Ada 83
Name_Enabled : constant Name_Id := N + $; -- GNAT
Name_Img : constant Name_Id := N + $; -- GNAT
Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT
Name_Integer_Value : constant Name_Id := N + $; -- GNAT
- Name_Interrupt_Priority : constant Name_Id := N + $; -- INT
Name_Invalid_Value : constant Name_Id := N + $; -- GNAT
Name_Iterator_Element : constant Name_Id := N + $; -- GNAT
Name_Large : constant Name_Id := N + $; -- Ada 83
Last_Entity_Attribute_Name : constant Name_Id := N + $;
Last_Attribute_Name : constant Name_Id := N + $;
+ -- Names of internal attributes. They are not real attributes but special
+ -- names used internally by GNAT in order to deal with certain delayed
+ -- aspects (Aspect_CPU, Aspect_Dispatching_Domain,
+ -- Aspect_Interrupt_Priority) that don't have corresponding pragmas or
+ -- user-referencable attributes. It is convenient to have these internal
+ -- attributes available in processing the aspects, since the normal
+ -- approach is to convert an aspect into its corresponding pragma or
+ -- attribute specification.
+
+ First_Internal_Attribute_Name : constant Name_Id := N + $;
+ Name_CPU : constant Name_Id := N + $; -- INT
+ Name_Dispatching_Domain : constant Name_Id := N + $; -- INT
+ Name_Interrupt_Priority : constant Name_Id := N + $; -- INT
+ Last_Internal_Attribute_Name : constant Name_Id := N + $;
+
-- Names of recognized locking policy identifiers
First_Locking_Policy_Name : constant Name_Id := N + $;
Attribute_Constant_Indexing,
Attribute_Constrained,
Attribute_Count,
- Attribute_CPU,
Attribute_Default_Bit_Order,
Attribute_Default_Iterator,
Attribute_Definite,
Attribute_Denorm,
Attribute_Descriptor_Size,
Attribute_Digits,
- Attribute_Dispatching_Domain,
Attribute_Elaborated,
Attribute_Emax,
Attribute_Enabled,
Attribute_Img,
Attribute_Implicit_Dereference,
Attribute_Integer_Value,
- Attribute_Interrupt_Priority,
Attribute_Invalid_Value,
Attribute_Iterator_Element,
Attribute_Large,
Attribute_Base,
Attribute_Class,
- Attribute_Stub_Type);
+ Attribute_Stub_Type,
+
+ -- The internal attributes are on their own, out of order, because of
+ -- the special processing required to deal with the fact that their
+ -- names are not attribute names.
+
+ Attribute_CPU,
+ Attribute_Dispatching_Domain,
+ Attribute_Interrupt_Priority);
+
+ subtype Internal_Attribute_Id is Attribute_Id range
+ Attribute_CPU .. Attribute_Interrupt_Priority;
type Attribute_Class_Array is array (Attribute_Id) of Boolean;
-- Type used to build attribute classification flag arrays
function Get_Attribute_Id (N : Name_Id) return Attribute_Id;
-- Returns Id of attribute corresponding to given name. It is an error to
- -- call this function with a name that is not the name of a attribute.
+ -- call this function with a name that is not the name of a attribute. Note
+ -- that the function also works correctly for internal attribute names even
+ -- though there are not included in the main list of attribute Names.
function Get_Convention_Id (N : Name_Id) return Convention_Id;
-- Returns Id of language convention corresponding to given name. It is
break;
/* Skip frames. */
- if (skip_frames)
+ if (skip_frames > 1)
{
skip_frames--;
continue;
projects / gcc.git / commitdiff