+2014-08-01 Robert Dewar <dewar@adacore.com>
+
+ * gnat_rm.texi: Remove VMS specific rules for pragma Ident.
+ * Makefile.rtl, adaint.c, gnat_rm.texi, s-asthan.adb, s-asthan.ads,
+ s-filofl.ads, s-fishfl.ads, s-fvadfl.ads, s-fvaffl.ads, s-fvagfl.ads,
+ s-po32gl.adb, s-po32gl.ads, s-vaflop.adb, s-vaflop.ads, s-vmexta.adb,
+ s-vmexta.ads, sem_vfpt.adb, sem_vfpt.ads, socket.c: Remove VMS specific
+ code.
+ * gcc-interface/decl.c, gcc-interface/Makefile.in,
+ gcc-interface/Make-lang.in: Ditto. Also remove refs to rTX.
+
+2014-08-01 Pascal Obry <obry@adacore.com>
+
+ * s-os_lib.ads: Rename File_Size to Large_File_Size.
+
2014-08-01 Robert Dewar <dewar@adacore.com>
* a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads,
g-signal$(objext) \
g-tastus$(objext) \
g-thread$(objext) \
- s-asthan$(objext) \
s-inmaop$(objext) \
s-interr$(objext) \
s-intman$(objext) \
s-ficobl$(objext) \
s-filatt$(objext) \
s-fileio$(objext) \
- s-filofl$(objext) \
s-finmas$(objext) \
s-finroo$(objext) \
- s-fishfl$(objext) \
s-flocon$(objext) \
s-fore$(objext) \
- s-fvadfl$(objext) \
- s-fvaffl$(objext) \
- s-fvagfl$(objext) \
s-gearop$(objext) \
s-geveop$(objext) \
s-gloloc$(objext) \
s-traent$(objext) \
s-unstyp$(objext) \
s-utf_32$(objext) \
- s-vaflop$(objext) \
s-valboo$(objext) \
s-valcha$(objext) \
s-valdec$(objext) \
s-veboop$(objext) \
s-vector$(objext) \
s-vercon$(objext) \
- s-vmexta$(objext) \
s-wchcnv$(objext) \
s-wchcon$(objext) \
s-wchjis$(objext) \
#include <sys/pstat.h>
#endif
-#ifdef VMS
-#define _POSIX_EXIT 1
-#define HOST_EXECUTABLE_SUFFIX ".exe"
-#define HOST_OBJECT_SUFFIX ".obj"
-#endif
-
#ifdef __PikeOS__
#define __BSD_VISIBLE 1
#endif
#include <sys/stat.h>
#include <fcntl.h>
#include <time.h>
-#ifdef VMS
-#include <unixio.h>
-#endif
#if defined (__vxworks) || defined (__ANDROID__)
/* S_IREAD and S_IWRITE are not defined in VxWorks or Android */
#include <utime.h>
#undef VMOS_DEV
-#elif !defined (VMS)
+#else
#include <utime.h>
#endif
#endif
#if defined (_WIN32)
-#elif defined (VMS)
-
-/* Header files and definitions for __gnat_set_file_time_name. */
-
-#define __NEW_STARLET 1
-#include <vms/rms.h>
-#include <vms/atrdef.h>
-#include <vms/fibdef.h>
-#include <vms/stsdef.h>
-#include <vms/iodef.h>
-#include <errno.h>
-#include <vms/descrip.h>
-#include <string.h>
-#include <unixlib.h>
-
-/* Use native 64-bit arithmetic. */
-#define unix_time_to_vms(X,Y) \
- { \
- unsigned long long reftime, tmptime = (X); \
- $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \
- SYS$BINTIM (&unixtime, &reftime); \
- Y = tmptime * 10000000 + reftime; \
- }
-
-/* descrip.h doesn't have everything ... */
-typedef struct fibdef* __fibdef_ptr32 __attribute__ (( mode (SI) ));
-struct dsc$descriptor_fib
-{
- unsigned int fib$l_len;
- __fibdef_ptr32 fib$l_addr;
-};
-
-/* I/O Status Block. */
-struct IOSB
-{
- unsigned short status, count;
- unsigned int devdep;
-};
-
-static char *tryfile;
-/* Variable length string. */
-struct vstring
-{
- short length;
- char string[NAM$C_MAXRSS+1];
-};
-
-#define SYI$_ACTIVECPU_CNT 0x111e
-extern int LIB$GETSYI (int *, unsigned int *);
-extern unsigned int LIB$CALLG_64 (unsigned long long argument_list [],
- int (*user_procedure)(void));
-
-#else
-#include <utime.h>
-#endif
-
-#if defined (_WIN32)
#include <process.h>
-#endif
-
-#if defined (_WIN32)
-
#include <dir.h>
#include <windows.h>
#include <accctrl.h>
#include <aclapi.h>
#undef DIR_SEPARATOR
#define DIR_SEPARATOR '\\'
+
+#else
+#include <utime.h>
#endif
#include "adaint.h"
as well. This is only a temporary work-around for 3.11b. */
#ifndef GNAT_LIBRARY_TEMPLATE
-#if defined (VMS)
-#define GNAT_LIBRARY_TEMPLATE "*.olb"
-#else
#define GNAT_LIBRARY_TEMPLATE "lib*.a"
#endif
-#endif
const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE;
-/* This variable is used in hostparm.ads to say whether the host is a VMS
- system. */
-#ifdef VMS
-int __gnat_vmsp = 1;
-#else
-int __gnat_vmsp = 0;
-#endif
-
-#if defined (VMS)
-#define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
-
-#elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
+#if defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__)
#define GNAT_MAX_PATH_LEN PATH_MAX
#else
system provides the routine readdir_r. */
#undef HAVE_READDIR_R
\f
-#if defined(VMS) && defined (__LONG_POINTERS)
-
-/* Return a 32 bit pointer to an array of 32 bit pointers
- given a 64 bit pointer to an array of 64 bit pointers */
-
-typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
-
-static __char_ptr_char_ptr32
-to_ptr32 (char **ptr64)
-{
- int argc;
- __char_ptr_char_ptr32 short_argv;
-
- for (argc = 0; ptr64[argc]; argc++)
- ;
-
- /* Reallocate argv with 32 bit pointers. */
- short_argv = (__char_ptr_char_ptr32) decc$malloc
- (sizeof (__char_ptr32) * (argc + 1));
-
- for (argc = 0; ptr64[argc]; argc++)
- short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
-
- short_argv[argc] = (__char_ptr32) 0;
- return short_argv;
-
-}
-#define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
-#else
#define MAYBE_TO_PTR32(argv) argv
-#endif
static const char ATTR_UNSET = 127;
time++;
#endif
-#ifdef VMS
- res = localtime (&time);
-#else
res = gmtime (&time);
-#endif
-
if (res)
{
*p_year = res->tm_year;
char *buf ATTRIBUTE_UNUSED,
size_t bufsiz ATTRIBUTE_UNUSED)
{
-#if defined (_WIN32) || defined (VMS) \
+#if defined (_WIN32) \
|| defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
return -1;
#else
__gnat_symlink (char *oldpath ATTRIBUTE_UNUSED,
char *newpath ATTRIBUTE_UNUSED)
{
-#if defined (_WIN32) || defined (VMS) \
+#if defined (_WIN32) \
|| defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__)
return -1;
#else
/* Try to lock a file, return 1 if success. */
#if defined (__vxworks) || defined (__nucleus__) \
- || defined (_WIN32) || defined (VMS) || defined (__PikeOS__)
+ || defined (_WIN32) || defined (__PikeOS__)
/* Version that does not use link. */
int
__gnat_get_maximum_file_name_length (void)
{
-#if defined (VMS)
- if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS"))
- return -1;
- else
- return 39;
-#else
return -1;
-#endif
}
/* Return nonzero if file names are case sensitive. */
&& sensitive[1] == '\0')
file_names_case_sensitive_cache = sensitive[0] - '0';
else
-#if defined (VMS) || defined (WINNT) || defined (__APPLE__)
+#if defined (WINNT) || defined (__APPLE__)
file_names_case_sensitive_cache = 0;
#else
file_names_case_sensitive_cache = 1;
int
__gnat_get_env_vars_case_sensitive (void)
{
-#if defined (VMS) || defined (WINNT)
+#if defined (WINNT)
return 0;
#else
return 1;
WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
-#elif defined (VMS)
- /* Force Unix style, which is what GNAT uses internally. */
- getcwd (dir, *length, 0);
#else
getcwd (dir, *length);
#endif
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
return _tfopen (wpath, wmode);
-#elif defined (VMS)
- if (vms_form == 0)
- return decc$fopen (path, mode);
- else
- {
- char *local_form = (char *) alloca (strlen (vms_form) + 1);
- /* Allocate an argument list of guaranteed ample length. */
- unsigned long long *arg_list =
- (unsigned long long *) alloca (strlen (vms_form) + 3);
- char *ptrb, *ptre;
- int i;
-
- arg_list [1] = (unsigned long long) path;
- arg_list [2] = (unsigned long long) mode;
- strcpy (local_form, vms_form);
-
- /* Given a string such as "\"rfm=udf\",\"rat=cr\""
- Split it into an argument list as "rfm=udf","rat=cr". */
- ptrb = local_form;
- for (i = 0; *ptrb; i++)
- {
- ptrb = strchr (ptrb, '"');
- ptre = strchr (ptrb + 1, '"');
- *ptre = 0;
- arg_list [i + 3] = (unsigned long long) (ptrb + 1);
- ptrb = ptre + 1;
- }
- arg_list [0] = i + 2;
- /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
- always a 32bit pointer. */
- return LIB$CALLG_64 (arg_list, &decc$fopen);
- }
+
#else
return GNAT_FOPEN (path, mode);
#endif
S2WS (wpath, path, GNAT_MAX_PATH_LEN);
return _tfreopen (wpath, wmode, stream);
-#elif defined (VMS)
- if (vms_form == 0)
- return decc$freopen (path, mode, stream);
- else
- {
- char *local_form = (char *) alloca (strlen (vms_form) + 1);
- /* Allocate an argument list of guaranteed ample length. */
- unsigned long long *arg_list =
- (unsigned long long *) alloca (strlen (vms_form) + 4);
- char *ptrb, *ptre;
- int i;
-
- arg_list [1] = (unsigned long long) path;
- arg_list [2] = (unsigned long long) mode;
- arg_list [3] = (unsigned long long) stream;
- strcpy (local_form, vms_form);
-
- /* Given a string such as "\"rfm=udf\",\"rat=cr\""
- Split it into an argument list as "rfm=udf","rat=cr". */
- ptrb = local_form;
- for (i = 0; *ptrb; i++)
- {
- ptrb = strchr (ptrb, '"');
- ptre = strchr (ptrb + 1, '"');
- *ptre = 0;
- arg_list [i + 4] = (unsigned long long) (ptrb + 1);
- ptrb = ptre + 1;
- }
- arg_list [0] = i + 3;
- /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
- always a 32bit pointer. */
- return LIB$CALLG_64 (arg_list, &decc$freopen);
- }
#else
return freopen (path, mode, stream);
#endif
if (fmode)
o_fmode = O_TEXT;
-#if defined (VMS)
- /* Optional arguments mbc,deq,fop increase read performance. */
- fd = open (path, O_RDONLY | o_fmode, 0444,
- "mbc=16", "deq=64", "fop=tef");
-#elif defined (__vxworks)
+#if defined (__vxworks)
fd = open (path, O_RDONLY | o_fmode, 0444);
#elif defined (__MINGW32__)
{
#if defined (__MINGW32__)
#define PERM (S_IREAD | S_IWRITE)
-#elif defined (VMS)
-/* Excerpt from DECC C RTL Reference Manual:
- To create files with OpenVMS RMS default protections using the UNIX
- system-call functions umask, mkdir, creat, and open, call mkdir, creat,
- and open with a file-protection mode argument of 0777 in a program
- that never specifically calls umask. These default protections include
- correctly establishing protections based on ACLs, previous versions of
- files, and so on. */
-#define PERM 0777
#else
#define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
#endif
if (fmode)
o_fmode = O_TEXT;
-#if defined (VMS)
- fd = open (path, O_RDWR | o_fmode, PERM,
- "mbc=16", "deq=64", "fop=tef");
-#elif defined (__MINGW32__)
+#if defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
if (fmode)
o_fmode = O_TEXT;
-#if defined (VMS)
- fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM,
- "mbc=16", "deq=64", "fop=tef");
-#elif defined (__MINGW32__)
+#if defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
__gnat_create_output_file (char *path)
{
int fd;
-#if defined (VMS)
- 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__)
+#if defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
__gnat_create_output_file_new (char *path)
{
int fd;
-#if defined (VMS)
- fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM,
- "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
- "shr=del,get,put,upd");
-#elif defined (__MINGW32__)
+#if defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
if (fmode)
o_fmode = O_TEXT;
-#if defined (VMS)
- fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM,
- "mbc=16", "deq=64", "fop=tef");
-#elif defined (__MINGW32__)
+#if defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
if (fmode)
o_fmode = O_TEXT;
-#if defined (VMS)
- fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
- "mbc=16", "deq=64", "fop=tef");
-#elif defined (__MINGW32__)
+#if defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
return fd < 0 ? -1 : fd;
}
-/* Open a new temp file. Return error (-1) if the file already exists.
- Special options for VMS allow the file to be shared between parent and child
- processes, however they really slow down output. Used in gnatchop. */
+/* Open a new temp file. Return error (-1) if the file already exists. */
int
__gnat_open_new_temp (char *path, int fmode)
if (fmode)
o_fmode = O_TEXT;
-#if defined (VMS)
- /* Passing rfm=stmlf for binary files seems questionable since it results
- in having an extraneous line feed added after every call to CRTL write,
- so pass rfm=udf (aka undefined) instead. */
- fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM,
- fmode ? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none",
- "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef");
-#else
fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM);
-#endif
-
return fd < 0 ? -1 : fd;
}
{
int fd;
-#if defined (VMS)
- fd = open (path, fmode, PERM, "mbc=16", "deq=64", "fop=tef");
-#elif defined (__MINGW32__)
+#if defined (__MINGW32__)
{
TCHAR wpath[GNAT_MAX_PATH_LEN];
if (ret != 0) {
attr->timestamp = (OS_Time)-1;
} else {
-#ifdef VMS
- /* VMS has file versioning. */
- attr->timestamp = (OS_Time)statbuf.st_ctime;
-#else
attr->timestamp = (OS_Time)statbuf.st_mtime;
-#endif
}
}
CloseHandle (h);
return;
-#elif defined (VMS)
- struct FAB fab;
- struct NAM nam;
-
- struct
- {
- unsigned long long backup, create, expire, revise;
- unsigned int uic;
- union
- {
- unsigned short value;
- struct
- {
- unsigned system : 4;
- unsigned owner : 4;
- unsigned group : 4;
- unsigned world : 4;
- } bits;
- } prot;
- } Fat = { 0, 0, 0, 0, 0, { 0 }};
-
- ATRDEF atrlst[]
- = {
- { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create },
- { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise },
- { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire },
- { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup },
- { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot },
- { ATR$S_UIC, ATR$C_UIC, &Fat.uic },
- { 0, 0, 0}
- };
-
- FIBDEF fib;
- struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib};
-
- struct IOSB iosb;
-
- unsigned long long newtime;
- unsigned long long revtime;
- long status;
- short chan;
-
- struct vstring file;
- struct dsc$descriptor_s filedsc
- = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string};
- struct vstring device;
- struct dsc$descriptor_s devicedsc
- = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string};
- struct vstring timev;
- struct dsc$descriptor_s timedsc
- = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string};
- struct vstring result;
- struct dsc$descriptor_s resultdsc
- = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string};
-
- /* 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;
- nam = cc$rms_nam;
-
- nam.nam$l_esa = file.string;
- nam.nam$b_ess = NAM$C_MAXRSS;
- nam.nam$l_rsa = result.string;
- nam.nam$b_rss = NAM$C_MAXRSS;
- fab.fab$l_fna = tryfile;
- fab.fab$b_fns = strlen (tryfile);
- fab.fab$l_nam = &nam;
-
- /* Validate filespec syntax and device existence. */
- status = SYS$PARSE (&fab, 0, 0);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
-
- file.string[nam.nam$b_esl] = 0;
-
- /* Find matching filespec. */
- status = SYS$SEARCH (&fab, 0, 0);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
-
- file.string[nam.nam$b_esl] = 0;
- result.string[result.length=nam.nam$b_rsl] = 0;
-
- /* Get the device name and assign an IO channel. */
- strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev);
- devicedsc.dsc$w_length = nam.nam$b_dev;
- chan = 0;
- status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
-
- /* Initialize the FIB and fill in the directory id field. */
- memset (&fib, 0, sizeof (fib));
- fib.fib$w_did[0] = nam.nam$w_did[0];
- fib.fib$w_did[1] = nam.nam$w_did[1];
- fib.fib$w_did[2] = nam.nam$w_did[2];
- fib.fib$l_acctl = 0;
- fib.fib$l_wcc = 0;
- strcpy (file.string, (strrchr (result.string, ']') + 1));
- filedsc.dsc$w_length = strlen (file.string);
- result.string[result.length = 0] = 0;
-
- /* Open and close the file to fill in the attributes. */
- status
- = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
- &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
- if ((iosb.status & 1) != 1)
- LIB$SIGNAL (iosb.status);
-
- result.string[result.length] = 0;
- status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0,
- &atrlst, 0);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
- if ((iosb.status & 1) != 1)
- LIB$SIGNAL (iosb.status);
-
- {
- time_t t;
-
- /* Set creation time to requested time. */
- unix_time_to_vms (time_stamp, newtime);
-
- t = time ((time_t) 0);
-
- /* Set revision time to now in local time. */
- unix_time_to_vms (t, revtime);
- }
-
- /* Reopen the file, modify the times and then close. */
- fib.fib$l_acctl = FIB$M_WRITE;
- status
- = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0,
- &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
- if ((iosb.status & 1) != 1)
- LIB$SIGNAL (iosb.status);
-
- Fat.create = newtime;
- Fat.revise = revtime;
-
- status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0,
- &fibdsc, 0, 0, 0, &atrlst, 0);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
- if ((iosb.status & 1) != 1)
- LIB$SIGNAL (iosb.status);
-
- /* Deassign the channel and exit. */
- status = SYS$DASSGN (chan);
- if ((status & 1) != 1)
- LIB$SIGNAL (status);
#else
struct utimbuf utimbuf;
time_t t;
{
/* The child. */
if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
-#if defined (VMS)
- return -1; /* execv is in parent context on VMS. */
-#else
_exit (1);
-#endif
}
/* The parent. */
GetSystemInfo (&sysinfo);
cores = (int) sysinfo.dwNumberOfProcessors;
-#elif defined (VMS)
- int code = SYI$_ACTIVECPU_CNT;
- unsigned int res;
- int status;
-
- status = LIB$GETSYI (&code, &res);
- if ((status & 1) != 0)
- cores = res;
-
#elif defined (_WRS_CONFIG_SMP)
unsigned int vxCpuConfiguredGet (void);
{
/* The child. */
if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
-#if defined (VMS)
- return -1; /* execv is in parent context on VMS. */
-#else
_exit (1);
-#endif
}
return pid;
WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE);
return __gnat_locate_exec (exec_name, apath_val);
-#else
-
-#ifdef VMS
- char *path_val = "/VAXC$PATH";
#else
char *path_val = getenv ("PATH");
-#endif
+
if (path_val == NULL) return NULL;
apath_val = (char *) alloca (strlen (path_val) + 1);
strcpy (apath_val, path_val);
#endif
}
-#ifdef VMS
-
-/* These functions are used to translate to and from VMS and Unix syntax
- file, directory and path specifications. */
-
-#define MAXPATH 256
-#define MAXNAMES 256
-#define NEW_CANONICAL_FILELIST_INCREMENT 64
-
-static char new_canonical_dirspec [MAXPATH];
-static char new_canonical_filespec [MAXPATH];
-static char new_canonical_pathspec [MAXNAMES*MAXPATH];
-static unsigned new_canonical_filelist_index;
-static unsigned new_canonical_filelist_in_use;
-static unsigned new_canonical_filelist_allocated;
-static char **new_canonical_filelist;
-static char new_host_pathspec [MAXNAMES*MAXPATH];
-static char new_host_dirspec [MAXPATH];
-static char new_host_filespec [MAXPATH];
-
-/* Routine is called repeatedly by decc$from_vms via
- __gnat_to_canonical_file_list_init until it returns 0 or the expansion
- runs out. */
-
-static int
-wildcard_translate_unix (char *name)
-{
- char *ver;
- char buff [MAXPATH];
-
- strncpy (buff, name, MAXPATH);
- buff [MAXPATH - 1] = (char) 0;
- ver = strrchr (buff, '.');
-
- /* Chop off the version. */
- if (ver)
- *ver = 0;
-
- /* Dynamically extend the allocation by the increment. */
- if (new_canonical_filelist_in_use == new_canonical_filelist_allocated)
- {
- new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT;
- new_canonical_filelist = (char **) xrealloc
- (new_canonical_filelist,
- new_canonical_filelist_allocated * sizeof (char *));
- }
-
- new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff);
-
- return 1;
-}
-
-/* Translate a wildcard VMS file spec into a list of Unix file specs. First do
- full translation and copy the results into a list (_init), then return them
- one at a time (_next). If onlydirs set, only expand directory files. */
-
-int
-__gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
-{
- int len;
- char buff [MAXPATH];
-
- len = strlen (filespec);
- strncpy (buff, filespec, MAXPATH);
-
- /* Only look for directories */
- if (onlydirs && !strstr (&buff [len-5], "*.dir"))
- strncat (buff, "*.dir", MAXPATH);
-
- buff [MAXPATH - 1] = (char) 0;
-
- decc$from_vms (buff, wildcard_translate_unix, 1);
-
- /* Remove the .dir extension. */
- if (onlydirs)
- {
- int i;
- char *ext;
-
- for (i = 0; i < new_canonical_filelist_in_use; i++)
- {
- ext = strstr (new_canonical_filelist[i], ".dir");
- if (ext)
- *ext = 0;
- }
- }
-
- return new_canonical_filelist_in_use;
-}
-
-/* Return the next filespec in the list. */
-
-char *
-__gnat_to_canonical_file_list_next (void)
-{
- return new_canonical_filelist[new_canonical_filelist_index++];
-}
-
-/* Free storage used in the wildcard expansion. */
-
-void
-__gnat_to_canonical_file_list_free (void)
-{
- int i;
-
- for (i = 0; i < new_canonical_filelist_in_use; i++)
- free (new_canonical_filelist[i]);
-
- free (new_canonical_filelist);
-
- new_canonical_filelist_in_use = 0;
- new_canonical_filelist_allocated = 0;
- new_canonical_filelist_index = 0;
- new_canonical_filelist = 0;
-}
-
-/* The functional equivalent of decc$translate_vms routine.
- Designed to produce the same output, but is protected against
- malformed paths (original version ACCVIOs in this case) and
- does not require VMS-specific DECC RTL. */
-
-#define NAM$C_MAXRSS 1024
-
-char *
-__gnat_translate_vms (char *src)
-{
- static char retbuf [NAM$C_MAXRSS + 1];
- char *srcendpos, *pos1, *pos2, *retpos;
- int disp, path_present = 0;
-
- if (!src)
- return NULL;
-
- srcendpos = strchr (src, '\0');
- retpos = retbuf;
-
- /* Look for the node and/or device in front of the path. */
- pos1 = src;
- pos2 = strchr (pos1, ':');
-
- if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':'))
- {
- /* There is a node name. "node_name::" becomes "node_name!". */
- disp = pos2 - pos1;
- strncpy (retbuf, pos1, disp);
- retpos [disp] = '!';
- retpos = retpos + disp + 1;
- pos1 = pos2 + 2;
- pos2 = strchr (pos1, ':');
- }
-
- if (pos2)
- {
- /* There is a device name. "dev_name:" becomes "/dev_name/". */
- *(retpos++) = '/';
- disp = pos2 - pos1;
- strncpy (retpos, pos1, disp);
- retpos = retpos + disp;
- pos1 = pos2 + 1;
- *(retpos++) = '/';
- }
- else
- /* No explicit device; we must look ahead and prepend /sys$disk/ if
- the path is absolute. */
- if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos)
- && !strchr (".-]>", *(pos1 + 1)))
- {
- strncpy (retpos, "/sys$disk/", 10);
- retpos += 10;
- }
-
- /* Process the path part. */
- while (*pos1 == '[' || *pos1 == '<')
- {
- path_present++;
- pos1++;
- if (*pos1 == ']' || *pos1 == '>')
- {
- /* Special case, [] translates to '.'. */
- *(retpos++) = '.';
- pos1++;
- }
- else
- {
- /* '[000000' means root dir. It can be present in the middle of
- the path due to expansion of logical devices, in which case
- we skip it. */
- if (!strncmp (pos1, "000000", 6) && path_present > 1 &&
- (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.'))
- {
- pos1 += 6;
- if (*pos1 == '.') pos1++;
- }
- else if (*pos1 == '.')
- {
- /* Relative path. */
- *(retpos++) = '.';
- }
-
- /* There is a qualified path. */
- while (*pos1 && *pos1 != ']' && *pos1 != '>')
- {
- switch (*pos1)
- {
- case '.':
- /* '.' is used to separate directories. Replace it with '/'
- but only if there isn't already '/' just before. */
- if (*(retpos - 1) != '/')
- *(retpos++) = '/';
- pos1++;
- if (pos1 + 1 < srcendpos
- && *pos1 == '.'
- && *(pos1 + 1) == '.')
- {
- /* Ellipsis refers to entire subtree; replace
- with '**'. */
- *(retpos++) = '*';
- *(retpos++) = '*';
- *(retpos++) = '/';
- pos1 += 2;
- }
- break;
- case '-' :
- /* When after '.' '[' '<' is equivalent to Unix ".." but
- there may be several in a row. */
- if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' ||
- *(pos1 - 1) == '<')
- {
- while (*pos1 == '-')
- {
- pos1++;
- *(retpos++) = '.';
- *(retpos++) = '.';
- *(retpos++) = '/';
- }
- retpos--;
- break;
- }
- /* Otherwise fall through to default. */
- default:
- *(retpos++) = *(pos1++);
- }
- }
- pos1++;
- }
- }
-
- if (pos1 < srcendpos)
- {
- /* Now add the actual file name, until the version suffix if any */
- if (path_present)
- *(retpos++) = '/';
- pos2 = strchr (pos1, ';');
- disp = pos2? (pos2 - pos1) : (srcendpos - pos1);
- strncpy (retpos, pos1, disp);
- retpos += disp;
- if (pos2 && pos2 < srcendpos)
- {
- /* There is a non-empty version suffix. ";<ver>" becomes ".<ver>" */
- *retpos++ = '.';
- disp = srcendpos - pos2 - 1;
- strncpy (retpos, pos2 + 1, disp);
- retpos += disp;
- }
- }
-
- *retpos = '\0';
-
- return retbuf;
-}
-
-/* Translate a VMS syntax directory specification in to Unix syntax. If
- PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax
- found, return input string. Also translate a dirname that contains no
- slashes, in case it's a logical name. */
-
-char *
-__gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
-{
- int len;
-
- strcpy (new_canonical_dirspec, "");
- if (strlen (dirspec))
- {
- char *dirspec1;
-
- if (strchr (dirspec, ']') || strchr (dirspec, ':'))
- {
- strncpy (new_canonical_dirspec,
- __gnat_translate_vms (dirspec),
- MAXPATH);
- }
- else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
- {
- strncpy (new_canonical_dirspec,
- __gnat_translate_vms (dirspec1),
- MAXPATH);
- }
- else
- {
- strncpy (new_canonical_dirspec, dirspec, MAXPATH);
- }
- }
-
- len = strlen (new_canonical_dirspec);
- if (prefixflag && new_canonical_dirspec [len-1] != '/')
- strncat (new_canonical_dirspec, "/", MAXPATH);
-
- new_canonical_dirspec [MAXPATH - 1] = (char) 0;
-
- return new_canonical_dirspec;
-
-}
-
-/* Translate a VMS syntax file specification into Unix syntax.
- If no indicators of VMS syntax found, check if it's an uppercase
- alphanumeric_ name and if so try it out as an environment
- variable (logical name). If all else fails return the
- input string. */
-
-char *
-__gnat_to_canonical_file_spec (char *filespec)
-{
- char *filespec1;
-
- strncpy (new_canonical_filespec, "", MAXPATH);
-
- if (strchr (filespec, ']') || strchr (filespec, ':'))
- {
- char *tspec = (char *) __gnat_translate_vms (filespec);
-
- if (tspec != (char *) -1)
- strncpy (new_canonical_filespec, tspec, MAXPATH);
- }
- else if ((strlen (filespec) == strspn (filespec,
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_"))
- && (filespec1 = getenv (filespec)))
- {
- char *tspec = (char *) __gnat_translate_vms (filespec1);
-
- if (tspec != (char *) -1)
- strncpy (new_canonical_filespec, tspec, MAXPATH);
- }
- else
- {
- strncpy (new_canonical_filespec, filespec, MAXPATH);
- }
-
- new_canonical_filespec [MAXPATH - 1] = (char) 0;
-
- return new_canonical_filespec;
-}
-
-/* Translate a VMS syntax path specification into Unix syntax.
- If no indicators of VMS syntax found, return input string. */
-
-char *
-__gnat_to_canonical_path_spec (char *pathspec)
-{
- char *curr, *next, buff [MAXPATH];
-
- if (pathspec == 0)
- return pathspec;
-
- /* If there are /'s, assume it's a Unix path spec and return. */
- if (strchr (pathspec, '/'))
- return pathspec;
-
- new_canonical_pathspec[0] = 0;
- curr = pathspec;
-
- for (;;)
- {
- next = strchr (curr, ',');
- if (next == 0)
- next = strchr (curr, 0);
-
- strncpy (buff, curr, next - curr);
- buff[next - curr] = 0;
-
- /* Check for wildcards and expand if present. */
- if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "..."))
- {
- int i, dirs;
-
- dirs = __gnat_to_canonical_file_list_init (buff, 1);
- for (i = 0; i < dirs; i++)
- {
- char *next_dir;
-
- next_dir = __gnat_to_canonical_file_list_next ();
- strncat (new_canonical_pathspec, next_dir, MAXPATH);
-
- /* Don't append the separator after the last expansion. */
- if (i+1 < dirs)
- strncat (new_canonical_pathspec, ":", MAXPATH);
- }
-
- __gnat_to_canonical_file_list_free ();
- }
- else
- strncat (new_canonical_pathspec,
- __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
-
- if (*next == 0)
- break;
-
- strncat (new_canonical_pathspec, ":", MAXPATH);
- curr = next + 1;
- }
-
- new_canonical_pathspec [MAXPATH - 1] = (char) 0;
-
- return new_canonical_pathspec;
-}
-
-static char filename_buff [MAXPATH];
-
-static int
-translate_unix (char *name, int type ATTRIBUTE_UNUSED)
-{
- strncpy (filename_buff, name, MAXPATH);
- filename_buff [MAXPATH - 1] = (char) 0;
- return 0;
-}
-
-/* Translate a Unix syntax directory specification into VMS syntax. The
- PREFIXFLAG has no effect, but is kept for symmetry with
- to_canonical_dir_spec. If indicators of VMS syntax found, return input
- string. */
-
-char *
-__gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
-{
- int len = strlen (dirspec);
-
- strncpy (new_host_dirspec, dirspec, MAXPATH);
- new_host_dirspec [MAXPATH - 1] = (char) 0;
-
- if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
- return new_host_dirspec;
-
- while (len > 1 && new_host_dirspec[len - 1] == '/')
- {
- new_host_dirspec[len - 1] = 0;
- len--;
- }
-
- decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
- strncpy (new_host_dirspec, filename_buff, MAXPATH);
- new_host_dirspec [MAXPATH - 1] = (char) 0;
-
- return new_host_dirspec;
-}
-
-/* Translate a Unix syntax file specification into VMS syntax.
- If indicators of VMS syntax found, return input string. */
-
-char *
-__gnat_to_host_file_spec (char *filespec)
-{
- strncpy (new_host_filespec, "", MAXPATH);
- if (strchr (filespec, ']') || strchr (filespec, ':'))
- {
- strncpy (new_host_filespec, filespec, MAXPATH);
- }
- else
- {
- decc$to_vms (filespec, translate_unix, 1, 1);
- strncpy (new_host_filespec, filename_buff, MAXPATH);
- }
-
- new_host_filespec [MAXPATH - 1] = (char) 0;
-
- return new_host_filespec;
-}
-
-void
-__gnat_adjust_os_resource_limits (void)
-{
- SYS$ADJWSL (131072, 0);
-}
-
-#else /* VMS */
-
-/* Dummy functions for Osint import for non-VMS systems. */
+/* Dummy functions for Osint import for non-VMS systems.
+ ??? To be removed. */
int
__gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED,
{
}
-#endif
-
#if defined (__mips_vxworks)
int
_flush_cache (void)
}
#endif
-#if defined (IS_CROSS) \
- || (! ((defined (sparc) || defined (i386)) && defined (sun) \
- && defined (__SVR4)) \
- && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \
- && ! (defined (linux) && defined (__ia64__)) \
- && ! (defined (linux) && defined (powerpc)) \
- && ! defined (__FreeBSD__) \
- && ! defined (__Lynx__) \
- && ! defined (__hpux__) \
- && ! defined (__APPLE__) \
- && ! defined (_AIX) \
- && ! defined (VMS) \
- && ! defined (__MINGW32__))
-
-/* Dummy function to satisfy g-trasym.o. See the preprocessor conditional
- just above for a list of native platforms that provide a non-dummy
- version of this procedure in libaddr2line.a. */
-
-void
-convert_addresses (const char *file_name ATTRIBUTE_UNUSED,
- void *addrs ATTRIBUTE_UNUSED,
- int n_addr ATTRIBUTE_UNUSED,
- void *buf ATTRIBUTE_UNUSED,
- int *len ATTRIBUTE_UNUSED)
-{
- *len = 0;
-}
-#endif
-
#if defined (_WIN32)
int __gnat_argument_needs_quote = 1;
#else
__gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED,
int mode ATTRIBUTE_UNUSED)
{
-#if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
+#if (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \
defined (__nucleus__)
return -1;
int
__gnat_binder_supports_auto_init (void)
{
-#ifdef VMS
- return 0;
-#else
- return 1;
-#endif
+ return 1;
}
/* Indicates that Stand-Alone Libraries are automatically initialized through
int
__gnat_sals_init_using_constructors (void)
{
-#if defined (__vxworks) || defined (__Lynx__) || defined (VMS)
+#if defined (__vxworks) || defined (__Lynx__)
return 0;
#else
return 1;
ada/sem_smem.o \
ada/sem_type.o \
ada/sem_util.o \
- ada/sem_vfpt.o \
ada/sem_warn.o \
ada/set_targ.o \
ada/sinfo-cn.o \
g-soliop.ads<g-soliop-mingw.ads \
$(ATOMICS_TARGET_PAIRS)
- ifeq ($(strip $(filter-out rtx_w32 rtx_rtss,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS += \
- s-intman.adb<s-intman-dummy.adb \
- s-osinte.ads<s-osinte-rtx.ads \
- s-osprim.adb<s-osprim-rtx.adb \
- s-taprop.adb<s-taprop-rtx.adb \
- $(X86_TARGET_PAIRS)
-
- EXTRA_GNATRTL_NONTASKING_OBJS = s-win32.o
-
- ifeq ($(strip $(filter-out rtx_w32,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS += system.ads<system-rtx.ads
+ LIBGNAT_TARGET_PAIRS += \
+ a-exetim.adb<a-exetim-mingw.adb \
+ a-exetim.ads<a-exetim-mingw.ads \
+ a-intnam.ads<a-intnam-mingw.ads \
+ g-sercom.adb<g-sercom-mingw.adb \
+ s-trasym.adb<s-trasym-dwarf.adb \
+ s-tsmona.adb<s-tsmona-mingw.adb \
+ s-interr.adb<s-interr-sigaction.adb \
+ s-intman.adb<s-intman-mingw.adb \
+ s-mudido.adb<s-mudido-affinity.adb \
+ s-osinte.ads<s-osinte-mingw.ads \
+ s-osprim.adb<s-osprim-mingw.adb \
+ s-taprop.adb<s-taprop-mingw.adb
- EH_MECHANISM=-gcc
+ ifeq ($(strip $(filter-out x86_64%,$(target_cpu))),)
+ ifeq ($(strip $(MULTISUBDIR)),/32)
+ LIBGNAT_TARGET_PAIRS += \
+ $(X86_TARGET_PAIRS) \
+ system.ads<system-mingw.ads
+ SO_OPTS= -m32 -Wl,-soname,
else
- LIBGNAT_TARGET_PAIRS += \
- system.ads<system-rtx-rtss.ads \
- s-parame.adb<s-parame-vxworks.adb
-
- EH_MECHANISM=
+ LIBGNAT_TARGET_PAIRS += \
+ $(X86_64_TARGET_PAIRS) \
+ system.ads<system-mingw-x86_64.ads
+ SO_OPTS = -m64 -Wl,-soname,
endif
-
else
LIBGNAT_TARGET_PAIRS += \
a-exetim.adb<a-exetim-mingw.adb \
SO_OPTS = -m64 -Wl,-soname,
endif
else
- ifeq ($(strip $(MULTISUBDIR)),/64)
- LIBGNAT_TARGET_PAIRS += \
- $(X86_64_TARGET_PAIRS) \
- system.ads<system-mingw-x86_64.ads
- SO_OPTS = -m64 -Wl,-soname,
- else
- LIBGNAT_TARGET_PAIRS += \
- $(X86_TARGET_PAIRS) \
- system.ads<system-mingw.ads
- SO_OPTS = -m32 -Wl,-soname,
- endif
+ LIBGNAT_TARGET_PAIRS += \
+ $(X86_TARGET_PAIRS) \
+ system.ads<system-mingw.ads
+ SO_OPTS = -m32 -Wl,-soname,
endif
+ endif
- EXTRA_GNATRTL_NONTASKING_OBJS = \
- s-win32.o s-winext.o g-regist.o g-sse.o g-ssvety.o
- EXTRA_GNATRTL_TASKING_OBJS = a-exetim.o
- EXTRA_LIBGNAT_SRCS+=mingw32.h
- MISCLIB = -lws2_32
+ EXTRA_GNATRTL_NONTASKING_OBJS = \
+ s-win32.o s-winext.o g-regist.o g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_TASKING_OBJS = a-exetim.o
+ EXTRA_LIBGNAT_SRCS+=mingw32.h
+ MISCLIB = -lws2_32
- # ??? This will be replaced by gnatlib-shared-dual-win32 when GNAT
- # auto-import support for array/record will be done.
- GNATLIB_SHARED = gnatlib-shared-win32
+ # ??? This will be replaced by gnatlib-shared-dual-win32 when GNAT
+ # auto-import support for array/record will be done.
+ GNATLIB_SHARED = gnatlib-shared-win32
- EH_MECHANISM=-gcc
- endif
+ EH_MECHANISM=-gcc
TOOLS_TARGET_PAIRS= \
mlib-tgt-specific.adb<mlib-tgt-specific-mingw.adb \
s-bbthre.ads s-bbtiev.adb s-bbtiev.ads s-bbtime.adb s-bbtime.ads \
s-bcprmu.adb s-bcprmu.ads s-btstch.adb s-btstch.ads \
s-init.ads s-init.adb \
- s-po32gl.adb s-po32gl.ads \
s-stache.adb s-stache.ads \
s-thread.ads \
s-vxwext.adb s-vxwext.ads \
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
-# force debugging information on s-vaflop.o so that it is always
-# possible to call the VAX float debug print routines.
-# force at least -O so that the inline assembly works.
-
-s-vaflop.o : s-vaflop.adb s-vaflop.ads
- $(CC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \
- $< $(OUTPUT_OPTION)
-
# force no function reordering on a-except.o because of the exclusion bounds
# mechanism (see the source file for more detailed information).
# force debugging information on a-except.o so that it is always
break;
case E_Floating_Point_Type:
- /* If this is a VAX floating-point type, use an integer of the proper
- size. All the operations will be handled with ASM statements. */
- if (Vax_Float (gnat_entity))
- {
- gnu_type = make_signed_type (esize);
- TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
- SET_TYPE_DIGITS_VALUE (gnu_type,
- UI_To_gnu (Digits_Value (gnat_entity),
- sizetype));
- break;
- }
-
/* The type of the Low and High bounds can be our type if this is
a type from Standard, so set them at the end of the function. */
gnu_type = make_node (REAL_TYPE);
break;
case E_Floating_Point_Subtype:
- if (Vax_Float (gnat_entity))
- {
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
- break;
- }
-
/* See the E_Signed_Integer_Subtype case for the rationale. */
if (!definition
&& Present (Ancestor_Subtype (gnat_entity))
/* If this is an enumeration or floating-point type, we were not able to set
the bounds since they refer to the type. These are always static. */
if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
- || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
+ || (kind == E_Floating_Point_Type))
{
tree gnu_scalar_type = gnu_type;
tree gnu_low_bound, gnu_high_bound;
@end smallexample
@noindent
-This pragma provides a string identification in the generated object file,
-if the system supports the concept of this kind of identification string.
-This pragma is allowed only in the outermost declarative part or
-declarative items of a compilation unit. If more than one @code{Ident}
-pragma is given, only the last one processed is effective.
-@cindex OpenVMS
-On OpenVMS systems, the effect of the pragma is identical to the effect of
-the DEC Ada 83 pragma of the same name. Note that in DEC Ada 83, the
-maximum allowed length is 31 characters, so if it is important to
-maintain compatibility with this compiler, you should obey this length
-limit.
+This pragma is identical in effect to pragma @code{Comment}. It is provided
+for compatibility with other Ada compilers providing this pragma.
@node Pragma Implementation_Defined
@unnumberedsec Pragma Implementation_Defined
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUNT-TIME COMPONENTS --
--- --
--- S Y S T E M . A S T _ H A N D L I N G --
--- --
--- B o d y --
--- --
--- Copyright (C) 1996-2009, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the dummy version used on non-VMS systems
-
-package body System.AST_Handling is
-
- ------------------------
- -- Create_AST_Handler --
- ------------------------
-
- function Create_AST_Handler
- (Taskid : Ada.Task_Identification.Task_Id;
- Entryno : Natural) return System.Aux_DEC.AST_Handler
- is
- begin
- raise Program_Error with "AST is implemented only on VMS systems";
- return System.Aux_DEC.No_AST_Handler;
- end Create_AST_Handler;
-
- procedure Expand_AST_Packet_Pool
- (Requested_Packets : Natural;
- Actual_Number : out Natural;
- Total_Number : out Natural)
- is
- begin
- raise Program_Error with "AST is implemented only on VMS systems";
- end Expand_AST_Packet_Pool;
-
-end System.AST_Handling;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . A S T _ H A N D L I N G --
--- --
--- S p e c --
--- --
--- Copyright (C) 1996-2009, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Runtime support for Handling of AST's (Used on VMS implementations only)
-
-with Ada.Task_Identification;
-with System;
-with System.Aux_DEC;
-
-package System.AST_Handling is
-
- function Create_AST_Handler
- (Taskid : Ada.Task_Identification.Task_Id;
- Entryno : Natural) return System.Aux_DEC.AST_Handler;
- -- This function implements the appropriate semantics for a use of the
- -- AST_Entry pragma. See body for details of implementation approach.
- -- The parameters are the Task_Id for the task containing the entry
- -- and the entry Index for the specified entry.
-
- procedure Expand_AST_Packet_Pool
- (Requested_Packets : Natural;
- Actual_Number : out Natural;
- Total_Number : out Natural);
- -- This function takes a request for zero or more extra AST packets and
- -- returns the number actually added to the pool and the total number
- -- now available or in use.
- -- This function is not yet fully implemented.
-
-end System.AST_Handling;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . F A T _ I E E E _ L O N G _ F L O A T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2014, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains an instantiation of the floating-point attribute
--- runtime routines for IEEE long float. This is used on VMS targets where
--- we can't just use Long_Float, since this may have been mapped to Vax_Float
--- using a Float_Representation configuration pragma.
-
--- TO BE RMOVED ???
-
-with System.Fat_Gen;
-
-package System.Fat_IEEE_Long_Float is
- pragma Pure;
-
- type Fat_IEEE_Long is digits 15;
-
- -- Note the only entity from this package that is accessed by Rtsfind
- -- is the name of the package instantiation. Entities within this package
- -- (i.e. the individual floating-point attribute routines) are accessed
- -- by name using selected notation.
-
- package Attr_IEEE_Long is new System.Fat_Gen (Fat_IEEE_Long);
-
-end System.Fat_IEEE_Long_Float;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . F A T _ I E E E _ S H O R T _ F L O A T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2014, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains an instantiation of the floating-point attribute
--- runtime routines for IEEE short float. This is used on VMS targets where
--- we can't just use Float, since this may have been mapped to Vax_Float
--- using a Float_Representation configuration pragma.
-
--- TO BE REMOVED ???
-
-with System.Fat_Gen;
-
-package System.Fat_IEEE_Short_Float is
- pragma Pure;
-
- type Fat_IEEE_Short is digits 6;
-
- -- Note the only entity from this package that is accessed by Rtsfind
- -- is the name of the package instantiation. Entities within this package
- -- (i.e. the individual floating-point attribute routines) are accessed
- -- by name using selected notation.
-
- package Attr_IEEE_Short is new System.Fat_Gen (Fat_IEEE_Short);
-
-end System.Fat_IEEE_Short_Float;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . F A T _ V A X _ D _ F L O A T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2014, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains an instantiation of the floating-point attribute
--- runtime routines for VAX D-float for use on VMS targets.
-
--- TO BE REMOVED ???
-
-with System.Fat_Gen;
-
-package System.Fat_VAX_D_Float is
- pragma Pure;
-
- type Fat_VAX_D is digits 9;
-
- -- Note the only entity from this package that is accessed by Rtsfind
- -- is the name of the package instantiation. Entities within this package
- -- (i.e. the individual floating-point attribute routines) are accessed
- -- by name using selected notation.
-
- package Attr_VAX_D_Float is new System.Fat_Gen (Fat_VAX_D);
-
-end System.Fat_VAX_D_Float;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . F A T _ V A X _ F _ F L O A T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2014, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains an instantiation of the floating-point attribute
--- runtime routines for VAX F-float for use on VMS targets.
-
--- TO BE REMOVED ???
-
-with System.Fat_Gen;
-
-package System.Fat_VAX_F_Float is
- pragma Pure;
-
- type Fat_VAX_F is digits 6;
-
- -- Note the only entity from this package that is accessed by Rtsfind
- -- is the name of the package instantiation. Entities within this package
- -- (i.e. the individual floating-point attribute routines) are accessed
- -- by name using selected notation.
-
- package Attr_VAX_F_Float is new System.Fat_Gen (Fat_VAX_F);
-
-end System.Fat_VAX_F_Float;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . F A T _ V A X _ G _ F L O A T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2014, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains an instantiation of the floating-point attribute
--- runtime routines for VAX F-float for use on VMS targets.
-
--- TO BE REMOVED ???
-
-with System.Fat_Gen;
-
-package System.Fat_VAX_G_Float is
- pragma Pure;
-
- type Fat_VAX_G is digits 15;
-
- -- Note the only entity from this package that is accessed by Rtsfind
- -- is the name of the package instantiation. Entities within this package
- -- (i.e. the individual floating-point attribute routines) are accessed
- -- by name using selected notation.
-
- package Attr_VAX_G_Float is new System.Fat_Gen (Fat_VAX_G);
-
-end System.Fat_VAX_G_Float;
-- to the current position (origin = SEEK_CUR), end of file (origin =
-- SEEK_END), or start of file (origin = SEEK_SET).
- type File_Size is range -(2 ** 63) .. (2 ** 63) - 1;
+ type Large_File_Size is range -(2 ** 63) .. (2 ** 63) - 1;
function File_Length (FD : File_Descriptor) return Long_Integer;
pragma Import (C, File_Length, "__gnat_file_length_long");
- function File_Length64 (FD : File_Descriptor) return File_Size;
+ function File_Length64 (FD : File_Descriptor) return Large_File_Size;
pragma Import (C, File_Length64, "__gnat_file_length");
-- Get length of file from file descriptor FD
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P O O L _ 3 2 _ G L O B A L --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2011, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with System.Storage_Pools; use System.Storage_Pools;
-with System.Memory;
-
-package body System.Pool_32_Global is
-
- package SSE renames System.Storage_Elements;
-
- --------------
- -- Allocate --
- --------------
-
- overriding procedure Allocate
- (Pool : in out Unbounded_No_Reclaim_Pool_32;
- Address : out System.Address;
- Storage_Size : SSE.Storage_Count;
- Alignment : SSE.Storage_Count)
- is
- pragma Warnings (Off, Pool);
- pragma Warnings (Off, Alignment);
-
- begin
- Address := Memory.Alloc32 (Memory.size_t (Storage_Size));
-
- -- The call to Alloc returns an address whose alignment is compatible
- -- with the worst case alignment requirement for the machine; thus the
- -- Alignment argument can be safely ignored.
-
- if Address = Null_Address then
- raise Storage_Error;
- end if;
- end Allocate;
-
- ----------------
- -- Deallocate --
- ----------------
-
- overriding procedure Deallocate
- (Pool : in out Unbounded_No_Reclaim_Pool_32;
- Address : System.Address;
- Storage_Size : SSE.Storage_Count;
- Alignment : SSE.Storage_Count)
- is
- pragma Warnings (Off, Pool);
- pragma Warnings (Off, Storage_Size);
- pragma Warnings (Off, Alignment);
-
- begin
- Memory.Free (Address);
- end Deallocate;
-
- ------------------
- -- Storage_Size --
- ------------------
-
- overriding function Storage_Size
- (Pool : Unbounded_No_Reclaim_Pool_32)
- return SSE.Storage_Count
- is
- pragma Warnings (Off, Pool);
-
- begin
- -- The 32 bit heap is limited to 2 GB of memory
-
- return SSE.Storage_Count (2 ** 31);
- end Storage_Size;
-
-end System.Pool_32_Global;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P O O L _ 3 2 _ G L O B A L --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2011, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Storage pool corresponding to default global storage pool used for types
--- designated by a 32 bits access type for which no storage pool is specified.
--- This is specific to VMS.
-
-with System;
-with System.Storage_Pools;
-with System.Storage_Elements;
-
-package System.Pool_32_Global is
- pragma Elaborate_Body;
- -- Needed to ensure that library routines can execute allocators
-
- -- Allocation strategy:
-
- -- Call to malloc/free for each Allocate/Deallocate
- -- No user specifiable size
- -- No automatic reclaim
- -- Minimal overhead
-
- -- Pool simulating the allocation/deallocation strategy used by the
- -- compiler for access types globally declared.
-
- type Unbounded_No_Reclaim_Pool_32 is new
- System.Storage_Pools.Root_Storage_Pool with null record;
-
- overriding function Storage_Size
- (Pool : Unbounded_No_Reclaim_Pool_32)
- return System.Storage_Elements.Storage_Count;
-
- overriding procedure Allocate
- (Pool : in out Unbounded_No_Reclaim_Pool_32;
- Address : out System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count);
-
- overriding procedure Deallocate
- (Pool : in out Unbounded_No_Reclaim_Pool_32;
- Address : System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count);
-
- -- Pool object used by the compiler when implicit Storage Pool objects are
- -- explicitly referred to. For instance when writing something like:
- -- for T'Storage_Pool use Q'Storage_Pool;
- -- and Q'Storage_Pool hasn't been defined explicitly.
-
- Global_Pool_32_Object : Unbounded_No_Reclaim_Pool_32;
-
-end System.Pool_32_Global;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2014, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a dummy body for use on non-Alpha systems so that the library
--- can compile. This dummy version uses ordinary conversions and other
--- arithmetic operations. It is used only for testing purposes in the
--- case where the -gnatdm switch is used to force testing of VMS features
--- on non-VMS systems.
-
-with System.IO;
-
-package body System.Vax_Float_Operations is
- pragma Warnings (Off);
- -- Warnings about infinite recursion when the -gnatdm switch is used
-
- -----------
- -- Abs_F --
- -----------
-
- function Abs_F (X : F) return F is
- begin
- return abs X;
- end Abs_F;
-
- -----------
- -- Abs_G --
- -----------
-
- function Abs_G (X : G) return G is
- begin
- return abs X;
- end Abs_G;
-
- -----------
- -- Add_F --
- -----------
-
- function Add_F (X, Y : F) return F is
- begin
- return X + Y;
- end Add_F;
-
- -----------
- -- Add_G --
- -----------
-
- function Add_G (X, Y : G) return G is
- begin
- return X + Y;
- end Add_G;
-
- ------------
- -- D_To_G --
- ------------
-
- function D_To_G (X : D) return G is
- begin
- return G (X);
- end D_To_G;
-
- --------------------
- -- Debug_Output_D --
- --------------------
-
- procedure Debug_Output_D (Arg : D) is
- begin
- System.IO.Put (D'Image (Arg));
- end Debug_Output_D;
-
- --------------------
- -- Debug_Output_F --
- --------------------
-
- procedure Debug_Output_F (Arg : F) is
- begin
- System.IO.Put (F'Image (Arg));
- end Debug_Output_F;
-
- --------------------
- -- Debug_Output_G --
- --------------------
-
- procedure Debug_Output_G (Arg : G) is
- begin
- System.IO.Put (G'Image (Arg));
- end Debug_Output_G;
-
- --------------------
- -- Debug_String_D --
- --------------------
-
- Debug_String_Buffer : String (1 .. 32);
- -- Buffer used by all Debug_String_x routines for returning result
-
- function Debug_String_D (Arg : D) return System.Address is
- Image_String : constant String := D'Image (Arg) & ASCII.NUL;
- Image_Size : constant Integer := Image_String'Length;
-
- begin
- Debug_String_Buffer (1 .. Image_Size) := Image_String;
- return Debug_String_Buffer (1)'Address;
- end Debug_String_D;
-
- --------------------
- -- Debug_String_F --
- --------------------
-
- function Debug_String_F (Arg : F) return System.Address is
- Image_String : constant String := F'Image (Arg) & ASCII.NUL;
- Image_Size : constant Integer := Image_String'Length;
-
- begin
- Debug_String_Buffer (1 .. Image_Size) := Image_String;
- return Debug_String_Buffer (1)'Address;
- end Debug_String_F;
-
- --------------------
- -- Debug_String_G --
- --------------------
-
- function Debug_String_G (Arg : G) return System.Address is
- Image_String : constant String := G'Image (Arg) & ASCII.NUL;
- Image_Size : constant Integer := Image_String'Length;
-
- begin
- Debug_String_Buffer (1 .. Image_Size) := Image_String;
- return Debug_String_Buffer (1)'Address;
- end Debug_String_G;
-
- -----------
- -- Div_F --
- -----------
-
- function Div_F (X, Y : F) return F is
- begin
- return X / Y;
- end Div_F;
-
- -----------
- -- Div_G --
- -----------
-
- function Div_G (X, Y : G) return G is
- begin
- return X / Y;
- end Div_G;
-
- ----------
- -- Eq_F --
- ----------
-
- function Eq_F (X, Y : F) return Boolean is
- begin
- return X = Y;
- end Eq_F;
-
- ----------
- -- Eq_G --
- ----------
-
- function Eq_G (X, Y : G) return Boolean is
- begin
- return X = Y;
- end Eq_G;
-
- ------------
- -- F_To_G --
- ------------
-
- function F_To_G (X : F) return G is
- begin
- return G (X);
- end F_To_G;
-
- ------------
- -- F_To_Q --
- ------------
-
- function F_To_Q (X : F) return Q is
- begin
- return Q (X);
- end F_To_Q;
-
- ------------
- -- F_To_S --
- ------------
-
- function F_To_S (X : F) return S is
- begin
- return S (X);
- end F_To_S;
-
- ------------
- -- G_To_D --
- ------------
-
- function G_To_D (X : G) return D is
- begin
- return D (X);
- end G_To_D;
-
- ------------
- -- G_To_F --
- ------------
-
- function G_To_F (X : G) return F is
- begin
- return F (X);
- end G_To_F;
-
- ------------
- -- G_To_Q --
- ------------
-
- function G_To_Q (X : G) return Q is
- begin
- return Q (X);
- end G_To_Q;
-
- ------------
- -- G_To_T --
- ------------
-
- function G_To_T (X : G) return T is
- begin
- return T (X);
- end G_To_T;
-
- ----------
- -- Le_F --
- ----------
-
- function Le_F (X, Y : F) return Boolean is
- begin
- return X <= Y;
- end Le_F;
-
- ----------
- -- Le_G --
- ----------
-
- function Le_G (X, Y : G) return Boolean is
- begin
- return X <= Y;
- end Le_G;
-
- ----------
- -- Lt_F --
- ----------
-
- function Lt_F (X, Y : F) return Boolean is
- begin
- return X < Y;
- end Lt_F;
-
- ----------
- -- Lt_G --
- ----------
-
- function Lt_G (X, Y : G) return Boolean is
- begin
- return X < Y;
- end Lt_G;
-
- -----------
- -- Mul_F --
- -----------
-
- function Mul_F (X, Y : F) return F is
- begin
- return X * Y;
- end Mul_F;
-
- -----------
- -- Mul_G --
- -----------
-
- function Mul_G (X, Y : G) return G is
- begin
- return X * Y;
- end Mul_G;
-
- ----------
- -- Ne_F --
- ----------
-
- function Ne_F (X, Y : F) return Boolean is
- begin
- return X /= Y;
- end Ne_F;
-
- ----------
- -- Ne_G --
- ----------
-
- function Ne_G (X, Y : G) return Boolean is
- begin
- return X /= Y;
- end Ne_G;
-
- -----------
- -- Neg_F --
- -----------
-
- function Neg_F (X : F) return F is
- begin
- return -X;
- end Neg_F;
-
- -----------
- -- Neg_G --
- -----------
-
- function Neg_G (X : G) return G is
- begin
- return -X;
- end Neg_G;
-
- --------
- -- pd --
- --------
-
- procedure pd (Arg : D) is
- begin
- System.IO.Put_Line (D'Image (Arg));
- end pd;
-
- --------
- -- pf --
- --------
-
- procedure pf (Arg : F) is
- begin
- System.IO.Put_Line (F'Image (Arg));
- end pf;
-
- --------
- -- pg --
- --------
-
- procedure pg (Arg : G) is
- begin
- System.IO.Put_Line (G'Image (Arg));
- end pg;
-
- ------------
- -- Q_To_F --
- ------------
-
- function Q_To_F (X : Q) return F is
- begin
- return F (X);
- end Q_To_F;
-
- ------------
- -- Q_To_G --
- ------------
-
- function Q_To_G (X : Q) return G is
- begin
- return G (X);
- end Q_To_G;
-
- ------------
- -- S_To_F --
- ------------
-
- function S_To_F (X : S) return F is
- begin
- return F (X);
- end S_To_F;
-
- --------------
- -- Return_D --
- --------------
-
- function Return_D (X : D) return D is
- begin
- return X;
- end Return_D;
-
- --------------
- -- Return_F --
- --------------
-
- function Return_F (X : F) return F is
- begin
- return X;
- end Return_F;
-
- --------------
- -- Return_G --
- --------------
-
- function Return_G (X : G) return G is
- begin
- return X;
- end Return_G;
-
- -----------
- -- Sub_F --
- -----------
-
- function Sub_F (X, Y : F) return F is
- begin
- return X - Y;
- end Sub_F;
-
- -----------
- -- Sub_G --
- -----------
-
- function Sub_G (X, Y : G) return G is
- begin
- return X - Y;
- end Sub_G;
-
- ------------
- -- T_To_G --
- ------------
-
- -- This function must be located before T_To_D for frontend inlining
-
- function T_To_G (X : T) return G is
- begin
- return G (X);
- end T_To_G;
-
- ------------
- -- T_To_D --
- ------------
-
- function T_To_D (X : T) return D is
- begin
- return G_To_D (T_To_G (X));
- end T_To_D;
-
- -------------
- -- Valid_D --
- -------------
-
- -- For now, convert to IEEE and do Valid test on result. This is not quite
- -- accurate, but is good enough in practice.
-
- function Valid_D (Arg : D) return Boolean is
- Val : constant T := G_To_T (D_To_G (Arg));
- begin
- return Val'Valid;
- end Valid_D;
-
- -------------
- -- Valid_F --
- -------------
-
- -- For now, convert to IEEE and do Valid test on result. This is not quite
- -- accurate, but is good enough in practice.
-
- function Valid_F (Arg : F) return Boolean is
- Val : constant S := F_To_S (Arg);
- begin
- return Val'Valid;
- end Valid_F;
-
- -------------
- -- Valid_G --
- -------------
-
- -- For now, convert to IEEE and do Valid test on result. This is not quite
- -- accurate, but is good enough in practice.
-
- function Valid_G (Arg : G) return Boolean is
- Val : constant T := G_To_T (Arg);
- begin
- return Val'Valid;
- end Valid_G;
-
-end System.Vax_Float_Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1997-2014, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains runtime routines for handling the non-IEEE
--- floating-point formats used on the Vax.
-
--- TO BE REMOVED ???
-
-package System.Vax_Float_Operations is
-
- type D is digits 9;
- type G is digits 15;
- type F is digits 6;
- type S is digits 6;
- type T is digits 15;
-
- type Q is range -2 ** 63 .. +(2 ** 63 - 1);
- -- 64-bit signed integer
-
- --------------------------
- -- Conversion Functions --
- --------------------------
-
- function D_To_G (X : D) return G;
- function G_To_D (X : G) return D;
- -- Conversions between D float and G float
-
- function G_To_F (X : G) return F;
- function F_To_G (X : F) return G;
- -- Conversions between F float and G float
-
- function F_To_S (X : F) return S;
- function S_To_F (X : S) return F;
- -- Conversions between F float and IEEE short
-
- function G_To_T (X : G) return T;
- function T_To_G (X : T) return G;
- -- Conversions between G float and IEEE long
-
- function F_To_Q (X : F) return Q;
- function Q_To_F (X : Q) return F;
- -- Conversions between F float and 64-bit integer
-
- function G_To_Q (X : G) return Q;
- function Q_To_G (X : Q) return G;
- -- Conversions between G float and 64-bit integer
-
- function T_To_D (X : T) return D;
- -- Conversion from IEEE long to D_Float (used for literals)
-
- --------------------------
- -- Arithmetic Functions --
- --------------------------
-
- function Abs_F (X : F) return F;
- function Abs_G (X : G) return G;
- -- Absolute value of F/G float
-
- function Add_F (X, Y : F) return F;
- function Add_G (X, Y : G) return G;
- -- Addition of F/G float
-
- function Div_F (X, Y : F) return F;
- function Div_G (X, Y : G) return G;
- -- Division of F/G float
-
- function Mul_F (X, Y : F) return F;
- function Mul_G (X, Y : G) return G;
- -- Multiplication of F/G float
-
- function Neg_F (X : F) return F;
- function Neg_G (X : G) return G;
- -- Negation of F/G float
-
- function Sub_F (X, Y : F) return F;
- function Sub_G (X, Y : G) return G;
- -- Subtraction of F/G float
-
- --------------------------
- -- Comparison Functions --
- --------------------------
-
- function Eq_F (X, Y : F) return Boolean;
- function Eq_G (X, Y : G) return Boolean;
- -- Compares for X = Y
-
- function Le_F (X, Y : F) return Boolean;
- function Le_G (X, Y : G) return Boolean;
- -- Compares for X <= Y
-
- function Lt_F (X, Y : F) return Boolean;
- function Lt_G (X, Y : G) return Boolean;
- -- Compares for X < Y
-
- function Ne_F (X, Y : F) return Boolean;
- function Ne_G (X, Y : G) return Boolean;
- -- Compares for X /= Y
-
- ----------------------
- -- Return Functions --
- ----------------------
-
- function Return_D (X : D) return D;
- function Return_F (X : F) return F;
- function Return_G (X : G) return G;
- -- Deal with returned value for an imported function where the function
- -- result is of VAX Float type. Usually nothing needs to be done, and these
- -- functions return their argument unchanged. But for the case of VMS Alpha
- -- the return value is already in $f0, so we need to trick the compiler
- -- into thinking that we are moving X to $f0. See bodies for this case
- -- for the Asm sequence generated to achieve this.
-
- ----------------------------------
- -- Routines for Valid Attribute --
- ----------------------------------
-
- function Valid_D (Arg : D) return Boolean;
- function Valid_F (Arg : F) return Boolean;
- function Valid_G (Arg : G) return Boolean;
- -- Test whether Arg has a valid representation
-
- ----------------------
- -- Debug Procedures --
- ----------------------
-
- procedure Debug_Output_D (Arg : D);
- procedure Debug_Output_F (Arg : F);
- procedure Debug_Output_G (Arg : G);
- pragma Export (Ada, Debug_Output_D);
- pragma Export (Ada, Debug_Output_F);
- pragma Export (Ada, Debug_Output_G);
- -- These routines output their argument in decimal string form, with
- -- no terminating line return. They are provided for implicit use by
- -- the pre gnat-3.12w GDB, and are retained for backwards compatibility.
-
- function Debug_String_D (Arg : D) return System.Address;
- function Debug_String_F (Arg : F) return System.Address;
- function Debug_String_G (Arg : G) return System.Address;
- pragma Export (Ada, Debug_String_D);
- pragma Export (Ada, Debug_String_F);
- pragma Export (Ada, Debug_String_G);
- -- These routines return a decimal C string image of their argument.
- -- They are provided for implicit use by the debugger, in response to
- -- the special encoding used for Vax floating-point types (see Exp_Dbug
- -- for details). They supersede the above Debug_Output_D/F/G routines
- -- which didn't work properly with GDBTK.
-
- procedure pd (Arg : D);
- procedure pf (Arg : F);
- procedure pg (Arg : G);
- pragma Export (Ada, pd);
- pragma Export (Ada, pf);
- pragma Export (Ada, pg);
- -- These are like the Debug_Output_D/F/G procedures except that they
- -- output a line return after the output. They were originally present
- -- for direct use in GDB before GDB recognized Vax floating-point
- -- types, and are retained for backwards compatibility.
-
-private
- pragma Inline_Always (D_To_G);
- pragma Inline_Always (F_To_G);
- pragma Inline_Always (F_To_Q);
- pragma Inline_Always (F_To_S);
- pragma Inline_Always (G_To_D);
- pragma Inline_Always (G_To_F);
- pragma Inline_Always (G_To_Q);
- pragma Inline_Always (G_To_T);
- pragma Inline_Always (Q_To_F);
- pragma Inline_Always (Q_To_G);
- pragma Inline_Always (S_To_F);
- pragma Inline_Always (T_To_G);
-
- pragma Inline_Always (Abs_F);
- pragma Inline_Always (Abs_G);
- pragma Inline_Always (Add_F);
- pragma Inline_Always (Add_G);
- pragma Inline_Always (Div_G);
- pragma Inline_Always (Div_F);
- pragma Inline_Always (Mul_F);
- pragma Inline_Always (Mul_G);
- pragma Inline_Always (Neg_G);
- pragma Inline_Always (Neg_F);
- pragma Inline_Always (Return_D);
- pragma Inline_Always (Return_F);
- pragma Inline_Always (Return_G);
- pragma Inline_Always (Sub_F);
- pragma Inline_Always (Sub_G);
-
- pragma Inline_Always (Eq_F);
- pragma Inline_Always (Eq_G);
- pragma Inline_Always (Le_F);
- pragma Inline_Always (Le_G);
- pragma Inline_Always (Lt_F);
- pragma Inline_Always (Lt_G);
- pragma Inline_Always (Ne_F);
- pragma Inline_Always (Ne_G);
-
- pragma Inline_Always (Valid_D);
- pragma Inline_Always (Valid_F);
- pragma Inline_Always (Valid_G);
-
-end System.Vax_Float_Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2013, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is an Alpha/VMS package
-
-with System.HTable;
-pragma Elaborate_All (System.HTable);
-with System.Storage_Elements; use System.Storage_Elements;
-
-package body System.VMS_Exception_Table is
-
- type HTable_Headers is range 1 .. 37;
-
- type Exception_Code_Data;
- type Exception_Code_Data_Ptr is access all Exception_Code_Data;
-
- -- The following record maps an imported VMS condition to an
- -- Ada exception.
-
- type Exception_Code_Data is record
- Code : Exception_Code;
- Except : SSL.Exception_Data_Ptr;
- HTable_Ptr : Exception_Code_Data_Ptr;
- end record;
-
- procedure Set_HT_Link
- (T : Exception_Code_Data_Ptr;
- Next : Exception_Code_Data_Ptr);
-
- function Get_HT_Link (T : Exception_Code_Data_Ptr)
- return Exception_Code_Data_Ptr;
-
- function Hash (F : Exception_Code) return HTable_Headers;
- function Get_Key (T : Exception_Code_Data_Ptr) return Exception_Code;
-
- package Exception_Code_HTable is new System.HTable.Static_HTable (
- Header_Num => HTable_Headers,
- Element => Exception_Code_Data,
- Elmt_Ptr => Exception_Code_Data_Ptr,
- Null_Ptr => null,
- Set_Next => Set_HT_Link,
- Next => Get_HT_Link,
- Key => Exception_Code,
- Get_Key => Get_Key,
- Hash => Hash,
- Equal => "=");
-
- ------------------
- -- Base_Code_In --
- ------------------
-
- function Base_Code_In
- (Code : Exception_Code) return Exception_Code
- is
- begin
- return To_Address (To_Integer (Code) and not 2#0111#);
- end Base_Code_In;
-
- ---------------------
- -- Coded_Exception --
- ---------------------
-
- function Coded_Exception
- (X : Exception_Code) return SSL.Exception_Data_Ptr
- is
- Res : Exception_Code_Data_Ptr;
-
- begin
- Res := Exception_Code_HTable.Get (X);
-
- if Res /= null then
- return Res.Except;
- else
- return null;
- end if;
-
- end Coded_Exception;
-
- -----------------
- -- Get_HT_Link --
- -----------------
-
- function Get_HT_Link
- (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr
- is
- begin
- return T.HTable_Ptr;
- end Get_HT_Link;
-
- -------------
- -- Get_Key --
- -------------
-
- function Get_Key (T : Exception_Code_Data_Ptr)
- return Exception_Code
- is
- begin
- return T.Code;
- end Get_Key;
-
- ----------
- -- Hash --
- ----------
-
- function Hash
- (F : Exception_Code) return HTable_Headers
- is
- Headers_Magnitude : constant Exception_Code :=
- Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
-
- begin
- return HTable_Headers
- (To_Address ((To_Integer (F) mod To_Integer (Headers_Magnitude)) + 1));
- end Hash;
-
- ----------------------------
- -- Register_VMS_Exception --
- ----------------------------
-
- procedure Register_VMS_Exception
- (Code : Exception_Code;
- E : SSL.Exception_Data_Ptr)
- is
- -- We bind the exception data with the base code found in the
- -- input value, that is with the severity bits masked off.
-
- Excode : constant Exception_Code := Base_Code_In (Code);
-
- begin
- -- The exception data registered here is mostly filled prior to this
- -- call and by __gnat_error_handler when the exception is raised. We
- -- still need to fill a couple of components for exceptions that will
- -- be used as propagation filters (exception data pointer registered
- -- as choices in the unwind tables): in some import/export cases, the
- -- exception pointers for the choice and the propagated occurrence may
- -- indeed be different for a single import code, and the personality
- -- routine attempts to match the import codes in this case.
-
- E.Lang := 'V';
- E.Foreign_Data := Excode;
-
- if Exception_Code_HTable.Get (Excode) = null then
- Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null));
- end if;
- end Register_VMS_Exception;
-
- -----------------
- -- Set_HT_Link --
- -----------------
-
- procedure Set_HT_Link
- (T : Exception_Code_Data_Ptr;
- Next : Exception_Code_Data_Ptr)
- is
- begin
- T.HTable_Ptr := Next;
- end Set_HT_Link;
-
-end System.VMS_Exception_Table;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1997-2013, 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 3, 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. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is usually used only on OpenVMS systems in the case
--- where there is at least one Import/Export exception present.
-
-with System.Standard_Library;
-
-package System.VMS_Exception_Table is
-
- package SSL renames System.Standard_Library;
-
- subtype Exception_Code is System.Address;
-
- procedure Register_VMS_Exception
- (Code : Exception_Code;
- E : SSL.Exception_Data_Ptr);
- -- Register an exception in hash table mapping with a VMS condition code.
- --
- -- The table is used by exception code (the personnality routine) to detect
- -- wether a VMS exception (aka condition) is known by the Ada code. In
- -- that case, the identity of the imported or exported exception is used
- -- to create the occurrence.
-
- -- LOTS more comments needed here regarding the entire scheme ???
-
-private
-
- -- The following functions are directly called (without import/export) in
- -- init.c by __gnat_handle_vms_condition.
-
- function Base_Code_In (Code : Exception_Code) return Exception_Code;
- -- Value of Code with the severity bits masked off
-
- function Coded_Exception (X : Exception_Code)
- return SSL.Exception_Data_Ptr;
- -- Given a VMS condition, find and return its allocated Ada exception
-
-end System.VMS_Exception_Table;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S E M _ V F P T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2014, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with CStand; use CStand;
-with Einfo; use Einfo;
-with Stand; use Stand;
-
-package body Sem_VFpt is
-
- -----------------
- -- Set_D_Float --
- -----------------
-
- procedure Set_D_Float (E : Entity_Id) is
- VAXDF_Digits : constant := 9;
-
- begin
- Init_Size (Base_Type (E), 64);
- Init_Alignment (Base_Type (E));
- Init_Digits_Value (Base_Type (E), VAXDF_Digits);
- Set_Float_Bounds (Base_Type (E));
-
- Init_Size (E, 64);
- Init_Alignment (E);
- Init_Digits_Value (E, VAXDF_Digits);
- Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
- end Set_D_Float;
-
- -----------------
- -- Set_F_Float --
- -----------------
-
- procedure Set_F_Float (E : Entity_Id) is
- VAXFF_Digits : constant := 6;
-
- begin
- Init_Size (Base_Type (E), 32);
- Init_Alignment (Base_Type (E));
- Init_Digits_Value (Base_Type (E), VAXFF_Digits);
- Set_Float_Bounds (Base_Type (E));
-
- Init_Size (E, 32);
- Init_Alignment (E);
- Init_Digits_Value (E, VAXFF_Digits);
- Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
- end Set_F_Float;
-
- -----------------
- -- Set_G_Float --
- -----------------
-
- procedure Set_G_Float (E : Entity_Id) is
- VAXGF_Digits : constant := 15;
-
- begin
- Init_Size (Base_Type (E), 64);
- Init_Alignment (Base_Type (E));
- Init_Digits_Value (Base_Type (E), VAXGF_Digits);
- Set_Float_Bounds (Base_Type (E));
-
- Init_Size (E, 64);
- Init_Alignment (E);
- Init_Digits_Value (E, VAXGF_Digits);
- Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
- end Set_G_Float;
-
- -------------------
- -- Set_IEEE_Long --
- -------------------
-
- procedure Set_IEEE_Long (E : Entity_Id) is
- IEEEL_Digits : constant := 15;
-
- begin
- Init_Size (Base_Type (E), 64);
- Init_Alignment (Base_Type (E));
- Init_Digits_Value (Base_Type (E), IEEEL_Digits);
- Set_Float_Rep (Base_Type (E), IEEE_Binary);
- Set_Float_Bounds (Base_Type (E));
-
- Init_Size (E, 64);
- Init_Alignment (E);
- Init_Digits_Value (E, IEEEL_Digits);
- Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
- end Set_IEEE_Long;
-
- --------------------
- -- Set_IEEE_Short --
- --------------------
-
- procedure Set_IEEE_Short (E : Entity_Id) is
- IEEES_Digits : constant := 6;
-
- begin
- Init_Size (Base_Type (E), 32);
- Init_Alignment (Base_Type (E));
- Init_Digits_Value (Base_Type (E), IEEES_Digits);
- Set_Float_Rep (Base_Type (E), IEEE_Binary);
- Set_Float_Bounds (Base_Type (E));
-
- Init_Size (E, 32);
- Init_Alignment (E);
- Init_Digits_Value (E, IEEES_Digits);
- Set_Scalar_Range (E, Scalar_Range (Base_Type (E)));
- end Set_IEEE_Short;
-
- ------------------------------
- -- Set_Standard_Fpt_Formats --
- ------------------------------
-
- procedure Set_Standard_Fpt_Formats is
- begin
- Set_IEEE_Short (Standard_Float);
- Set_IEEE_Long (Standard_Long_Float);
- Set_IEEE_Long (Standard_Long_Long_Float);
- end Set_Standard_Fpt_Formats;
-
-end Sem_VFpt;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S E M _ V F P T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1997-2014, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains specialized routines for handling the Alpha
--- floating point formats. It is used only in Alpha implementations.
--- Note that this means that the caller can assume that we are on an
--- Alpha implementation, and that Vax floating-point formats are valid.
-
-with Types; use Types;
-
-package Sem_VFpt is
-
- procedure Set_D_Float (E : Entity_Id);
- -- Sets the given floating-point entity to have Vax D_Float format
-
- procedure Set_F_Float (E : Entity_Id);
- -- Sets the given floating-point entity to have Vax F_Float format
-
- procedure Set_G_Float (E : Entity_Id);
- -- Sets the given floating-point entity to have Vax G_Float format
-
- procedure Set_IEEE_Short (E : Entity_Id);
- -- Sets the given floating-point entity to have IEEE Short format
-
- procedure Set_IEEE_Long (E : Entity_Id);
- -- Sets the given floating-point entity to have IEEE Long format
-
- procedure Set_Standard_Fpt_Formats;
- -- This procedure sets the appropriate formats for the standard
- -- floating-point types in Standard, based on the setting of
- -- the flags Opt.Float_Format and Opt.Float_Format_Long
-
-end Sem_VFpt;
#include "gsocket.h"
-#if defined(VMS)
-/*
- * For VMS, gsocket.h can't include sockets-related DEC C header files
- * when building the runtime (because these files are in a DEC C text library
- * (DECC$RTLDEF.TLB) not accessible to GCC). So, we generate a separate header
- * file along with s-oscons.ads and include it here.
- */
-# include "s-oscons.h"
-
-/*
- * We also need the declaration of struct hostent/servent, which s-oscons
- * can't provide, so we copy it manually here. This needs to be kept in synch
- * with the definition of that structure in the DEC C headers, which
- * hopefully won't change frequently.
- */
-typedef char *__netdb_char_ptr __attribute__ (( mode (SI) ));
-typedef __netdb_char_ptr *__netdb_char_ptr_ptr __attribute__ (( mode (SI) ));
-
-struct hostent {
- __netdb_char_ptr h_name;
- __netdb_char_ptr_ptr h_aliases;
- int h_addrtype;
- int h_length;
- __netdb_char_ptr_ptr h_addr_list;
-};
-
-struct servent {
- __netdb_char_ptr s_name;
- __netdb_char_ptr_ptr s_aliases;
- int s_port;
- __netdb_char_ptr s_proto;
-};
-#elif defined(__FreeBSD__)
+#if defined(__FreeBSD__)
typedef unsigned int IOCTL_Req_T;
#else
typedef int IOCTL_Req_T;
#endif
}
\f
-#if defined (_WIN32) || defined (__vxworks) || defined (VMS)
+#if defined (_WIN32) || defined (__vxworks)
/*
* Signalling FDs operations are implemented in Ada for these platforms
* (see subunit GNAT.Sockets.Thin.Signalling_Fds).
return -1;
}
-#elif defined (VMS)
- /* h_errno is defined as follows in OpenVMS' version of <netdb.h>.
- * However this header file is not available when building the GNAT
- * runtime library using GCC, so we are hardcoding the definition
- * directly. Note that the returned address is thread-specific.
- */
- extern int *decc$h_errno_get_addr ();
- return *decc$h_errno_get_addr ();
-
#elif defined (__rtems__)
/* At this stage in the tool build, no networking .h files are available.
* Newlib does not provide networking .h files and RTEMS is not built yet.
#ifndef HAVE_INET_PTON
-#ifdef VMS
-# define in_addr_t int
-# define inet_addr decc$inet_addr
-#endif
-
int
__gnat_inet_pton (int af, const char *src, void *dst) {
switch (af) {
}
return (rc == 0);
-#elif defined (__hpux__) || defined (VMS)
+#elif defined (__hpux__)
in_addr_t addr;
int rc = -1;
projects / thirdparty / gcc.git / commitdiff
