From 2588dbe80b53154a8a7d68eb4cbda531ab36e1f4 Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 17 Apr 2009 09:06:20 +0000 Subject: [PATCH] 2009-04-17 Pascal Obry * 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 * 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 --- gcc/ada/ChangeLog | 25 +++++++++++++++-------- gcc/ada/a-except-2005.adb | 48 ++++++++++++++++++++++++++----------------- gcc/ada/a-except.adb | 48 ++++++++++++++++++++++++++----------------- gcc/ada/adaint.h | 1 - gcc/ada/argv.c | 52 ++++------------------------------------------- gcc/ada/bindgen.adb | 37 ++++++--------------------------- gcc/ada/initialize.c | 32 +++++++++++++++++++++++++++++ gcc/ada/sem_attr.adb | 4 +--- gcc/ada/types.ads | 37 +++++++++++++++++---------------- gcc/ada/types.h | 41 +++++++++++++++++++------------------ 10 files changed, 157 insertions(+), 168 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7f2cc58..e9b46c6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,17 +1,24 @@ -2009-04-17 Nicolas Setton +2009-04-17 Pascal Obry - * gcc-interface/Makefile.in: Under darwin, build shared libraries - with install_name starting with "@rpath/". + * initialize.c: Set gnat_argv with UTF-8 encoded strings on Windows. -2009-04-17 Pascal Obry + * init.c: Fix minor typo and style fix. - * adaint.h, argv.c (__gnat_init_args): New routine used to initialize - command line arguments. +2009-04-17 Robert Dewar - * bindgen.adb: Call __gnat_init_args instead of simple assignments of - argc, argv and envp parameters. + * a-except.adb, a-except-2005.adb: Add PE_Address_Of_Intrinsic - * init.c: Fix minor typo and style fix. + * 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 + +2009-04-17 Nicolas Setton + + * gcc-interface/Makefile.in: Under darwin, build shared libraries + with install_name starting with "@rpath/". 2009-04-17 Nicolas Setton diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 9db770c..ad43e21 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 -- ------------- diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 9a07b2f..229645a 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -414,6 +414,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"); @@ -448,6 +449,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, @@ -485,6 +487,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 -- @@ -511,25 +514,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 -- @@ -1127,7 +1132,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 @@ -1145,6 +1150,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 -- ------------- diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 1501e99..5ed4d76 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -142,7 +142,6 @@ extern FILE *__gnat_constant_stdin (void); extern FILE *__gnat_constant_stdout (void); extern char *__gnat_full_name (char *, char *); -extern void __gnat_init_args (int, char **, char **); extern int __gnat_arg_count (void); extern int __gnat_len_arg (int); extern void __gnat_fill_arg (char *, int); diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c index 6420967..b827b03 100644 --- a/gcc/ada/argv.c +++ b/gcc/ada/argv.c @@ -46,73 +46,29 @@ #include "tconfig.h" #include "tsystem.h" #include -/* We don't have libiberty, so use malloc. */ -#define xmalloc(S) malloc (S) #else #include "config.h" #include "system.h" #endif +#include "adaint.h" + /* argc and argv of the main program are saved under gnat_argc and gnat_argv, envp of the main program is saved under gnat_envp. */ int gnat_argc = 0; -char **gnat_argv = (char **) 0; +const char **gnat_argv = (const char **) 0; const char **gnat_envp = (const char **) 0; #if defined (_WIN32) && !defined (RTX) /* Note that on Windows environment the environ point to a buffer that could be reallocated if needed. It means that gnat_envp needs to be updated - before using gnat_envp to point to the right environment space. */ -#include "mingw32.h" -#include + before using gnat_envp to point to the right environment space */ #include /* for the environ variable definition */ #define gnat_envp (environ) #endif -#include "adaint.h" - -void -__gnat_init_args (int argc, char **argv ATTRIBUTE_UNUSED, char **envp) -{ -#if defined (_WIN32) && ! defined (__vxworks) && ! defined (CROSS_COMPILE) - char arg_utf8[MAX_PATH]; - LPWSTR *wargv; - int wargc; - int k; - - wargv = CommandLineToArgvW (GetCommandLineW(), &wargc); - - if (wargv == NULL) - { - /* CommandLineToArgvW was not successful, use standard argc/argv. */ - gnat_argv = argv; - gnat_argc = argc; - } - else - { - /* Set gnat_argv with arguments encoded in UTF-8. */ - gnat_argv = (char **) xmalloc ((wargc + 1) * sizeof (char *)); - - for (k=0; k extern void __gnat_init_float (void); extern void __gnat_install_SEH_handler (void *); +extern int gnat_argc; +extern char **gnat_argv; + #ifndef RTX /* Do not define for RTX since it is only used for creating child processes which is not supported in RTX. */ @@ -75,6 +81,32 @@ __gnat_initialize (void *eh) given that we have set Max_Digits etc with this in mind */ __gnat_init_float (); + /* Adjust gnat_argv to support Unicode characters. */ + { + char arg_utf8[MAX_PATH]; + LPWSTR *wargv; + int wargc; + int k; + + wargv = CommandLineToArgvW (GetCommandLineW(), &wargc); + + if (wargv != NULL) + { + /* Set gnat_argv with arguments encoded in UTF-8. */ + gnat_argv = (char **) xmalloc ((wargc + 1) * sizeof (char *)); + + for (k=0; k PE_Misaligned_Address_Value)); - -- ??? why Misaligned_Address_Value, seems wrong - + Reason => PE_Address_Of_Intrinsic)); else Error_Msg_N ("cannot take Address of intrinsic subprogram", N); diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 94b037e..3b89ab2 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -787,24 +787,25 @@ package Types is PE_Access_Before_Elaboration, -- 14 PE_Accessibility_Check_Failed, -- 15 - PE_All_Guards_Closed, -- 16 - PE_Current_Task_In_Entry_Body, -- 17 - PE_Duplicated_Entry_Address, -- 18 - PE_Explicit_Raise, -- 19 - PE_Finalize_Raised_Exception, -- 20 - PE_Implicit_Return, -- 21 - PE_Misaligned_Address_Value, -- 22 - PE_Missing_Return, -- 23 - PE_Overlaid_Controlled_Object, -- 24 - PE_Potentially_Blocking_Operation, -- 25 - PE_Stubbed_Subprogram_Called, -- 26 - PE_Unchecked_Union_Restriction, -- 27 - PE_Non_Transportable_Actual, -- 28 - - SE_Empty_Storage_Pool, -- 29 - SE_Explicit_Raise, -- 30 - SE_Infinite_Recursion, -- 31 - SE_Object_Too_Large); -- 32 + PE_Address_Of_Intrinsic, -- 16 + PE_All_Guards_Closed, -- 17 + PE_Current_Task_In_Entry_Body, -- 18 + PE_Duplicated_Entry_Address, -- 19 + PE_Explicit_Raise, -- 20 + PE_Finalize_Raised_Exception, -- 21 + PE_Implicit_Return, -- 22 + PE_Misaligned_Address_Value, -- 23 + PE_Missing_Return, -- 24 + PE_Overlaid_Controlled_Object, -- 25 + PE_Potentially_Blocking_Operation, -- 26 + PE_Stubbed_Subprogram_Called, -- 27 + PE_Unchecked_Union_Restriction, -- 28 + PE_Non_Transportable_Actual, -- 29 + + SE_Empty_Storage_Pool, -- 30 + SE_Explicit_Raise, -- 31 + SE_Infinite_Recursion, -- 32 + SE_Object_Too_Large); -- 33 subtype RT_CE_Exceptions is RT_Exception_Code range CE_Access_Check_Failed .. diff --git a/gcc/ada/types.h b/gcc/ada/types.h index 1d4fd67..9b2cc90 100644 --- a/gcc/ada/types.h +++ b/gcc/ada/types.h @@ -359,23 +359,24 @@ typedef Int Mechanism_Type; #define PE_Access_Before_Elaboration 14 #define PE_Accessibility_Check_Failed 15 -#define PE_All_Guards_Closed 16 -#define PE_Current_Task_In_Entry_Body 17 -#define PE_Duplicated_Entry_Address 18 -#define PE_Explicit_Raise 19 -#define PE_Finalize_Raised_Exception 20 -#define PE_Implicit_Return 21 -#define PE_Misaligned_Address_Value 22 -#define PE_Missing_Return 23 -#define PE_Overlaid_Controlled_Object 24 -#define PE_Potentially_Blocking_Operation 25 -#define PE_Stubbed_Subprogram_Called 26 -#define PE_Unchecked_Union_Restriction 27 -#define PE_Non_Transportable_Actual 28 - -#define SE_Empty_Storage_Pool 29 -#define SE_Explicit_Raise 30 -#define SE_Infinite_Recursion 31 -#define SE_Object_Too_Large 32 - -#define LAST_REASON_CODE 32 +#define PE_Address_Of_Intrinsic 16 +#define PE_All_Guards_Closed 17 +#define PE_Current_Task_In_Entry_Body 18 +#define PE_Duplicated_Entry_Address 19 +#define PE_Explicit_Raise 20 +#define PE_Finalize_Raised_Exception 21 +#define PE_Implicit_Return 22 +#define PE_Misaligned_Address_Value 23 +#define PE_Missing_Return 24 +#define PE_Overlaid_Controlled_Object 25 +#define PE_Potentially_Blocking_Operation 26 +#define PE_Stubbed_Subprogram_Called 27 +#define PE_Unchecked_Union_Restriction 28 +#define PE_Non_Transportable_Actual 29 + +#define SE_Empty_Storage_Pool 30 +#define SE_Explicit_Raise 31 +#define SE_Infinite_Recursion 32 +#define SE_Object_Too_Large 33 + +#define LAST_REASON_CODE 33 -- 2.7.4