2010-06-22 Doug Rupp <rupp@adacore.com>

	* system-vms.ads, system-vms-zcx.ads: Remove old unused VMS system
	packages.
	* system-vms_64.ads, system-vms-ia64.ads: Minor reformatting.
	(pragma Ident): Add a default ident string in the private part.

2010-06-22  Robert Dewar  <dewar@adacore.com>

	* cstand.adb: Minor reformatting.

2010-06-22  Ed Schonberg  <schonberg@adacore.com>

	* freeze.adb (Build_And_Analyze_Renamed_Body): For expansion purposes,
	recognize the Shift and Rotation intrinsics that are known to the
	compiler but have no interface name.

2010-06-22  Geert Bosch  <bosch@adacore.com>

	* a-ngcoty.adb ("*"): Rewrite complex multiplication to use proper
	scaling in case of overflow or NaN results.



git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@161210 138bc75d-0d04-0410-961f-82ee72b054a4

8 files changed, 75 insertions, 493 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 870345ab914..723187c5af8 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,25 @@
+2010-06-22  Doug Rupp  <rupp@adacore.com>
+
+	* system-vms.ads, system-vms-zcx.ads: Remove old unused VMS system
+	packages.
+	* system-vms_64.ads, system-vms-ia64.ads: Minor reformatting.
+	(pragma Ident): Add a default ident string in the private part.
+
+2010-06-22  Robert Dewar  <dewar@adacore.com>
+
+	* cstand.adb: Minor reformatting.
+
+2010-06-22  Ed Schonberg  <schonberg@adacore.com>
+
+	* freeze.adb (Build_And_Analyze_Renamed_Body): For expansion purposes,
+	recognize the Shift and Rotation intrinsics that are known to the
+	compiler but have no interface name.
+
+2010-06-22  Geert Bosch  <bosch@adacore.com>
+
+	* a-ngcoty.adb ("*"): Rewrite complex multiplication to use proper
+	scaling in case of overflow or NaN results.
+
 2010-06-22  Robert Dewar  <dewar@adacore.com>
 
 	* cstand.adb: Complete previous change.
diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb
index 81cc68a718a..d45dcd2a9ad 100644
--- a/gcc/ada/a-ngcoty.adb
+++ b/gcc/ada/a-ngcoty.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -43,6 +43,12 @@ package body Ada.Numerics.Generic_Complex_Types is
    ---------
 
    function "*" (Left, Right : Complex) return Complex is
+
+      Scale : constant R := R (R'Machine_Radix) ** ((R'Machine_Emax - 1) / 2);
+      --  In case of overflow, scale the operands by the largest power of the
+      --  radix (to avoid rounding error), so that the square of the scale does
+      --  not overflow itself.
+
       X : R;
       Y : R;
 
@@ -53,14 +59,19 @@ package body Ada.Numerics.Generic_Complex_Types is
       --  If either component overflows, try to scale (skip in fast math mode)
 
       if not Standard'Fast_Math then
-         if abs (X) > R'Last then
-            X := R'(4.0) * (R'(Left.Re / 2.0)  * R'(Right.Re / 2.0)
-                            - R'(Left.Im / 2.0) * R'(Right.Im / 2.0));
+
+         --  ??? the test below is weird, it needs a comment, otherwise I or
+         --  someone else will change it back to R'Last > abs (X) ???
+
+         if not (abs (X) <= R'Last) then
+            X := Scale**2 * ((Left.Re / Scale) * (Right.Re / Scale) -
+                             (Left.Im / Scale) * (Right.Im / Scale));
          end if;
 
-         if abs (Y) > R'Last then
-            Y := R'(4.0) * (R'(Left.Re / 2.0)  * R'(Right.Im / 2.0)
-                            - R'(Left.Im / 2.0) * R'(Right.Re / 2.0));
+         --  ??? same weird test ???
+         if not (abs (Y) <= R'Last) then
+            Y := Scale**2 * ((Left.Re / Scale) * (Right.Im / Scale)
+                           + (Left.Im / Scale) * (Right.Re / Scale));
          end if;
       end if;
 
@@ -569,7 +580,8 @@ package body Ada.Numerics.Generic_Complex_Types is
          --  in order to prevent inaccuracies on machines where not all
          --  immediate expressions are rounded, such as PowerPC.
 
-         if Re2 > R'Last then
+         --  ??? same weird test, why not Re2 > R'Last ???
+         if not (Re2 <= R'Last) then
             raise Constraint_Error;
          end if;
 
@@ -582,7 +594,8 @@ package body Ada.Numerics.Generic_Complex_Types is
       begin
          Im2 := X.Im ** 2;
 
-         if Im2 > R'Last then
+         --  ??? same weird test
+         if not (Im2 <= R'Last) then
             raise Constraint_Error;
          end if;
 
diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb
index 0a74be8ea59..7cabe91b902 100644
--- a/gcc/ada/cstand.adb
+++ b/gcc/ada/cstand.adb
@@ -287,11 +287,10 @@ package body CStand is
       Set_Etype (Last_Entity  (Standard_Op_Concatw), Standard_Wide_String);
 
       Set_Etype (First_Entity (Standard_Op_Concatww),
-                  Standard_Wide_Wide_String);
+                 Standard_Wide_Wide_String);
 
       Set_Etype (Last_Entity (Standard_Op_Concatww),
-                   Standard_Wide_Wide_String);
-
+                 Standard_Wide_Wide_String);
    end Create_Operators;
 
    ---------------------
@@ -350,13 +349,13 @@ package body CStand is
 
       procedure Pack_String_Type (String_Type : Entity_Id) is
          Prag : constant Node_Id :=
-           Make_Pragma (Stloc,
-             Chars                        => Name_Pack,
-             Pragma_Argument_Associations =>
-               New_List (
-                 Make_Pragma_Argument_Association (Stloc,
-                   Expression => New_Occurrence_Of (String_Type, Stloc))));
-
+                  Make_Pragma (Stloc,
+                    Chars                        => Name_Pack,
+                    Pragma_Argument_Associations =>
+                      New_List (
+                        Make_Pragma_Argument_Association (Stloc,
+                          Expression =>
+                            New_Occurrence_Of (String_Type, Stloc))));
       begin
          Append (Prag, Decl_S);
          Record_Rep_Item (String_Type, Prag);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 5e5877e20b5..48e679b4bed 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -230,10 +230,21 @@ package body Freeze is
 
       if Present (Renamed_Subp)
         and then Is_Intrinsic_Subprogram (Renamed_Subp)
-        and then Present (Interface_Name (Renamed_Subp))
         and then
           (not In_Same_Source_Unit (Renamed_Subp, Ent)
             or else Sloc (Renamed_Subp) < Sloc (Ent))
+        and then
+
+         --  We can make the renaming entity intrisic if the renamed function
+         --  has an interface name, or it is one of the shift/rotate operations
+         --  known to the compiler.
+
+        (Present (Interface_Name (Renamed_Subp))
+          or else Chars (Renamed_Subp) = Name_Rotate_Left
+          or else Chars (Renamed_Subp) = Name_Rotate_Right
+          or else Chars (Renamed_Subp) = Name_Shift_Left
+          or else Chars (Renamed_Subp) = Name_Shift_Right
+          or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic)
       then
          Set_Interface_Name (Ent, Interface_Name (Renamed_Subp));
          if Present (Alias (Renamed_Subp)) then
diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads
index 57fece94076..f5d806ddf77 100644
--- a/gcc/ada/system-vms-ia64.ads
+++ b/gcc/ada/system-vms-ia64.ads
@@ -7,7 +7,7 @@
 --                                 S p e c                                  --
 --            (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version)           --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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 --
@@ -239,7 +239,7 @@ private
    -- Special VMS Interfaces --
    ----------------------------
 
-   procedure Lib_Stop (I : Integer);
+   procedure Lib_Stop (Cond_Value : Integer);
    pragma Interface (C, Lib_Stop);
    pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
    --  Interface to VMS condition handling. Used by RTSfind and pragma
@@ -251,4 +251,7 @@ private
    --  Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug.
    --  Do not remove!
 
+   pragma Ident ("GNAT"); --  Gnat_Static_Version_String
+   --  Default ident for all VMS images.
+
 end System;
diff --git a/gcc/ada/system-vms-zcx.ads b/gcc/ada/system-vms-zcx.ads
deleted file mode 100644
index 5b4c3edb5d6..00000000000
--- a/gcc/ada/system-vms-zcx.ads
+++ /dev/null
@@ -1,232 +0,0 @@
-------------------------------------------------------------------------------
---                                                                          --
---                        GNAT RUN-TIME COMPONENTS                          --
---                                                                          --
---                               S Y S T E M                                --
---                                                                          --
---                                 S p e c                                  --
---                   (OpenVMS GCC_ZCX DEC Threads Version)                  --
---                                                                          --
---          Copyright (C) 2002-2009, 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 --
--- apply solely to the  contents of the part following the private keyword. --
---                                                                          --
--- 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.      --
---                                                                          --
-------------------------------------------------------------------------------
-
-package System is
-   pragma Pure;
-   --  Note that we take advantage of the implementation permission to make
-   --  this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-   --  2005, this is Pure in any case (AI-362).
-
-   type Name is (SYSTEM_NAME_GNAT);
-   System_Name : constant Name := SYSTEM_NAME_GNAT;
-
-   --  System-Dependent Named Numbers
-
-   Min_Int               : constant := Long_Long_Integer'First;
-   Max_Int               : constant := Long_Long_Integer'Last;
-
-   Max_Binary_Modulus    : constant := 2 ** Long_Long_Integer'Size;
-   Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
-   Max_Base_Digits       : constant := Long_Long_Float'Digits;
-   Max_Digits            : constant := Long_Long_Float'Digits;
-
-   Max_Mantissa          : constant := 63;
-   Fine_Delta            : constant := 2.0 ** (-Max_Mantissa);
-
-   Tick                  : constant := 0.01;
-
-   --  Storage-related Declarations
-
-   type Address is private;
-   pragma Preelaborable_Initialization (Address);
-   Null_Address : constant Address;
-
-   Storage_Unit : constant := 8;
-   Word_Size    : constant := 32;
-   Memory_Size  : constant := 2 ** 32;
-
-   --  Address comparison
-
-   function "<"  (Left, Right : Address) return Boolean;
-   function "<=" (Left, Right : Address) return Boolean;
-   function ">"  (Left, Right : Address) return Boolean;
-   function ">=" (Left, Right : Address) return Boolean;
-   function "="  (Left, Right : Address) return Boolean;
-
-   pragma Import (Intrinsic, "<");
-   pragma Import (Intrinsic, "<=");
-   pragma Import (Intrinsic, ">");
-   pragma Import (Intrinsic, ">=");
-   pragma Import (Intrinsic, "=");
-
-   --  Other System-Dependent Declarations
-
-   type Bit_Order is (High_Order_First, Low_Order_First);
-   Default_Bit_Order : constant Bit_Order := Low_Order_First;
-   pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
-   --  Priority-related Declarations (RM D.1)
-
-   Max_Priority           : constant Positive := 30;
-   Max_Interrupt_Priority : constant Positive := 31;
-
-   subtype Any_Priority       is Integer      range  0 .. 31;
-   subtype Priority           is Any_Priority range  0 .. 30;
-   subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
-   Default_Priority : constant Priority := 15;
-
-private
-
-   type Address is mod Memory_Size;
-   Null_Address : constant Address := 0;
-
-   --------------------------------------
-   -- System Implementation Parameters --
-   --------------------------------------
-
-   --  These parameters provide information about the target that is used
-   --  by the compiler. They are in the private part of System, where they
-   --  can be accessed using the special circuitry in the Targparm unit
-   --  whose source should be consulted for more detailed descriptions
-   --  of the individual switch values.
-
-   Backend_Divide_Checks     : constant Boolean := False;
-   Backend_Overflow_Checks   : constant Boolean := True;
-   Command_Line_Args         : constant Boolean := True;
-   Configurable_Run_Time     : constant Boolean := False;
-   Denorm                    : constant Boolean := False;
-   Duration_32_Bits          : constant Boolean := False;
-   Exit_Status_Supported     : constant Boolean := True;
-   Fractional_Fixed_Ops      : constant Boolean := False;
-   Frontend_Layout           : constant Boolean := False;
-   Machine_Overflows         : constant Boolean := False;
-   Machine_Rounds            : constant Boolean := True;
-   OpenVMS                   : constant Boolean := True;
-   Preallocated_Stacks       : constant Boolean := False;
-   Signed_Zeros              : constant Boolean := True;
-   Stack_Check_Default       : constant Boolean := True;
-   Stack_Check_Probes        : constant Boolean := True;
-   Stack_Check_Limits        : constant Boolean := False;
-   Support_64_Bit_Divides    : constant Boolean := True;
-   Support_Aggregates        : constant Boolean := True;
-   Support_Composite_Assign  : constant Boolean := True;
-   Support_Composite_Compare : constant Boolean := True;
-   Support_Long_Shifts       : constant Boolean := True;
-   Always_Compatible_Rep     : constant Boolean := True;
-   Suppress_Standard_Library : constant Boolean := False;
-   Use_Ada_Main_Program_Name : constant Boolean := False;
-   ZCX_By_Default            : constant Boolean := True;
-   GCC_ZCX_Support           : constant Boolean := True;
-
-   --------------------------
-   -- Underlying Priorities --
-   ---------------------------
-
-   --  Important note: this section of the file must come AFTER the
-   --  definition of the system implementation parameters to ensure
-   --  that the value of these parameters is available for analysis
-   --  of the declarations here (using Rtsfind at compile time).
-
-   --  The underlying priorities table provides a generalized mechanism
-   --  for mapping from Ada priorities to system priorities. In some
-   --  cases a 1-1 mapping is not the convenient or optimal choice.
-
-   --  For DEC Threads OpenVMS, we use the full range of 31 priorities
-   --  in the Ada model, but map them by compression onto the more limited
-   --  range of priorities available in OpenVMS.
-
-   --  To replace the default values of the Underlying_Priorities mapping,
-   --  copy this source file into your build directory, edit the file to
-   --  reflect your desired behavior, and recompile with the command:
-
-   --     $ gcc -c -O3 -gnatpgn system.ads
-
-   --  then recompile the run-time parts that depend on this package:
-
-   --     $ gnatmake -a -gnatn -O3 <your application>
-
-   --  then force rebuilding your application if you need different options:
-
-   --     $ gnatmake -f <your options> <your application>
-
-   type Priorities_Mapping is array (Any_Priority) of Integer;
-   pragma Suppress_Initialization (Priorities_Mapping);
-   --  Suppress initialization in case gnat.adc specifies Normalize_Scalars
-
-   Underlying_Priorities : constant Priorities_Mapping :=
-
-     (Priority'First => 16,
-
-      1  => 17,
-      2  => 18,
-      3  => 18,
-      4  => 18,
-      5  => 18,
-      6  => 19,
-      7  => 19,
-      8  => 19,
-      9  => 20,
-      10 => 20,
-      11 => 21,
-      12 => 21,
-      13 => 22,
-      14 => 23,
-
-      Default_Priority   => 24,
-
-      16 => 25,
-      17 => 25,
-      18 => 25,
-      19 => 26,
-      20 => 26,
-      21 => 26,
-      22 => 27,
-      23 => 27,
-      24 => 27,
-      25 => 28,
-      26 => 28,
-      27 => 29,
-      28 => 29,
-      29 => 30,
-
-      Priority'Last      => 30,
-
-      Interrupt_Priority => 31);
-
-   ----------------------------
-   -- Special VMS Interfaces --
-   ----------------------------
-
-   procedure Lib_Stop (I : Integer);
-   pragma Interface (C, Lib_Stop);
-   pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
-   --  Interface to VMS condition handling. Used by RTSfind and pragma
-   --  {Import,Export}_Exception. Put here because this is the only
-   --  VMS specific package that doesn't drag in tasking.
-
-end System;
diff --git a/gcc/ada/system-vms.ads b/gcc/ada/system-vms.ads
deleted file mode 100644
index 4b6f1eacdad..00000000000
--- a/gcc/ada/system-vms.ads
+++ /dev/null
@@ -1,237 +0,0 @@
-------------------------------------------------------------------------------
---                                                                          --
---                        GNAT RUN-TIME COMPONENTS                          --
---                                                                          --
---                               S Y S T E M                                --
---                                                                          --
---                                 S p e c                                  --
---                       (OpenVMS DEC Threads Version)                      --
---                                                                          --
---          Copyright (C) 1992-2009, 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 --
--- apply solely to the  contents of the part following the private keyword. --
---                                                                          --
--- 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.      --
---                                                                          --
-------------------------------------------------------------------------------
-
-package System is
-   pragma Pure;
-   --  Note that we take advantage of the implementation permission to make
-   --  this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-   --  2005, this is Pure in any case (AI-362).
-
-   type Name is (SYSTEM_NAME_GNAT);
-   System_Name : constant Name := SYSTEM_NAME_GNAT;
-
-   --  System-Dependent Named Numbers
-
-   Min_Int               : constant := Long_Long_Integer'First;
-   Max_Int               : constant := Long_Long_Integer'Last;
-
-   Max_Binary_Modulus    : constant := 2 ** Long_Long_Integer'Size;
-   Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
-   Max_Base_Digits       : constant := Long_Long_Float'Digits;
-   Max_Digits            : constant := Long_Long_Float'Digits;
-
-   Max_Mantissa          : constant := 63;
-   Fine_Delta            : constant := 2.0 ** (-Max_Mantissa);
-
-   Tick                  : constant := 0.01;
-
-   --  Storage-related Declarations
-
-   type Address is private;
-   pragma Preelaborable_Initialization (Address);
-   Null_Address : constant Address;
-
-   Storage_Unit : constant := 8;
-   Word_Size    : constant := 32;
-   Memory_Size  : constant := 2 ** 32;
-
-   --  Address comparison
-
-   function "<"  (Left, Right : Address) return Boolean;
-   function "<=" (Left, Right : Address) return Boolean;
-   function ">"  (Left, Right : Address) return Boolean;
-   function ">=" (Left, Right : Address) return Boolean;
-   function "="  (Left, Right : Address) return Boolean;
-
-   pragma Import (Intrinsic, "<");
-   pragma Import (Intrinsic, "<=");
-   pragma Import (Intrinsic, ">");
-   pragma Import (Intrinsic, ">=");
-   pragma Import (Intrinsic, "=");
-
-   --  Other System-Dependent Declarations
-
-   type Bit_Order is (High_Order_First, Low_Order_First);
-   Default_Bit_Order : constant Bit_Order := Low_Order_First;
-   pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
-   --  Priority-related Declarations (RM D.1)
-
-   Max_Priority           : constant Positive := 30;
-   Max_Interrupt_Priority : constant Positive := 31;
-
-   subtype Any_Priority       is Integer      range  0 .. 31;
-   subtype Priority           is Any_Priority range  0 .. 30;
-   subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
-   Default_Priority : constant Priority := 15;
-
-private
-
-   type Address is mod Memory_Size;
-   Null_Address : constant Address := 0;
-
-   --------------------------------------
-   -- System Implementation Parameters --
-   --------------------------------------
-
-   --  These parameters provide information about the target that is used
-   --  by the compiler. They are in the private part of System, where they
-   --  can be accessed using the special circuitry in the Targparm unit
-   --  whose source should be consulted for more detailed descriptions
-   --  of the individual switch values.
-
-   Backend_Divide_Checks     : constant Boolean := False;
-   Backend_Overflow_Checks   : constant Boolean := True;
-   Command_Line_Args         : constant Boolean := True;
-   Configurable_Run_Time     : constant Boolean := False;
-   Denorm                    : constant Boolean := False;
-   Duration_32_Bits          : constant Boolean := False;
-   Exit_Status_Supported     : constant Boolean := True;
-   Fractional_Fixed_Ops      : constant Boolean := False;
-   Frontend_Layout           : constant Boolean := False;
-   Machine_Overflows         : constant Boolean := False;
-   Machine_Rounds            : constant Boolean := True;
-   OpenVMS                   : constant Boolean := True;
-   Preallocated_Stacks       : constant Boolean := False;
-   Signed_Zeros              : constant Boolean := True;
-   Stack_Check_Default       : constant Boolean := True;
-   Stack_Check_Probes        : constant Boolean := True;
-   Stack_Check_Limits        : constant Boolean := False;
-   Support_64_Bit_Divides    : constant Boolean := True;
-   Support_Aggregates        : constant Boolean := True;
-   Support_Composite_Assign  : constant Boolean := True;
-   Support_Composite_Compare : constant Boolean := True;
-   Support_Long_Shifts       : constant Boolean := True;
-   Always_Compatible_Rep     : constant Boolean := True;
-   Suppress_Standard_Library : constant Boolean := False;
-   Use_Ada_Main_Program_Name : constant Boolean := False;
-   ZCX_By_Default            : constant Boolean := True;
-   GCC_ZCX_Support           : constant Boolean := False;
-
-   --------------------------
-   -- Underlying Priorities --
-   ---------------------------
-
-   --  Important note: this section of the file must come AFTER the
-   --  definition of the system implementation parameters to ensure
-   --  that the value of these parameters is available for analysis
-   --  of the declarations here (using Rtsfind at compile time).
-
-   --  The underlying priorities table provides a generalized mechanism
-   --  for mapping from Ada priorities to system priorities. In some
-   --  cases a 1-1 mapping is not the convenient or optimal choice.
-
-   --  For DEC Threads OpenVMS, we use the full range of 31 priorities
-   --  in the Ada model, but map them by compression onto the more limited
-   --  range of priorities available in OpenVMS.
-
-   --  To replace the default values of the Underlying_Priorities mapping,
-   --  copy this source file into your build directory, edit the file to
-   --  reflect your desired behavior, and recompile with the command:
-
-   --     $ gcc -c -O3 -gnatpgn system.ads
-
-   --  then recompile the run-time parts that depend on this package:
-
-   --     $ gnatmake -a -gnatn -O3 <your application>
-
-   --  then force rebuilding your application if you need different options:
-
-   --     $ gnatmake -f <your options> <your application>
-
-   type Priorities_Mapping is array (Any_Priority) of Integer;
-   pragma Suppress_Initialization (Priorities_Mapping);
-   --  Suppress initialization in case gnat.adc specifies Normalize_Scalars
-
-   Underlying_Priorities : constant Priorities_Mapping :=
-
-     (Priority'First => 16,
-
-      1  => 17,
-      2  => 18,
-      3  => 18,
-      4  => 18,
-      5  => 18,
-      6  => 19,
-      7  => 19,
-      8  => 19,
-      9  => 20,
-      10 => 20,
-      11 => 21,
-      12 => 21,
-      13 => 22,
-      14 => 23,
-
-      Default_Priority   => 24,
-
-      16 => 25,
-      17 => 25,
-      18 => 25,
-      19 => 26,
-      20 => 26,
-      21 => 26,
-      22 => 27,
-      23 => 27,
-      24 => 27,
-      25 => 28,
-      26 => 28,
-      27 => 29,
-      28 => 29,
-      29 => 30,
-
-      Priority'Last      => 30,
-
-      Interrupt_Priority => 31);
-
-   ----------------------------
-   -- Special VMS Interfaces --
-   ----------------------------
-
-   procedure Lib_Stop (I : Integer);
-   pragma Interface (C, Lib_Stop);
-   pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
-   --  Interface to VMS condition handling. Used by RTSfind and pragma
-   --  {Import,Export}_Exception. Put here because this is the only
-   --  VMS specific package that doesn't drag in tasking.
-
-   ADA_GNAT : constant Boolean := True;
-   pragma Export_Object (ADA_GNAT, "ADA$GNAT");
-   --  Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug.
-   --  Do not remove!
-
-end System;
diff --git a/gcc/ada/system-vms_64.ads b/gcc/ada/system-vms_64.ads
index 17b1ab81504..2934699420a 100644
--- a/gcc/ada/system-vms_64.ads
+++ b/gcc/ada/system-vms_64.ads
@@ -7,7 +7,7 @@
 --                                 S p e c                                  --
 --                (OpenVMS 64bit GCC_ZCX DEC Threads Version)               --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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 --
@@ -239,7 +239,7 @@ private
    -- Special VMS Interfaces --
    ----------------------------
 
-   procedure Lib_Stop (I : Integer);
+   procedure Lib_Stop (Cond_Value : Integer);
    pragma Interface (C, Lib_Stop);
    pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
    --  Interface to VMS condition handling. Used by RTSfind and pragma
@@ -251,4 +251,7 @@ private
    --  Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug.
    --  Do not remove!
 
+   pragma Ident ("GNAT"); --  Gnat_Static_Version_String
+   --  Default ident for all VMS images.
+
 end System;