diff options
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 25 | ||||
-rw-r--r-- | gcc/ada/a-except-2005.adb | 48 | ||||
-rw-r--r-- | gcc/ada/a-except.adb | 48 | ||||
-rw-r--r-- | gcc/ada/adaint.h | 1 | ||||
-rw-r--r-- | gcc/ada/argv.c | 52 | ||||
-rw-r--r-- | gcc/ada/bindgen.adb | 37 | ||||
-rw-r--r-- | gcc/ada/initialize.c | 32 | ||||
-rw-r--r-- | gcc/ada/sem_attr.adb | 4 | ||||
-rw-r--r-- | gcc/ada/types.ads | 37 | ||||
-rw-r--r-- | 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 <setton@adacore.com> +2009-04-17 Pascal Obry <obry@adacore.com> - * 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 <obry@adacore.com> + * 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 <dewar@adacore.com> - * 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 <setton@adacore.com> + + * gcc-interface/Makefile.in: Under darwin, build shared libraries + with install_name starting with "@rpath/". 2009-04-17 Nicolas Setton <setton@adacore.com> 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 <sys/stat.h> -/* 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 <windows.h> + before using gnat_envp to point to the right environment space */ #include <stdlib.h> /* 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<wargc; k++) - { - WS2SU (arg_utf8, wargv[k], MAX_PATH); - gnat_argv[k] = (char *) xmalloc (strlen (arg_utf8) + 1); - strcpy (gnat_argv[k], arg_utf8); - } - - LocalFree (wargv); - gnat_argc = wargc; - } -#else - gnat_argv = argv; - gnat_argc = argc; -#endif - - gnat_envp = envp; -} - int __gnat_arg_count (void) { diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index ef90c6c..ce81c7a 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -1456,17 +1456,6 @@ package body Bindgen is WBI (" is"); - -- ??? the following code needs commenting - - if not Configurable_Run_Time_Mode then - WBI (" procedure Init_Args"); - WBI (" (argc : Integer;"); - WBI (" argv : System.Address;"); - WBI (" envp : System.Address);"); - WBI (" pragma Import (C, Init_Args, ""__gnat_init_args"");"); - WBI (""); - end if; - else if Exit_Status_Supported_On_Target then Set_String (" return Integer is"); @@ -1580,16 +1569,9 @@ package body Bindgen is -- Acquire command line arguments if present on target if Command_Line_Args_On_Target then - if Configurable_Run_Time_Mode then - WBI (" gnat_argc := argc;"); - WBI (" gnat_argv := argv;"); - WBI (" gnat_envp := envp;"); - - -- ??? this else needs a comment - else - WBI (" Init_Args (argc, argv, envp);"); - end if; - + WBI (" gnat_argc := argc;"); + WBI (" gnat_argv := argv;"); + WBI (" gnat_envp := envp;"); WBI (""); -- If configurable run time and no command line args, then nothing @@ -1750,16 +1732,9 @@ package body Bindgen is -- arguments are present on target if Command_Line_Args_On_Target then - if Configurable_Run_Time_Mode then - WBI (" gnat_argc = argc;"); - WBI (" gnat_argv = argv;"); - WBI (" gnat_envp = envp;"); - - -- ??? this call must be commented - else - WBI (" __gnat_init_args (argc, argv, envp);"); - end if; - + WBI (" gnat_argc = argc;"); + WBI (" gnat_argv = argv;"); + WBI (" gnat_envp = envp;"); WBI (" "); -- If configurable run-time, then nothing to do, since in this case diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index dbaf80f..5e7b2ff 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -43,6 +43,8 @@ #ifdef IN_RTS #include "tconfig.h" #include "tsystem.h" +/* We don't have libiberty, so use malloc. */ +#define xmalloc(S) malloc (S) #else #include "config.h" #include "system.h" @@ -55,11 +57,15 @@ /******************************************/ #if defined (__MINGW32__) +#include "mingw32.h" #include <windows.h> 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<wargc; k++) + { + WS2SU (arg_utf8, wargv[k], MAX_PATH); + gnat_argv[k] = (char *) xmalloc (strlen (arg_utf8) + 1); + strcpy (gnat_argv[k], arg_utf8); + } + + LocalFree (wargv); + gnat_argc = wargc; + } + } + /* Note that we do not activate this for the compiler itself to avoid a bootstrap path problem. Older version of gnatbind will generate a call to __gnat_initialize() without argument. Therefore we cannot use eh in diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e2fe5c3..c043c4f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2060,9 +2060,7 @@ package body Sem_Attr is if In_Instance then Rewrite (N, Make_Raise_Program_Error (Loc, - Reason => 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 |