2009-04-17 Pascal Obry <obry@adacore.com>

	* initialize.c: Set gnat_argv with UTF-8 encoded strings on Windows.

	* adaint.h, argv.c, bindgen.adb: Reverted to previous version.

2009-04-17  Robert Dewar  <dewar@adacore.com>

	* a-except.adb, a-except-2005.adb: Add PE_Address_Of_Intrinsic

	* sem_attr.adb (Analyze_Attribute, case Address): Use
	PE_Address_Of_Intrinsic.

	* types.ads: Add PE_Address_Of_Intrinsic

	* types.h: Add PE_Address_Of_Intrinsic



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

1 files changed, 29 insertions, 19 deletions

diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb
index 9db770c3eb2..ad43e2121d1 100644
--- a/gcc/ada/a-except-2005.adb
+++ b/gcc/ada/a-except-2005.adb
@@ -457,6 +457,7 @@ package body Ada.Exceptions is
    procedure Rcheck_30 (File : System.Address; Line : Integer);
    procedure Rcheck_31 (File : System.Address; Line : Integer);
    procedure Rcheck_32 (File : System.Address; Line : Integer);
+   procedure Rcheck_33 (File : System.Address; Line : Integer);
 
    pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
    pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
@@ -491,6 +492,7 @@ package body Ada.Exceptions is
    pragma Export (C, Rcheck_30, "__gnat_rcheck_30");
    pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
    pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
+   pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
 
    --  None of these procedures ever returns (they raise an exception!). By
    --  using pragma No_Return, we ensure that any junk code after the call,
@@ -528,6 +530,7 @@ package body Ada.Exceptions is
    pragma No_Return (Rcheck_29);
    pragma No_Return (Rcheck_30);
    pragma No_Return (Rcheck_32);
+   pragma No_Return (Rcheck_33);
 
    ---------------------------------------------
    -- Reason Strings for Run-Time Check Calls --
@@ -554,25 +557,27 @@ package body Ada.Exceptions is
    Rmsg_13 : constant String := "tag check failed"                 & NUL;
    Rmsg_14 : constant String := "access before elaboration"        & NUL;
    Rmsg_15 : constant String := "accessibility check failed"       & NUL;
-   Rmsg_16 : constant String := "all guards closed"                & NUL;
-   Rmsg_17 : constant String := "Current_Task referenced in entry" &
+   Rmsg_16 : constant String := "attempt to take address of"       &
+                                " intrinsic subprogram"            & NUL;
+   Rmsg_17 : constant String := "all guards closed"                & NUL;
+   Rmsg_18 : constant String := "Current_Task referenced in entry" &
                                 " body"                            & NUL;
-   Rmsg_18 : constant String := "duplicated entry address"         & NUL;
-   Rmsg_19 : constant String := "explicit raise"                   & NUL;
-   Rmsg_20 : constant String := "finalize/adjust raised exception" & NUL;
-   Rmsg_21 : constant String := "implicit return with No_Return"   & NUL;
-   Rmsg_22 : constant String := "misaligned address value"         & NUL;
-   Rmsg_23 : constant String := "missing return"                   & NUL;
-   Rmsg_24 : constant String := "overlaid controlled object"       & NUL;
-   Rmsg_25 : constant String := "potentially blocking operation"   & NUL;
-   Rmsg_26 : constant String := "stubbed subprogram called"        & NUL;
-   Rmsg_27 : constant String := "unchecked union restriction"      & NUL;
-   Rmsg_28 : constant String := "actual/returned class-wide value "
-                                & "not transportable"              & NUL;
-   Rmsg_29 : constant String := "empty storage pool"               & NUL;
-   Rmsg_30 : constant String := "explicit raise"                   & NUL;
-   Rmsg_31 : constant String := "infinite recursion"               & NUL;
-   Rmsg_32 : constant String := "object too large"                 & NUL;
+   Rmsg_19 : constant String := "duplicated entry address"         & NUL;
+   Rmsg_20 : constant String := "explicit raise"                   & NUL;
+   Rmsg_21 : constant String := "finalize/adjust raised exception" & NUL;
+   Rmsg_22 : constant String := "implicit return with No_Return"   & NUL;
+   Rmsg_23 : constant String := "misaligned address value"         & NUL;
+   Rmsg_24 : constant String := "missing return"                   & NUL;
+   Rmsg_25 : constant String := "overlaid controlled object"       & NUL;
+   Rmsg_26 : constant String := "potentially blocking operation"   & NUL;
+   Rmsg_27 : constant String := "stubbed subprogram called"        & NUL;
+   Rmsg_28 : constant String := "unchecked union restriction"      & NUL;
+   Rmsg_29 : constant String := "actual/returned class-wide"       &
+                                " value not transportable"         & NUL;
+   Rmsg_30 : constant String := "empty storage pool"               & NUL;
+   Rmsg_31 : constant String := "explicit raise"                   & NUL;
+   Rmsg_32 : constant String := "infinite recursion"               & NUL;
+   Rmsg_33 : constant String := "object too large"                 & NUL;
 
    -----------------------
    -- Polling Interface --
@@ -1161,7 +1166,7 @@ package body Ada.Exceptions is
 
    procedure Rcheck_29 (File : System.Address; Line : Integer) is
    begin
-      Raise_Storage_Error_Msg (File, Line, Rmsg_29'Address);
+      Raise_Program_Error_Msg (File, Line, Rmsg_29'Address);
    end Rcheck_29;
 
    procedure Rcheck_30 (File : System.Address; Line : Integer) is
@@ -1179,6 +1184,11 @@ package body Ada.Exceptions is
       Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address);
    end Rcheck_32;
 
+   procedure Rcheck_33 (File : System.Address; Line : Integer) is
+   begin
+      Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
+   end Rcheck_33;
+
    -------------
    -- Reraise --
    -------------