mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-04 02:50:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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

From-SVN: r146226
This commit is contained in:
Arnaud Charlet 2009-04-17 11:06:20 +02:00
parent 78246a6e75
commit ba4a2f78ee
10 changed files with 155 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gcc/ada/ChangeLog
View File

@ -1,18 +1,25 @@
2009-04-17 Pascal Obry <obry@adacore.com>
* initialize.c: Set gnat_argv with UTF-8 encoded strings on Windows.
* init.c: Fix minor typo and style fix.
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
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 Pascal Obry <obry@adacore.com>
* adaint.h, argv.c (__gnat_init_args): New routine used to initialize
command line arguments.
* bindgen.adb: Call __gnat_init_args instead of simple assignments of
argc, argv and envp parameters.
* init.c: Fix minor typo and style fix.
2009-04-17 Nicolas Setton <setton@adacore.com>
* link.c: Add darwin section

48
gcc/ada/a-except-2005.adb
View File

@ -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 --
-------------

48
gcc/ada/a-except.adb
View File

@ -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 --
-------------

1
gcc/ada/adaint.h
View File

@ -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);

52
gcc/ada/argv.c
View File

@ -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)
{

37
gcc/ada/bindgen.adb
View File

@ -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

32
gcc/ada/initialize.c
View File

@ -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

4
gcc/ada/sem_attr.adb
View File

@ -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);

35
gcc/ada/types.ads
View File

@ -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
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, -- 29
SE_Explicit_Raise, -- 30
SE_Infinite_Recursion, -- 31
SE_Object_Too_Large); -- 32
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 ..

37
gcc/ada/types.h
View File

@ -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 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 29
#define SE_Explicit_Raise 30
#define SE_Infinite_Recursion 31
#define SE_Object_Too_Large 32
#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 32
#define LAST_REASON_CODE 33