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

adaint.h, adaint.c (DIR_SEPARATOR): Use _T() macro for Unicode support.

Browse Source 
2006-02-13  Pascal Obry  <obry@adacore.com>
	    Nicolas Roche  <roche@adacore.com>
	    Arnaud Charlet  <charlet@adacore.com>

	* adaint.h, adaint.c (DIR_SEPARATOR): Use _T() macro for Unicode
	support.
	(__gnat_try_lock): Add unicode support by using a specific section on
	Windows.
	(__gnat_get_current_dir): Idem.
	(__gnat_open_read): Idem.
	(__gnat_open_rw): Idem.
	(__gnat_open_create): Idem.
	(__gnat_create_output_file): Idem.
	(__gnat_open_append): Idem.
	(__gnat_open_new): Idem.
	(__gnat_file_time_name): Idem.
	(__gnat_set_file_time_name): Idem.
	(__gnat_stat): Idem.
	(win32_no_block_spawn): Idem.
	(__gnat_locate_exec_on_path): Idem.
	(__gnat_opendir): New routine.
	(__gnat_closedir): Idem.
	(__gnat_readdir): Add new parameter length (pointer to int). Update
	implementation to use it and add specific Win32 code for Unicode
	support.
	(__gnat_get_env_value_ptr): Remove. Replaced by __gnat_getenv in env.c
	(__gnat_set_env_value): Remove. Replaced by __gnat_setenv in env.c
	(convert_addresses): Do not define this dummy routine on VMS.

	* mingw32.h (GNAT_UNICODE_SUPPORT): New definition, if set the GNAT
	runtime Unicode support will be activated.
	(S2WS): String to Wide-String conversion. This version just copy a
	string in non Unicode version.
	(WS2S): Wide-String to String conversion. This version just copy a
	string in non Unicode version.

	* g-dirope.adb: (Close): Now import __gnat_closedir from adaint.c.
	(Open): Now import __gnat_opendir from adaint.c.
	(Read): Change the implementation to support unicode characters. It is
	not possible to use strlen() on Windows as this version supports only
	standard ASCII characters. So the length of the directory entry is now
	returned from the imported __gnat_readdir routine.
	Update copyright notice.

	* s-crtl-vms64.ads, s-crtl.ads: (closedir): Moved to adaint.c.
	(opendir): Moved to adaint.c.

	* g-os_lib.adb (Copy_Time_Stamp): Fix off-by-one range computation.
	(Get_Directory): Fix wrong indexing.
	(Getenv): replace __gnat_get_env_value_ptr from adaint.c by
	__gnat_getenv from env.c
	(Setenv): replace __gnat_set_env_value from adaint.c by __gnat_setenv
	from env.c

	* env.h, env.c: New file.

	* s-scaval.adb (Initialize): Replace __gnat_get_env_value_ptr from
	adaint.c by __gnat_getenv from env.c

	* s-shasto.adb (Initialize): replace __gnat_get_env_value_ptr from
	adaint.c by __gnat_getenv from env.c

	* Make-lang.in: Add env.o in the list of C object needed by gnat1
	and gnatbind.
	Update dependencies.

From-SVN: r111029
This commit is contained in:
Pascal Obry 2006-02-15 10:30:39 +01:00 committed by Arnaud Charlet
parent 4f37ea7d5f
commit 0022d9e31d
12 changed files with 2069 additions and 2593 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3881
gcc/ada/Make-lang.in
View File

File diff suppressed because it is too large Load Diff

342
gcc/ada/adaint.c
View File

@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 1992-2005, Free Software Foundation, Inc. *
* Copyright (C) 1992-2006, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@ -411,11 +411,24 @@ __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
int
__gnat_try_lock (char *dir, char *file)
{
char full_path[256];
int fd;
#ifdef __MINGW32__
TCHAR wfull_path[GNAT_MAX_PATH_LEN];
TCHAR wfile[GNAT_MAX_PATH_LEN];
TCHAR wdir[GNAT_MAX_PATH_LEN];
S2WS (wdir, dir, GNAT_MAX_PATH_LEN);
S2WS (wfile, file, GNAT_MAX_PATH_LEN);
_stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile);
fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600);
#else
char full_path[256];
sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
fd = open (full_path, O_CREAT | O_EXCL, 0600);
#endif
if (fd < 0)
return 0;
@ -436,6 +449,7 @@ __gnat_try_lock (char *dir, char *file)
sprintf (full_path, "%s%c%s", dir, DIR_SEPARATOR, file);
fd = open (full_path, O_CREAT | O_EXCL, 0600);
if (fd < 0)
return 0;
@ -522,7 +536,14 @@ __gnat_get_default_identifier_character_set (void)
void
__gnat_get_current_dir (char *dir, int *length)
{
#ifdef VMS
#if defined (__MINGW32__)
TCHAR wdir[GNAT_MAX_PATH_LEN];
_tgetcwd (wdir, *length);
WS2S (dir, wdir, GNAT_MAX_PATH_LEN);
#elif defined (VMS)
/* Force Unix style, which is what GNAT uses internally. */
getcwd (dir, *length, 0);
#else
@ -604,6 +625,13 @@ __gnat_open_read (char *path, int fmode)
"mbc=16", "deq=64", "fop=tef");
#elif defined (__vxworks)
fd = open (path, O_RDONLY | o_fmode, 0444);
#elif defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_RDONLY | o_fmode, 0444);
}
#else
fd = open (path, O_RDONLY | o_fmode);
#endif
@ -638,6 +666,13 @@ __gnat_open_rw (char *path, int fmode)
#if defined (VMS)
fd = open (path, O_RDWR | o_fmode, PERM,
"mbc=16", "deq=64", "fop=tef");
#elif defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_RDWR | o_fmode, PERM);
}
#else
fd = open (path, O_RDWR | o_fmode, PERM);
#endif
@ -657,6 +692,13 @@ __gnat_open_create (char *path, int fmode)
#if defined (VMS)
fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
"mbc=16", "deq=64", "fop=tef");
#elif defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
}
#else
fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM);
#endif
@ -672,6 +714,13 @@ __gnat_create_output_file (char *path)
fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
"rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
"shr=del,get,put,upd");
#elif defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
}
#else
fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
#endif
@ -691,6 +740,13 @@ __gnat_open_append (char *path, int fmode)
#if defined (VMS)
fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
"mbc=16", "deq=64", "fop=tef");
#elif defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
}
#else
fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM);
#endif
@ -712,6 +768,13 @@ __gnat_open_new (char *path, int fmode)
#if defined (VMS)
fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
"mbc=16", "deq=64", "fop=tef");
#elif defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
}
#else
fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
#endif
@ -838,15 +901,44 @@ __gnat_tmp_name (char *tmp_filename)
#endif
}
/* Open directory and returns a DIR pointer. */
DIR* __gnat_opendir (char *name)
{
#ifdef __MINGW32__
TCHAR wname[GNAT_MAX_PATH_LEN];
S2WS (wname, name, GNAT_MAX_PATH_LEN);
return (DIR*)_topendir (wname);
#else
return opendir (name);
#endif
}
/* Read the next entry in a directory. The returned string points somewhere
in the buffer. */
char *
__gnat_readdir (DIR *dirp, char *buffer)
__gnat_readdir (DIR *dirp, char *buffer, int *len)
{
#if defined (__MINGW32__)
struct _tdirent *dirent = _treaddir ((_TDIR*)dirp);
if (dirent != NULL)
{
WS2S (buffer, dirent->d_name, GNAT_MAX_PATH_LEN);
*len = strlen (buffer);
return buffer;
}
else
return NULL;
#elif defined (HAVE_READDIR_R)
/* If possible, try to use the thread-safe version. */
#ifdef HAVE_READDIR_R
if (readdir_r (dirp, buffer) != NULL)
*len = strlen (((struct dirent*) buffer)->d_name);
return ((struct dirent*) buffer)->d_name;
else
return NULL;
@ -857,6 +949,7 @@ __gnat_readdir (DIR *dirp, char *buffer)
if (dirent != NULL)
{
strcpy (buffer, dirent->d_name);
*len = strlen (buffer);
return buffer;
}
else
@ -865,6 +958,18 @@ __gnat_readdir (DIR *dirp, char *buffer)
#endif
}
/* Close a directory entry. */
int __gnat_closedir (DIR *dirp)
{
#ifdef __MINGW32__
return _tclosedir ((_TDIR*)dirp);
#else
return closedir (dirp);
#endif
}
/* Returns 1 if readdir is thread safe, 0 otherwise. */
int
@ -900,8 +1005,7 @@ win32_filetime (HANDLE h)
since <Jan 1st 1970>. */
if (GetFileTime (h, NULL, NULL, &t_write.ft_time))
return (time_t) (t_write.ull_time / 10000000ULL
- w32_epoch_offset);
return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
return (time_t) 0;
}
#endif
@ -920,8 +1024,13 @@ __gnat_file_time_name (char *name)
#elif defined (_WIN32)
time_t ret = 0;
HANDLE h = CreateFile (name, GENERIC_READ, FILE_SHARE_READ, 0,
OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
TCHAR wname[GNAT_MAX_PATH_LEN];
S2WS (wname, name, GNAT_MAX_PATH_LEN);
HANDLE h = CreateFile
(wname, GENERIC_READ, FILE_SHARE_READ, 0,
OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
if (h != INVALID_HANDLE_VALUE)
{
@ -1052,10 +1161,14 @@ __gnat_set_file_time_name (char *name, time_t time_stamp)
FILETIME ft_time;
unsigned long long ull_time;
} t_write;
TCHAR wname[GNAT_MAX_PATH_LEN];
HANDLE h = CreateFile (name, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
NULL);
S2WS (wname, name, GNAT_MAX_PATH_LEN);
HANDLE h = CreateFile
(wname, GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS,
NULL);
if (h == INVALID_HANDLE_VALUE)
return;
/* Add number of seconds between <Jan 1st 1601> and <Jan 1st 1970> */
@ -1122,7 +1235,13 @@ __gnat_set_file_time_name (char *name, time_t time_stamp)
struct dsc$descriptor_s resultdsc
= {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
tryfile = (char *) __gnat_to_host_dir_spec (name, 0);
/* Convert parameter name (a file spec) to host file form. Note that this
is needed on VMS to prepare for subsequent calls to VMS RMS library
routines. Note that it would not work to call __gnat_to_host_dir_spec
as was done in a previous version, since this fails silently unless
the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF
(directory not found) condition is signalled. */
tryfile = (char *) __gnat_to_host_file_spec (name);
/* Allocate and initialize a FAB and NAM structures. */
fab = cc$rms_fab;
@ -1238,123 +1357,6 @@ __gnat_set_file_time_name (char *name, time_t time_stamp)
#endif
}
void
__gnat_get_env_value_ptr (char *name, int *len, char **value)
{
*value = getenv (name);
if (!*value)
*len = 0;
else
*len = strlen (*value);
return;
}
/* VMS specific declarations for set_env_value. */
#ifdef VMS
static char *to_host_path_spec (char *);
struct descriptor_s
{
unsigned short len, mbz;
__char_ptr32 adr;
};
typedef struct _ile3
{
unsigned short len, code;
__char_ptr32 adr;
unsigned short *retlen_adr;
} ile_s;
#endif
void
__gnat_set_env_value (char *name, char *value)
{
#ifdef MSDOS
#elif defined (VMS)
struct descriptor_s name_desc;
/* Put in JOB table for now, so that the project stuff at least works. */
struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
char *host_pathspec = value;
char *copy_pathspec;
int num_dirs_in_pathspec = 1;
char *ptr;
long status;
name_desc.len = strlen (name);
name_desc.mbz = 0;
name_desc.adr = name;
if (*host_pathspec == 0)
/* deassign */
{
status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
/* no need to check status; if the logical name is not
defined, that's fine. */
return;
}
ptr = host_pathspec;
while (*ptr++)
if (*ptr == ',')
num_dirs_in_pathspec++;
{
int i, status;
ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
char *curr, *next;
strcpy (copy_pathspec, host_pathspec);
curr = copy_pathspec;
for (i = 0; i < num_dirs_in_pathspec; i++)
{
next = strchr (curr, ',');
if (next == 0)
next = strchr (curr, 0);
*next = 0;
ile_array[i].len = strlen (curr);
/* Code 2 from lnmdef.h means it's a string. */
ile_array[i].code = 2;
ile_array[i].adr = curr;
/* retlen_adr is ignored. */
ile_array[i].retlen_adr = 0;
curr = next + 1;
}
/* Terminating item must be zero. */
ile_array[i].len = 0;
ile_array[i].code = 0;
ile_array[i].adr = 0;
ile_array[i].retlen_adr = 0;
status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
if ((status & 1) != 1)
LIB$SIGNAL (status);
}
#elif defined (__vxworks) && defined (__RTP__)
setenv (name, value, 1);
#else
int size = strlen (name) + strlen (value) + 2;
char *expression;
expression = (char *) xmalloc (size * sizeof (char));
sprintf (expression, "%s=%s", name, value);
putenv (expression);
#endif
}
#ifdef _WIN32
#include <windows.h>
#endif
@ -1396,7 +1398,7 @@ __gnat_get_libraries_from_registry (void)
for (index = 0; res == ERROR_SUCCESS; index++)
{
value_size = name_size = 256;
res = RegEnumValue (reg_key, index, name, &name_size, 0,
res = RegEnumValue (reg_key, index, (TCHAR*)name, &name_size, 0,
&type, (LPBYTE)value, &value_size);
if (res == ERROR_SUCCESS && type == REG_SZ)
@ -1421,29 +1423,34 @@ __gnat_get_libraries_from_registry (void)
int
__gnat_stat (char *name, struct stat *statbuf)
{
#ifdef _WIN32
#ifdef __MINGW32__
/* Under Windows the directory name for the stat function must not be
terminated by a directory separator except if just after a drive name. */
int name_len = strlen (name);
char last_char = name[name_len - 1];
char win32_name[GNAT_MAX_PATH_LEN + 2];
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
int name_len;
TCHAR last_char;
S2WS (wname, name, GNAT_MAX_PATH_LEN + 2);
name_len = _tcslen (wname);
if (name_len > GNAT_MAX_PATH_LEN)
return -1;
strcpy (win32_name, name);
last_char = wname[name_len - 1];
while (name_len > 1 && (last_char == '\\' || last_char == '/'))
while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
{
win32_name[name_len - 1] = '\0';
wname[name_len - 1] = _T('\0');
name_len--;
last_char = win32_name[name_len - 1];
last_char = wname[name_len - 1];
}
if (name_len == 2 && win32_name[1] == ':')
strcat (win32_name, "\\");
/* Only a drive letter followed by ':', we must add a directory separator
for the stat routine to work properly. */
if (name_len == 2 && wname[1] == _T(':'))
_tcscat (wname, _T("\\"));
return stat (win32_name, statbuf);
return _tstat (wname, statbuf);
#else
return stat (name, statbuf);
@ -1811,11 +1818,20 @@ win32_no_block_spawn (char *command, char *args[])
k++;
}
result = CreateProcess
(NULL, (char *) full_command, &SA, NULL, TRUE,
GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
{
int wsize = csize * 2;
TCHAR *wcommand = (TCHAR *) xmalloc (wsize);
free (full_command);
S2WS (wcommand, full_command, wsize);
free (full_command);
result = CreateProcess
(NULL, wcommand, &SA, NULL, TRUE,
GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
free (wcommand);
}
if (result == TRUE)
{
@ -2075,33 +2091,42 @@ char *
__gnat_locate_exec_on_path (char *exec_name)
{
char *apath_val;
#ifdef VMS
char *path_val = "/VAXC$PATH";
#else
char *path_val = getenv ("PATH");
#endif
#ifdef _WIN32
TCHAR *wpath_val = _tgetenv (_T("PATH"));
TCHAR *wapath_val;
/* In Win32 systems we expand the PATH as for XP environment
variables are not automatically expanded. We also prepend the
".;" to the path to match normal NT path search semantics */
#define EXPAND_BUFFER_SIZE 32767
apath_val = alloca (EXPAND_BUFFER_SIZE);
wapath_val = alloca (EXPAND_BUFFER_SIZE);
apath_val [0] = '.';
apath_val [1] = ';';
wapath_val [0] = '.';
wapath_val [1] = ';';
DWORD res = ExpandEnvironmentStrings
(path_val, apath_val + 2, EXPAND_BUFFER_SIZE - 2);
(wpath_val, &wapath_val[2], EXPAND_BUFFER_SIZE - 2);
if (!res) wapath_val [0] = _T('\0');
apath_val = alloca (EXPAND_BUFFER_SIZE);
WS2S (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
return __gnat_locate_exec (exec_name, apath_val);
if (!res) apath_val [0] = '\0';
#else
#ifdef VMS
char *path_val = "/VAXC$PATH";
#else
char *path_val = getenv ("PATH");
#endif
apath_val = alloca (strlen (path_val) + 1);
strcpy (apath_val, path_val);
#endif
return __gnat_locate_exec (exec_name, apath_val);
#endif
}
#ifdef VMS
@ -2556,6 +2581,7 @@ _flush_cache()
&& ! defined (__APPLE__) \
&& ! defined (_AIX) \
&& ! (defined (__alpha__) && defined (__osf__)) \
&& ! defined (VMS) \
&& ! defined (__MINGW32__) \
&& ! (defined (__mips) && defined (__sgi)))

16
gcc/ada/adaint.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2005, Free Software Foundation, Inc. *
* Copyright (C) 1992-2006, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@ -30,7 +30,13 @@
* *
****************************************************************************/
#include <sys/stat.h>
#include <stdio.h>
#ifdef _WIN32
#include "mingw32.h"
#endif
#include <dirent.h>
typedef long OS_Time; /* Type corresponding to GNAT.OS_Lib.OS_Time */
@ -68,7 +74,9 @@ extern int __gnat_open_append (char *, int);
extern long __gnat_file_length (int);
extern long __gnat_named_file_length (char *);
extern void __gnat_tmp_name (char *);
extern char *__gnat_readdir (DIR *, char *);
extern DIR *__gnat_opendir (char *);
extern char *__gnat_readdir (DIR *, char *, int *);
extern int __gnat_closedir (DIR *);
extern int __gnat_readdir_is_thread_safe (void);
extern OS_Time __gnat_file_time_name (char *);
@ -76,8 +84,7 @@ extern OS_Time __gnat_file_time_fd (int);
/* return -1 in case of error */
extern void __gnat_set_file_time_name (char *, time_t);
extern void __gnat_get_env_value_ptr (char *, int *,
char **);
extern int __gnat_dup (int);
extern int __gnat_dup2 (int, int);
extern int __gnat_file_exists (char *);
@ -98,7 +105,6 @@ extern char *__gnat_locate_exec_on_path (char *);
extern char *__gnat_locate_regular_file (char *, char *);
extern void __gnat_maybe_glob_args (int *, char ***);
extern void __gnat_os_exit (int);
extern void __gnat_set_env_value (char *, char *);
extern char *__gnat_get_libraries_from_registry (void);
extern int __gnat_to_canonical_file_list_init (char *, int);
extern char *__gnat_to_canonical_file_list_next (void);

314
gcc/ada/env.c Normal file
View File

@ -0,0 +1,314 @@
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* E N V *
* *
* C Implementation File *
* *
* Copyright (C) 2005-2006, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* ware Foundation; either version 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
* Boston, MA 02110-1301, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
#include <sys/stat.h>
#include <fcntl.h>
#include <time.h>
#ifdef VMS
#include <unixio.h>
#endif
#if defined (__APPLE__)
#include <crt_externs.h>
#endif
#if defined (__MINGW32__)
#include <stdlib.h>
#endif
#if defined (__vxworks) && ! (defined (__RTP__) || defined (__COREOS__))
#include "envLib.h"
extern char** ppGlobalEnviron;
#endif
/* We don't have libiberty, so use malloc. */
#define xmalloc(S) malloc (S)
#else /* IN_RTS */
#include "config.h"
#include "system.h"
#endif /* IN_RTS */
#include "env.h"
void
__gnat_getenv (char *name, int *len, char **value)
{
*value = getenv (name);
if (!*value)
*len = 0;
else
*len = strlen (*value);
return;
}
/* VMS specific declarations for set_env_value. */
#ifdef VMS
static char *to_host_path_spec (char *);
struct descriptor_s
{
unsigned short len, mbz;
__char_ptr32 adr;
};
typedef struct _ile3
{
unsigned short len, code;
__char_ptr32 adr;
unsigned short *retlen_adr;
} ile_s;
#endif
void
__gnat_setenv (char *name, char *value)
{
#ifdef MSDOS
#elif defined (VMS)
struct descriptor_s name_desc;
/* Put in JOB table for now, so that the project stuff at least works. */
struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
char *host_pathspec = value;
char *copy_pathspec;
int num_dirs_in_pathspec = 1;
char *ptr;
long status;
name_desc.len = strlen (name);
name_desc.mbz = 0;
name_desc.adr = name;
if (*host_pathspec == 0)
/* deassign */
{
status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
/* no need to check status; if the logical name is not
defined, that's fine. */
return;
}
ptr = host_pathspec;
while (*ptr++)
if (*ptr == ',')
num_dirs_in_pathspec++;
{
int i, status;
ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
char *curr, *next;
strcpy (copy_pathspec, host_pathspec);
curr = copy_pathspec;
for (i = 0; i < num_dirs_in_pathspec; i++)
{
next = strchr (curr, ',');
if (next == 0)
next = strchr (curr, 0);
*next = 0;
ile_array[i].len = strlen (curr);
/* Code 2 from lnmdef.h means it's a string. */
ile_array[i].code = 2;
ile_array[i].adr = curr;
/* retlen_adr is ignored. */
ile_array[i].retlen_adr = 0;
curr = next + 1;
}
/* Terminating item must be zero. */
ile_array[i].len = 0;
ile_array[i].code = 0;
ile_array[i].adr = 0;
ile_array[i].retlen_adr = 0;
status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
if ((status & 1) != 1)
LIB$SIGNAL (status);
}
#elif defined (__vxworks) && defined (__RTP__)
setenv (name, value, 1);
#else
int size = strlen (name) + strlen (value) + 2;
char *expression;
expression = (char *) xmalloc (size * sizeof (char));
sprintf (expression, "%s=%s", name, value);
putenv (expression);
#if defined (__FreeBSD__) || defined (__APPLE__) || defined (__MINGW32__) \
||(defined (__vxworks) && ! defined (__RTP__))
/* On some systems like FreeBSD, MacOS X and Windows, putenv is making
a copy of the expression string so we can free it after the call to
putenv */
free (expression);
#endif
#endif
}
char **
__gnat_environ (void)
{
#if defined (VMS)
/* Not implemented */
return NULL;
#elif defined (__APPLE__)
char ***result = _NSGetEnviron ();
return *result;
#elif defined (__MINGW32__)
return _environ;
#elif defined (sun)
extern char **_environ;
return _environ;
#else
#if ! (defined (__vxworks) && ! (defined (__RTP__) || defined (__COREOS__)))
/* in VxWorks kernel mode environ is macro and not a variable */
/* same thing on 653 in the CoreOS */
extern char **environ;
#endif
return environ;
#endif
}
void __gnat_unsetenv (char *name) {
#if defined (VMS)
/* Not implemented */
return;
#elif defined (__hpux__) || defined (sun) \
|| (defined (__mips) && defined (__sgi)) \
|| (defined (__vxworks) && ! defined (__RTP__)) \
|| defined (_AIX)
/* On Solaris, HP-UX and IRIX there is no function to clear an environment
variable. So we look for the variable in the environ table and delete it
by setting the entry to NULL. This can clearly cause some memory leaks
but free cannot be used on this context as not all strings in the environ
have been allocated using malloc. To avoid this memory leak another
method can be used. It consists in forcing the reallocation of all the
strings in the environ table using malloc on the first call on the
functions related to environment variable management. The disavantage
is that if a program makes a direct call to getenv the return string
may be deallocated at some point. */
/* Note that on AIX, unsetenv is not supported on 5.1 but it is on 5.3.
As we are still supporting AIX 5.1 we cannot use unsetenv */
char **env = __gnat_environ ();
int index = 0;
int size = strlen (name);
while (env[index] != NULL) {
if (strlen (env[index]) > size) {
if (strstr (env[index], name) == env[index] &&
env[index][size] == '=') {
#if defined (__vxworks) && ! defined (__RTP__)
/* on Vxworks we are sure that the string has been allocated using
malloc */
free (env[index]);
#endif
while (env[index] != NULL) {
env[index]=env[index + 1];
index++;
}
} else
index++;
} else
index++;
}
#elif defined (__MINGW32__)
/* On Windows platform putenv ("key=") is equivalent to unsetenv (a
subsequent call to getenv ("key") will return NULL and not the "\0"
string */
int size = strlen (name) + 2;
char *expression;
expression = (char *) xmalloc (size * sizeof (char));
sprintf (expression, "%s=", name);
putenv (expression);
free (expression);
#else
unsetenv (name);
#endif
}
void __gnat_clearenv (void) {
#if defined (VMS)
/* not implemented */
return;
#elif defined (sun) || (defined (__mips) && defined (__sgi)) \
|| (defined (__vxworks) && ! defined (__RTP__)) || defined (__Lynx__)
/* On Solaris, IRIX, VxWorks (not RTPs), and Lynx there is no system
call to unset a variable or to clear the environment so set all
the entries in the environ table to NULL (see comment in
__gnat_unsetenv for more explanation). */
char **env = __gnat_environ ();
int index = 0;
while (env[index] != NULL) {
env[index]=NULL;
index++;
}
#elif defined (__MINGW32__) || defined (__FreeBSD__) || defined (__APPLE__) \
|| (defined (__vxworks) && defined (__RTP__))
/* On Windows, FreeBSD and MacOS there is no function to clean all the
environment but there is a "clean" way to unset a variable. So go
through the environ table and call __gnat_unsetenv on all entries */
char **env = __gnat_environ ();
int size;
while (env[0] != NULL) {
size = 0;
while (env[0][size] != '=')
size++;
/* create a string that contains "name" */
size++;
{
char expression[size];
strncpy (expression, env[0], size);
expression[size - 1] = 0;
__gnat_unsetenv (expression);
}
}
#else
clearenv ();
#endif
}

6
gcc/ada/env.h Normal file
View File

@ -0,0 +1,6 @@
extern void __gnat_getenv (char *name, int *len, char **value);
extern void __gnat_setenv (char *name, char *value);
extern char **__gnat_environ (void);
extern void __gnat_unsetenv (char *name);
extern void __gnat_clearenv (void);

22
gcc/ada/g-dirope.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2005, AdaCore --
-- Copyright (C) 1998-2006, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -33,7 +33,6 @@
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Unchecked_Deallocation;
with Unchecked_Conversion;
@ -187,6 +186,9 @@ package body GNAT.Directory_Operations is
Discard : Integer;
pragma Warnings (Off, Discard);
function closedir (directory : DIRs) return Integer;
pragma Import (C, closedir, "__gnat_closedir");
begin
if not Is_Open (Dir) then
raise Directory_Error;
@ -625,6 +627,9 @@ package body GNAT.Directory_Operations is
(Dir : out Dir_Type;
Dir_Name : Dir_Name_Str)
is
function opendir (file_name : String) return DIRs;
pragma Import (C, opendir, "__gnat_opendir");
C_File_Name : constant String := Dir_Name & ASCII.NUL;
begin
@ -647,7 +652,7 @@ package body GNAT.Directory_Operations is
Last : out Natural)
is
Filename_Addr : Address;
Filename_Len : Integer;
Filename_Len : aliased Integer;
Buffer : array (0 .. Filename_Max + 12) of Character;
-- 12 is the size of the dirent structure (see dirent.h), without the
@ -655,27 +660,24 @@ package body GNAT.Directory_Operations is
function readdir_gnat
(Directory : System.Address;
Buffer : System.Address) return System.Address;
Buffer : System.Address;
Last : access Integer) return System.Address;
pragma Import (C, readdir_gnat, "__gnat_readdir");
function strlen (S : Address) return Integer;
pragma Import (C, strlen, "strlen");
begin
if not Is_Open (Dir) then
raise Directory_Error;
end if;
Filename_Addr :=
readdir_gnat (System.Address (Dir.all), Buffer'Address);
readdir_gnat
(System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
if Filename_Addr = System.Null_Address then
Last := 0;
return;
end if;
Filename_Len := strlen (Filename_Addr);
if Str'Length > Filename_Len then
Last := Str'First + Filename_Len - 1;
else

17
gcc/ada/g-os_lib.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1995-2005, AdaCore --
-- Copyright (C) 1995-2006, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -609,11 +609,11 @@ package body GNAT.OS_Lib is
C_Source : String (1 .. Source'Length + 1);
C_Dest : String (1 .. Dest'Length + 1);
begin
C_Source (1 .. C_Source'Length) := Source;
C_Source (C_Source'Last) := ASCII.Nul;
C_Source (1 .. Source'Length) := Source;
C_Source (C_Source'Last) := ASCII.NUL;
C_Dest (1 .. C_Dest'Length) := Dest;
C_Dest (C_Dest'Last) := ASCII.Nul;
C_Dest (1 .. Dest'Length) := Dest;
C_Dest (C_Dest'Last) := ASCII.NUL;
if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then
Success := False;
@ -1057,7 +1057,7 @@ package body GNAT.OS_Lib is
function Getenv (Name : String) return String_Access is
procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
@ -1702,12 +1702,11 @@ package body GNAT.OS_Lib is
-- Directory given, add directory separator if needed
if Dir'Length > 0 then
if Dir (Dir'Length) = Directory_Separator then
if Dir (Dir'Last) = Directory_Separator then
return Directory;
else
declare
Result : String (1 .. Dir'Length + 1);
begin
Result (1 .. Dir'Length) := Dir;
Result (Result'Length) := Directory_Separator;
@ -2313,7 +2312,7 @@ package body GNAT.OS_Lib is
F_Value : String (1 .. Value'Length + 1);
procedure Set_Env_Value (Name, Value : System.Address);
pragma Import (C, Set_Env_Value, "__gnat_set_env_value");
pragma Import (C, Set_Env_Value, "__gnat_setenv");
begin
F_Name (1 .. Name'Length) := Name;

31
gcc/ada/mingw32.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 2002-2004, Free Software Foundation, Inc. *
* Copyright (C) 2002-2006, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@ -36,6 +36,35 @@
#ifndef _MINGW32_H
#define _MINGW32_H
/* Uncomment to activate the GNAT Unicode support. */
/*#define GNAT_UNICODE_SUPPORT */
#ifdef GNAT_UNICODE_SUPPORT
#define _UNICODE /* For C runtime */
#define UNICODE /* For Win32 API */
#endif
#include <tchar.h>
/* After including this file it is possible to use the character t as prefix
to routines. If GNAT_UNICODE_SUPPORT is defined then the unicode enabled
versions will be used. */
/* Copy to/from wide-string, if GNAT_UNICODE_SUPPORT activated this will do
the proper translations using the UTF-8 encoding. */
#ifdef GNAT_UNICODE_SUPPORT
#define S2WS(wstr,str,len) \
MultiByteToWideChar (CP_UTF8,0,str,-1,wstr,len);
#define WS2S(str,wstr,len) \
WideCharToMultiByte (CP_UTF8,0,wstr,-1,str,len,NULL,NULL);
#else
#define S2WS(wstr,str,len) strncpy(wstr,str,len);
#define WS2S(str,wstr,len) strncpy(str,wstr,len);
#endif
#include <stdlib.h>
/* STD_MINGW: standard if MINGW32 version > 1.3, we have switched to this

8
gcc/ada/s-crtl-vms64.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2005 Free Software Foundation, Inc. --
-- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -63,9 +63,6 @@ package System.CRTL is
procedure clearerr (stream : FILEs);
pragma Import (C, clearerr, "decc$clearerr");
function closedir (directory : DIRs) return Integer;
pragma Import (C, closedir, "decc$closedir");
function dup (handle : int) return int;
pragma Import (C, dup, "decc$dup");
@ -137,9 +134,6 @@ package System.CRTL is
procedure mktemp (template : chars);
pragma Import (C, mktemp, "decc$_mktemp64");
function opendir (file_name : String) return DIRs;
pragma Import (C, opendir, "decc$opendir");
function pclose (stream : System.Address) return int;
pragma Import (C, pclose, "decc$pclose");

8
gcc/ada/s-crtl.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2003-2005 Free Software Foundation, Inc. --
-- Copyright (C) 2003-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -63,9 +63,6 @@ package System.CRTL is
procedure clearerr (stream : FILEs);
pragma Import (C, clearerr, "clearerr");
function closedir (directory : DIRs) return Integer;
pragma Import (C, closedir, "closedir");
function dup (handle : int) return int;
pragma Import (C, dup, "dup");
@ -137,9 +134,6 @@ package System.CRTL is
procedure mktemp (template : chars);
pragma Import (C, mktemp, "mktemp");
function opendir (file_name : String) return DIRs;
pragma Import (C, opendir, "opendir");
function pclose (stream : System.Address) return int;
pragma Import (C, pclose, "pclose");

2
gcc/ada/s-scaval.adb
View File

@ -44,7 +44,7 @@ package body System.Scalar_Values is
C2 : Character := Mode2;
procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
subtype String2 is String (1 .. 2);
type String2_Ptr is access all String2;

15
gcc/ada/s-shasto.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -34,7 +34,6 @@
with Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Streams;
with Ada.Streams.Stream_IO;
with System.Global_Locks;
with System.Soft_Links;
@ -86,7 +85,7 @@ package body System.Shared_Storage is
procedure Write
(Stream : in out File_Stream_Type;
Item : in AS.Stream_Element_Array);
Item : AS.Stream_Element_Array);
subtype Hash_Header is Natural range 0 .. 30;
-- Number of hash headers, related (for efficiency purposes only)
@ -249,7 +248,7 @@ package body System.Shared_Storage is
procedure Initialize is
procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
@ -331,7 +330,7 @@ package body System.Shared_Storage is
-- Shared_Var_Close --
----------------------
procedure Shared_Var_Close (Var : in SIO.Stream_Access) is
procedure Shared_Var_Close (Var : SIO.Stream_Access) is
pragma Warnings (Off, Var);
begin
@ -342,7 +341,7 @@ package body System.Shared_Storage is
-- Shared_Var_Lock --
---------------------
procedure Shared_Var_Lock (Var : in String) is
procedure Shared_Var_Lock (Var : String) is
pragma Warnings (Off, Var);
begin
@ -429,7 +428,7 @@ package body System.Shared_Storage is
-- Shared_Var_Unlock --
-----------------------
procedure Shared_Var_Unlock (Var : in String) is
procedure Shared_Var_Unlock (Var : String) is
pragma Warnings (Off, Var);
begin
@ -522,7 +521,7 @@ package body System.Shared_Storage is
procedure Write
(Stream : in out File_Stream_Type;
Item : in AS.Stream_Element_Array)
Item : AS.Stream_Element_Array)
is
begin
SIO.Write (Stream.File, Item);