-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>
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");
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,
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 --
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 --
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
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 --
-------------
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");
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,
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 --
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 --
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
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 --
-------------
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);
#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)
{
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");
-- 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
-- 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
#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"
/******************************************/
#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. */
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
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);
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 ..
#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
projects / thirdparty / gcc.git / commitdiff
