[multiple changes]

2010-01-25  Bob Duff  <duff@adacore.com>

	* sem_aggr.adb (Resolve_Array_Aggregate): Check for the case where this
	is an internally-generated positional aggregate, and the bounds are
	already correctly set. We don't want to overwrite those bounds with
	bounds determined by context.

2010-01-25  Robert Dewar  <dewar@adacore.com>

	* g-sercom.ads, gnatcmd.adb, gnatlink.adb, a-ststio.adb, exp_ch6.adb,
	exp_ch9.adb, g-sechas.ads: Minor reformatting.

2010-01-25  Thomas Quinot  <quinot@adacore.com>

	* s-commun.adb (Last_Index): Count must be converted to SEO (a signed
	integer type) before subtracting 1, otherwise the computation may wrap
	(because size_t is modular) and cause the conversion to fail.

2010-01-25  Ed Falis  <falis@adacore.com>

	* sysdep.c, init.c: Adapt to support full run-time on VxWorks MILS.

2010-01-25  Vincent Celier  <celier@adacore.com>

	* prj-attr.adb: New attribute Run_Path_Origin_Required
	* prj-nmsc.adb (Process_Project_Level_Simple_Attributes): Process new
	attribute Run_Path_Origin_Required.
	* prj.ads (Project_Configuration): New component
	Run_Path_Origin_Supported.
	* snames.ads-tmpl: New standard name Run_Path_Origin_Required

From-SVN: r156215

gcc/ada/a-ststio.adb

@@ -29,7 +29,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Interfaces.C_Streams;  use Interfaces.C_Streams;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
 
 with System;               use System;
 with System.Communication; use System.Communication;

gcc/ada/exp_ch6.adb

@@ -4506,14 +4506,12 @@ package body Exp_Ch6 is
             --  Create protected operation as well. Even though the operation
             --  is only accessible within the body, it is possible to make it
             --  available outside of the protected object by using 'Access to
-            --  provide a callback, so we build the protected version in all
-            --  cases.
+            --  provide a callback, so build protected version in all cases.
 
             Prot_Decl :=
-                 Make_Subprogram_Declaration (Loc,
-                   Specification =>
-                     Build_Protected_Sub_Specification
-                      (N, Scop, Protected_Mode));
+              Make_Subprogram_Declaration (Loc,
+                Specification =>
+                  Build_Protected_Sub_Specification (N, Scop, Protected_Mode));
             Insert_Before (Prot_Bod, Prot_Decl);
             Analyze (Prot_Decl);
 

gcc/ada/exp_ch9.adb

@@ -2602,13 +2602,12 @@ package body Exp_Ch9 is
       else
          New_Spec :=
            Make_Function_Specification (Loc,
-              Defining_Unit_Name       =>
-                Make_Defining_Identifier (Sloc (Body_Id),
-                  Chars => Chars (Body_Id)),
-              Parameter_Specifications =>
-                Plist,
-              Result_Definition        =>
-                New_Occurrence_Of (Etype (Body_Id), Loc));
+             Defining_Unit_Name       =>
+               Make_Defining_Identifier (Sloc (Body_Id),
+                 Chars => Chars (Body_Id)),
+             Parameter_Specifications => Plist,
+             Result_Definition        =>
+               New_Occurrence_Of (Etype (Body_Id), Loc));
       end if;
 
       Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec);

gcc/ada/g-sechas.ads

@@ -134,11 +134,10 @@ package GNAT.Secure_Hashes is
       --  The internal processing state of the hashing function
 
       function "=" (L, R : Context) return Boolean is abstract;
-      --  Context is the internal, implementation defined state of an
-      --  intermediate state in a hash computation, and no specific semantics
-      --  can be expected on equality of context values. Only equality of
-      --  final hash values (as returned by the [Wide_]Digest functions below)
-      --  is meaningful.
+      --  Context is the internal, implementation defined intermediate state
+      --  in a hash computation, and no specific semantics can be expected on
+      --  equality of context values. Only equality of final hash values (as
+      --  returned by the [Wide_]Digest functions below) is meaningful.
 
       Initial_Context : constant Context;
       --  Initial value of a Context object. May be used to reinitialize

gcc/ada/g-sercom.ads

@@ -92,8 +92,8 @@ package GNAT.Serial_Communications is
       Last   : out Ada.Streams.Stream_Element_Offset);
    --  Read a set of bytes, put result into Buffer and set Last accordingly.
    --  Last is set to Buffer'First - 1 if no byte has been read, unless
-   --  Buffer'First = Stream_Element_Offset'First, in which case
-   --  Constraint_Error raised instead.
+   --  Buffer'First = Stream_Element_Offset'First, in which case the exception
+   --  Constraint_Error is raised instead.
 
    overriding procedure Write
      (Port   : in out Serial_Port;

gcc/ada/gnatcmd.adb

@@ -579,7 +579,7 @@ procedure GNATCmd is
                         Add_Char_To_Name_Buffer ('"');
                         Add_Str_To_Name_Buffer
                           (Get_Name_String
-                             (Unit.File_Names (Kind).Path.Display_Name));
+                            (Unit.File_Names (Kind).Path.Display_Name));
                         Add_Char_To_Name_Buffer ('"');
 
                         if FD /= Invalid_FD then

gcc/ada/init.c

@@ -310,8 +310,7 @@ __gnat_adjust_context_for_raise (int signo, void *ucontext)
 }
 
 static void
-__gnat_error_handler
-  (int sig, siginfo_t *sip, struct sigcontext *context)
+__gnat_error_handler (int sig, siginfo_t *sip, struct sigcontext *context)
 {
   struct Exception_Data *exception;
   static int recurse = 0;
@@ -582,7 +581,11 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
 {
   mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
 
-  /* On the i386 and x86-64 architectures, stack checking is performed by
+  /* On the i386 and x86-64 architectures, we specifically detect calls to
+     the null address and entirely fold the not-yet-fully-established frame
+     to prevent it from stopping the unwinding.
+
+     On the i386 and x86-64 architectures, stack checking is performed by
      means of probes with moving stack pointer, that is to say the probed
      address is always the value of the stack pointer.  Upon hitting the
      guard page, the stack pointer therefore points to an inaccessible
@@ -602,13 +605,25 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
 
 #if defined (i386)
   unsigned long *pc = (unsigned long *)mcontext->gregs[REG_EIP];
+  /* The call insn pushes the return address onto the stack.  Pop it.  */
+  if (pc == NULL)
+    {
+      mcontext->gregs[REG_EIP] = *(unsigned long *)mcontext->gregs[REG_ESP];
+      mcontext->gregs[REG_ESP] += 4;
+    }
   /* The pattern is "orl $0x0,(%esp)" for a probe in 32-bit mode.  */
-  if (signo == SIGSEGV && pc && *pc == 0x00240c83)
+  else if (signo == SIGSEGV && *pc == 0x00240c83)
     mcontext->gregs[REG_ESP] += 4096 + 4 * sizeof (unsigned long);
 #elif defined (__x86_64__)
   unsigned long *pc = (unsigned long *)mcontext->gregs[REG_RIP];
+  /* The call insn pushes the return address onto the stack.  Pop it.  */
+  if (pc == NULL)
+    {
+      mcontext->gregs[REG_RIP] = *(unsigned long *)mcontext->gregs[REG_RSP];
+      mcontext->gregs[REG_RSP] += 8;
+    }
   /* The pattern is "orq $0x0,(%rsp)" for a probe in 64-bit mode.  */
-  if (signo == SIGSEGV && pc && (*pc & 0xffffffffff) == 0x00240c8348)
+  else if (signo == SIGSEGV && (*pc & 0xffffffffff) == 0x00240c8348)
     mcontext->gregs[REG_RSP] += 4096 + 4 * sizeof (unsigned long);
 #elif defined (__ia64__)
   /* ??? The IA-64 unwinder doesn't compensate for signals.  */
@@ -624,8 +639,12 @@ __gnat_error_handler (int sig,
                       void *ucontext)
 {
   struct Exception_Data *exception;
-  const char *msg;
   static int recurse = 0;
+  const char *msg;
+
+  /* Adjusting is required for every fault context, so adjust for this one
+     now, before we possibly trigger a recursive fault below.  */
+  __gnat_adjust_context_for_raise (sig, ucontext);
 
   switch (sig)
     {
@@ -682,14 +701,8 @@ __gnat_error_handler (int sig,
       exception = &program_error;
       msg = "unhandled signal";
     }
-  recurse = 0;
-
-  /* We adjust the interrupted context here (and not in the fallback
-     unwinding routine) because recent versions of the Native POSIX
-     Thread Library (NPTL) are compiled with unwind information, so
-     the fallback routine is never executed for signal frames.  */
-  __gnat_adjust_context_for_raise (sig, ucontext);
 
+  recurse = 0;
   Raise_From_Signal_Handler (exception, msg);
 }
 
@@ -997,28 +1010,55 @@ __gnat_install_handler(void)
 /* Likewise regarding how the "instruction pointer" register slot can
    be identified in signal machine contexts.  We have either "REG_PC"
    or "PC" at hand, depending on the target CPU and Solaris version.  */
-
 #if !defined (REG_PC)
 #define REG_PC PC
 #endif
 
-static void __gnat_error_handler (int, siginfo_t *, ucontext_t *);
+static void __gnat_error_handler (int, siginfo_t *, void *);
+
+#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
+
+void
+__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
+{
+  mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
+  unsigned long *pc = (unsigned long *)mcontext->gregs[REG_PC];
+
+  /* We specifically detect calls to the null address and entirely fold
+     the not-yet-fully-established frame to prevent it from stopping the
+     unwinding.  */
+  if (pc == NULL)
+#if defined (__sparc)
+    /* The call insn moves the return address into %o7.  Move it back.  */
+    mcontext->gregs[REG_PC] = mcontext->gregs[REG_O7];
+#elif defined (i386)
+    {
+      /* The call insn pushes the return address onto the stack.  Pop it.  */
+      mcontext->gregs[REG_PC] = *(unsigned long *)mcontext->gregs[UESP];
+      mcontext->gregs[UESP] += 4;
+    }
+#elif defined (__x86_64__)
+    {
+      /* The call insn pushes the return address onto the stack.  Pop it.  */
+      mcontext->gregs[REG_PC] = *(unsigned long *)mcontext->gregs[REG_RSP];
+      mcontext->gregs[REG_RSP] += 8;
+    }
+#else
+#error architecture not supported on Solaris
+#endif
+}
 
 static void
-__gnat_error_handler (int sig, siginfo_t *sip, ucontext_t *cx ATTRIBUTE_UNUSED)
+__gnat_error_handler (int sig, siginfo_t *sip, void *ucontext)
 {
   struct Exception_Data *exception;
   static int recurse = 0;
   const char *msg;
 
-  /* If this was an explicit signal from a "kill", just resignal it.  */
-  if (SI_FROMUSER (sip))
-    {
-      signal (sig, SIG_DFL);
-      kill (getpid(), sig);
-    }
+  /* Adjusting is required for every fault context, so adjust for this one
+     now, before we possibly trigger a recursive fault below.  */
+  __gnat_adjust_context_for_raise (sig, ucontext);
 
-  /* Otherwise, treat it as something we handle.  */
   switch (sig)
     {
     case SIGSEGV:
@@ -1030,6 +1070,7 @@ __gnat_error_handler (int sig, siginfo_t *sip, ucontext_t *cx ATTRIBUTE_UNUSED)
 	 much too hard to do anything else and we're just determining
 	 which exception to raise.  */
       if (sip->si_code == SEGV_ACCERR
+	  || (long) sip->si_addr == 0
 	  || (((long) sip->si_addr) & 3) != 0
 	  || recurse)
 	{
@@ -1066,7 +1107,6 @@ __gnat_error_handler (int sig, siginfo_t *sip, ucontext_t *cx ATTRIBUTE_UNUSED)
     }
 
   recurse = 0;
-
   Raise_From_Signal_Handler (exception, msg);
 }
 
@@ -1816,6 +1856,20 @@ __gnat_map_signal (int sig)
       msg = "SIGFPE";
       break;
 #ifdef VTHREADS
+#ifdef __VXWORKSMILS__
+    case SIGILL:
+      exception = &storage_error;
+      msg = "SIGILL: possible stack overflow";
+      break;
+    case SIGSEGV:
+      exception = &storage_error;
+      msg = "SIGSEGV";
+      break;
+    case SIGBUS:
+      exception = &program_error;
+      msg = "SIGBUS";
+      break;
+#else
     case SIGILL:
       exception = &constraint_error;
       msg = "Floating point exception or SIGILL";
@@ -1828,6 +1882,7 @@ __gnat_map_signal (int sig)
       exception = &storage_error;
       msg = "SIGBUS: possible stack overflow";
       break;
+#endif
 #elif (_WRS_VXWORKS_MAJOR == 6)
     case SIGILL:
       exception = &constraint_error;

gcc/ada/prj-attr.adb

@@ -112,6 +112,7 @@ package body Prj.Attr is
 
    "SVdefault_language#" &
    "LVrun_path_option#" &
+   "SVrun_path_origin_supported#" &
    "SVseparate_run_path_options#" &
    "Satoolchain_version#" &
    "Satoolchain_description#" &

gcc/ada/prj-nmsc.adb

@@ -2093,6 +2093,22 @@ package body Prj.Nmsc is
                           In_Tree   => Data.Tree);
                   end if;
 
+               elsif Attribute.Name = Name_Run_Path_Origin_Supported then
+                  declare
+                     pragma Unsuppress (All_Checks);
+                  begin
+                     Project.Config.Run_Path_Origin_Supported :=
+                       Boolean'Value (Get_Name_String (Attribute.Value.Value));
+                  exception
+                     when Constraint_Error =>
+                        Error_Msg
+                          (Data.Flags,
+                           "invalid value """ &
+                           Get_Name_String (Attribute.Value.Value) &
+                           """ for Run_Path_Origin_Supported",
+                           Attribute.Value.Location, Project);
+                  end;
+
                elsif Attribute.Name = Name_Separate_Run_Path_Options then
                   declare
                      pragma Unsuppress (All_Checks);

gcc/ada/prj.ads

@@ -906,6 +906,10 @@ package Prj is
       --  The option to use when linking to specify the path where to look for
       --  libraries.
 
+      Run_Path_Origin_Supported : Boolean := False;
+      --  Specify if the run path option support $ORIGIN to indicate paths
+      --  reative to the directory of the executable.
+
       Separate_Run_Path_Options : Boolean := False;
       --  True if each directory needs to be specified in a separate run path
       --  option.
@@ -1017,6 +1021,7 @@ package Prj is
    Default_Project_Config : constant Project_Configuration :=
                               (Target                        => No_Name,
                                Run_Path_Option               => No_Name_List,
+                               Run_Path_Origin_Supported     => False,
                                Separate_Run_Path_Options     => False,
                                Executable_Suffix             => No_Name,
                                Linker                        => No_Path,

gcc/ada/s-commun.adb

@@ -48,7 +48,7 @@ package body System.Communication is
          raise Constraint_Error with
            "last index out of range (no element transferred)";
       else
-         return First + SEO (Count - 1);
+         return First + SEO (Count) - 1;
       end if;
    end Last_Index;
 

gcc/ada/sem_aggr.adb

@@ -2173,6 +2173,16 @@ package body Sem_Aggr is
          end if;
       end if;
 
+      --  If the aggregate already has bounds attached to it, it means this is
+      --  a positional aggregate created as an optimization by
+      --  Exp_Aggr.Convert_To_Positional, so we don't want to change those
+      --  bounds.
+
+      if Present (Aggregate_Bounds (N)) and then not Others_Allowed then
+         Aggr_Low := Low_Bound (Aggregate_Bounds (N));
+         Aggr_High := High_Bound (Aggregate_Bounds (N));
+      end if;
+
       Set_Aggregate_Bounds
         (N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High));
 

gcc/ada/snames.ads-tmpl

@@ -1130,6 +1130,7 @@ package Snames is
    Name_Roots                            : constant Name_Id := N + $; --  GPR
    Name_Required_Switches                : constant Name_Id := N + $;
    Name_Run_Path_Option                  : constant Name_Id := N + $;
+   Name_Run_Path_Origin_Supported        : constant Name_Id := N + $;
    Name_Separate_Run_Path_Options        : constant Name_Id := N + $;
    Name_Shared_Library_Minimum_Switches  : constant Name_Id := N + $;
    Name_Shared_Library_Prefix            : constant Name_Id := N + $;

gcc/ada/sysdep.c

@@ -34,8 +34,10 @@
 
 #ifdef __vxworks
 #include "ioLib.h"
+#if ! defined (__VXWORKSMILS__)
 #include "dosFsLib.h"
-#if ! defined ( __RTP__) && ! defined (VTHREADS)
+#endif
+#if ! defined (__RTP__) && ! defined (VTHREADS)
 # include "nfsLib.h"
 #endif
 #include "selectLib.h"
@@ -985,7 +987,9 @@ __gnat_is_file_not_found_error (int errno_val) {
       /* In the case of VxWorks, we also have to take into account various
        * filesystem-specific variants of this error.
        */
+#if ! defined (__VXWORKSMILS__)
       case S_dosFsLib_FILE_NOT_FOUND:
+#endif
 #if ! defined (__RTP__) && ! defined (VTHREADS)
       case S_nfsLib_NFSERR_NOENT:
 #endif