[multiple changes]

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

gcc/ada/ChangeLog

@@ -1,3 +1,31 @@
+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).

gcc/ada/exp_attr.adb

@@ -841,9 +841,7 @@ package body Exp_Attr is
       --  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                |
+      when Internal_Attribute_Id =>
-           Attribute_Dispatching_Domain |
-           Attribute_Interrupt_Priority =>
          raise Program_Error;
 
       ------------

gcc/ada/init.c

@@ -304,6 +304,25 @@ __gnat_install_handler (void)
 #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,
@@ -312,6 +331,10 @@ __gnat_error_handler (int sig,
   struct Exception_Data *exception;
   const char *msg;
 
+#if defined(__ia64__)
+  __gnat_adjust_context_for_raise (sig, ucontext);
+#endif
+
   switch (sig)
     {
     case SIGSEGV:

gcc/ada/par-ch13.adb

@@ -226,8 +226,8 @@ package body Ch13 is
                --  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 (not Is_Internal_Attribute_Name (Attr_Name)
-                           and then Comes_From_Source (Token_Node))
+                            or else Comes_From_Source (Token_Node))
                then
                   Signal_Bad_Attribute;
                end if;

gcc/ada/par-ch4.adb

@@ -434,13 +434,7 @@ package body Ch4 is
             elsif Token = Tok_Identifier then
                Attr_Name := Token_Name;
 
-               --  Note that internal attributes names don't denote real
+               if not Is_Attribute_Name (Attr_Name) then
-               --  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 Apostrophe_Should_Be_Semicolon then
                      Expr_Form := EF_Name;
                      return Name_Node;

gcc/ada/par-util.adb

@@ -721,13 +721,7 @@ package body Util is
 
       Error_Msg_Name_1 := First_Attribute_Name;
       while Error_Msg_Name_1 <= Last_Attribute_Name loop
-
+         if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then
-         --  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
             Error_Msg_N -- CODEFIX
               ("\possible misspelling of %", Token_Node);
             exit;

gcc/ada/raise-gcc.c

@@ -1167,7 +1167,7 @@ __gnat_cleanupunwind_handler (int version,
 {
   /* 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.  */

gcc/ada/sem_attr.adb

@@ -2218,9 +2218,7 @@ package body Sem_Attr is
       --  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                |
+      when Internal_Attribute_Id =>
-           Attribute_Dispatching_Domain |
-           Attribute_Interrupt_Priority =>
          raise Program_Error;
 
       ------------------

gcc/ada/sem_ch9.adb

@@ -244,12 +244,71 @@ package body Sem_Ch9 is
                ----------------
 
                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
@@ -258,6 +317,8 @@ package body Sem_Ch9 is
 
                         return Abandon;
 
+                     --  Function calls must be static
+
                      elsif Nkind (N) = N_Function_Call
                        and then not Is_Static_Expression (N)
                      then

gcc/ada/snames.adb-tmpl

@@ -127,7 +127,15 @@ package body Snames is
 
    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;
 
    -----------------------
@@ -399,9 +407,7 @@ package body Snames is
    function Is_Internal_Attribute_Name (N : Name_Id) return Boolean is
    begin
       return
-        N = Name_CPU                or else
+        N in First_Internal_Attribute_Name .. Last_Internal_Attribute_Name;
-        N = Name_Interrupt_Priority or else
-        N = Name_Dispatching_Domain;
    end Is_Internal_Attribute_Name;
 
    ----------------------------

gcc/ada/snames.ads-tmpl

@@ -753,14 +753,6 @@ package Snames is
    --  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.
 
@@ -787,7 +779,6 @@ package Snames is
    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 + $;
@@ -795,7 +786,6 @@ package Snames is
    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
@@ -817,7 +807,6 @@ package Snames is
    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
@@ -963,6 +952,21 @@ package Snames is
    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 + $;
@@ -1366,7 +1370,6 @@ package Snames is
       Attribute_Constant_Indexing,
       Attribute_Constrained,
       Attribute_Count,
-      Attribute_CPU,
       Attribute_Default_Bit_Order,
       Attribute_Default_Iterator,
       Attribute_Definite,
@@ -1374,7 +1377,6 @@ package Snames is
       Attribute_Denorm,
       Attribute_Descriptor_Size,
       Attribute_Digits,
-      Attribute_Dispatching_Domain,
       Attribute_Elaborated,
       Attribute_Emax,
       Attribute_Enabled,
@@ -1396,7 +1398,6 @@ package Snames is
       Attribute_Img,
       Attribute_Implicit_Dereference,
       Attribute_Integer_Value,
-      Attribute_Interrupt_Priority,
       Attribute_Invalid_Value,
       Attribute_Iterator_Element,
       Attribute_Large,
@@ -1526,7 +1527,18 @@ package Snames is
 
       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
@@ -1897,7 +1909,9 @@ package Snames is
 
    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

gcc/ada/tracebak.c

@@ -160,7 +160,7 @@ __gnat_backtrace (void **array,
 	break;
 
       /* Skip frames.  */
-      if (skip_frames)
+      if (skip_frames > 1)
 	{
 	  skip_frames--;
 	  continue;