diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 37 | ||||
| -rw-r--r-- | gcc/ada/a-dinopr.ads | 31 | ||||
| -rw-r--r-- | gcc/ada/a-dispat.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/a-dispat.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 147 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/expect.c | 8 | ||||
| -rw-r--r-- | gcc/ada/gsocket.h | 6 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/s-oscons-tmplt.c | 17 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 12 | ||||
| -rw-r--r-- | gcc/ada/sysdep.c | 89 |
15 files changed, 269 insertions, 243 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c255ca6..cdaacd2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,42 @@ 2015-02-20 Arnaud Charlet <charlet@adacore.com> + * sysdep.c, expect.c, s-oscons-tmplt.c, gsocket.h, adaint.c: Remove + obsolete references to RTX, nucleus, VMS. + +2015-02-20 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb (Fix_Error): For an illegal Type_Invariant'Class + aspect, use name that mentions Class explicitly, rather than + compiler-internal name. + +2015-02-20 Robert Dewar <dewar@adacore.com> + + * debug.adb: Add documentation for -gnatd.2 (allow statements + in decl sequences). + * par-ch3.adb (P_Identifier_Declarations): Handle + statement appearing where declaration expected more cleanly. + (Statement_When_Declaration_Expected): Implement debug flag + -gnatd.2. + +2015-02-20 Jose Ruiz <ruiz@adacore.com> + + * a-dinopr.ads: Add spec for this package (Unimplemented_Unit). + * a-dispat.ads (Yield): Include procedure added in Ada 2012. + * a-dispat.adb (Yield): Implement procedure added in Ada 2012. + * impunit.adb (Non_Imp_File_Names_05): Mark unit a-dinopr.ads as + defined by Ada 2005. + * snames.ads-tmpl (Name_Non_Preemptive_FIFO_Within_Priorities): + This is the correct name for the dispatching policy (FIFO was + missing). + +2015-02-20 Javier Miranda <miranda@adacore.com> + + * sem_res.adb (Resolve_Type_Conversion): If the type of the + operand is the limited-view of a class-wide type then recover + the class-wide type of the non-limited view. + +2015-02-20 Arnaud Charlet <charlet@adacore.com> + * gcc-interface/Makefile.in: Remove references to nucleus. * gcc-interface/decl.c (gnat_to_gnu_entity, case E_Procedure): Set extern_flag to true for Inline_Always subprograms with diff --git a/gcc/ada/a-dinopr.ads b/gcc/ada/a-dinopr.ads new file mode 100644 index 0000000..396aeae --- /dev/null +++ b/gcc/ada/a-dinopr.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . N O N _ P R E E M P T I V E -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +package Ada.Dispatching.Non_Preemptive is + pragma Preelaborate (Non_Preemptive); + + pragma Unimplemented_Unit; + + procedure Yield_To_Higher; + procedure Yield_To_Same_Or_Higher renames Yield; +end Ada.Dispatching.Non_Preemptive; diff --git a/gcc/ada/a-dispat.adb b/gcc/ada/a-dispat.adb new file mode 100644 index 0000000..b00a17f --- /dev/null +++ b/gcc/ada/a-dispat.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015, 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 Ada.Exceptions; +with System.Tasking; +with System.Task_Primitives.Operations; + +package body Ada.Dispatching is + + procedure Yield is + Self_Id : constant System.Tasking.Task_Id := + System.Task_Primitives.Operations.Self; + + begin + -- If pragma Detect_Blocking is active, Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + System.Task_Primitives.Operations.Yield; + end if; + end Yield; + +end Ada.Dispatching; diff --git a/gcc/ada/a-dispat.ads b/gcc/ada/a-dispat.ads index b350ae0..a193940 100644 --- a/gcc/ada/a-dispat.ads +++ b/gcc/ada/a-dispat.ads @@ -14,7 +14,9 @@ ------------------------------------------------------------------------------ package Ada.Dispatching is - pragma Pure (Dispatching); + pragma Preelaborate (Dispatching); + + procedure Yield; Dispatching_Policy_Error : exception; end Ada.Dispatching; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index d9bccfe..05c8055 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -108,16 +108,11 @@ extern "C" { #if defined (__MINGW32__) || defined (__CYGWIN__) -#if defined (RTX) -#include <windows.h> -#include <Rtapi.h> -#else #include "mingw32.h" /* Current code page and CCS encoding to use, set in initialize.c. */ UINT CurrentCodePage; UINT CurrentCCSEncoding; -#endif #include <sys/utime.h> @@ -157,7 +152,7 @@ UINT CurrentCCSEncoding; preventing the inclusion of the GCC header from doing anything. */ # define GCC_RESOURCE_H # include <sys/wait.h> -#elif defined (__nucleus__) || defined (__PikeOS__) +#elif defined (__PikeOS__) /* No wait() or waitpid() calls available. */ #else /* Default case. */ @@ -253,7 +248,7 @@ char __gnat_path_separator = PATH_SEPARATOR; const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE; -#if defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__) +#if defined (__vxworks) #define GNAT_MAX_PATH_LEN PATH_MAX #else @@ -418,7 +413,7 @@ __gnat_readlink (char *path ATTRIBUTE_UNUSED, size_t bufsiz ATTRIBUTE_UNUSED) { #if defined (_WIN32) \ - || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__) + || defined(__vxworks) || defined (__PikeOS__) return -1; #else return readlink (path, buf, bufsiz); @@ -434,7 +429,7 @@ __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, char *newpath ATTRIBUTE_UNUSED) { #if defined (_WIN32) \ - || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__) + || defined(__vxworks) || defined (__PikeOS__) return -1; #else return symlink (oldpath, newpath); @@ -443,7 +438,7 @@ __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, /* Try to lock a file, return 1 if success. */ -#if defined (__vxworks) || defined (__nucleus__) \ +#if defined (__vxworks) \ || defined (_WIN32) || defined (__PikeOS__) /* Version that does not use link. */ @@ -985,8 +980,6 @@ __gnat_open_new_temp (char *path, int fmode) return mkstemp (path); #elif defined (__Lynx__) mktemp (path); -#elif defined (__nucleus__) - return -1; #else if (mktemp (path) == NULL) return -1; @@ -1063,7 +1056,7 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) attr->exists = !ret; -#if !defined (_WIN32) || defined (RTX) +#if !defined (_WIN32) /* on Windows requires extra system call, see __gnat_is_readable_file_attr */ attr->readable = (!ret && (statbuf.st_mode & S_IRUSR)); attr->writable = (!ret && (statbuf.st_mode & S_IWUSR)); @@ -1121,15 +1114,7 @@ __gnat_named_file_length (char *name) void __gnat_tmp_name (char *tmp_filename) { -#ifdef RTX - /* Variable used to create a series of unique names */ - static int counter = 0; - - /* RTX in RTSS mode does not support tempnam nor tmpnam so we emulate it */ - strcpy (tmp_filename, "c:\\WINDOWS\\Temp\\gnat-"); - sprintf (&tmp_filename[strlen (tmp_filename)], "%d\0", counter++); - -#elif defined (__MINGW32__) +#if defined (__MINGW32__) { char *pname; char prefix[25]; @@ -1205,12 +1190,7 @@ __gnat_tmp_name (char *tmp_filename) DIR* __gnat_opendir (char *name) { -#if defined (RTX) - /* Not supported in RTX */ - - return NULL; - -#elif defined (__MINGW32__) +#if defined (__MINGW32__) TCHAR wname[GNAT_MAX_PATH_LEN]; S2WSC (wname, name, GNAT_MAX_PATH_LEN); @@ -1234,12 +1214,7 @@ DIR* __gnat_opendir (char *name) char * __gnat_readdir (DIR *dirp, char *buffer, int *len) { -#if defined (RTX) - /* Not supported in RTX */ - - return NULL; - -#elif defined (__MINGW32__) +#if defined (__MINGW32__) struct _tdirent *dirent = _treaddir ((_TDIR*)dirp); if (dirent != NULL) @@ -1281,12 +1256,7 @@ __gnat_readdir (DIR *dirp, char *buffer, int *len) int __gnat_closedir (DIR *dirp) { -#if defined (RTX) - /* Not supported in RTX */ - - return 0; - -#elif defined (__MINGW32__) +#if defined (__MINGW32__) return _tclosedir ((_TDIR*)dirp); #else @@ -1306,7 +1276,7 @@ __gnat_readdir_is_thread_safe (void) #endif } -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) /* Number of seconds between <Jan 1st 1601> and <Jan 1st 1970>. */ static const unsigned long long w32_epoch_offset = 11644473600ULL; @@ -1354,7 +1324,7 @@ OS_Time __gnat_file_time_name_attr (char* name, struct file_attributes* attr) { if (attr->timestamp == (OS_Time)-2) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) BOOL res; WIN32_FILE_ATTRIBUTE_DATA fad; __time64_t ret = -1; @@ -1385,7 +1355,7 @@ OS_Time __gnat_file_time_fd_attr (int fd, struct file_attributes* attr) { if (attr->timestamp == (OS_Time)-2) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) HANDLE h = (HANDLE) _get_osfhandle (fd); time_t ret = win32_filetime (h); attr->timestamp = (OS_Time) ret; @@ -1415,7 +1385,7 @@ __gnat_set_file_time_name (char *name, time_t time_stamp) /* Code to implement __gnat_set_file_time_name for these systems. */ -#elif defined (_WIN32) && !defined (RTX) +#elif defined (_WIN32) union { FILETIME ft_time; @@ -1466,8 +1436,7 @@ __gnat_get_libraries_from_registry (void) result[0] = '\0'; -#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) \ - && ! defined (RTX) +#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) HKEY reg_key; DWORD name_size, value_size; @@ -1699,7 +1668,7 @@ __gnat_is_directory (char *name) return __gnat_is_directory_attr (name, &attr); } -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) /* Returns the same constant as GetDriveType but takes a pathname as argument. */ @@ -1887,14 +1856,14 @@ __gnat_can_use_acl (TCHAR *wname) return __gnat_use_acl && GetDriveTypeFromPath (wname) != DRIVE_REMOTE; } -#endif /* defined (_WIN32) && !defined (RTX) */ +#endif /* defined (_WIN32) */ int __gnat_is_readable_file_attr (char* name, struct file_attributes* attr) { if (attr->readable == ATTR_UNSET) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; GENERIC_MAPPING GenericMapping; @@ -1931,7 +1900,7 @@ __gnat_is_writable_file_attr (char* name, struct file_attributes* attr) { if (attr->writable == ATTR_UNSET) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; GENERIC_MAPPING GenericMapping; @@ -1972,7 +1941,7 @@ __gnat_is_executable_file_attr (char* name, struct file_attributes* attr) { if (attr->executable == ATTR_UNSET) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; GENERIC_MAPPING GenericMapping; @@ -2019,7 +1988,7 @@ __gnat_is_executable_file (char *name) void __gnat_set_writable (char *name) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); @@ -2029,8 +1998,7 @@ __gnat_set_writable (char *name) SetFileAttributes (wname, GetFileAttributes (wname) & ~FILE_ATTRIBUTE_READONLY); -#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \ - ! defined(__nucleus__) +#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) GNAT_STRUCT_STAT statbuf; if (GNAT_STAT (name, &statbuf) == 0) @@ -2049,7 +2017,7 @@ __gnat_set_writable (char *name) void __gnat_set_executable (char *name, int mode ATTRIBUTE_UNUSED) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); @@ -2057,8 +2025,7 @@ __gnat_set_executable (char *name, int mode ATTRIBUTE_UNUSED) if (__gnat_can_use_acl (wname)) __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_EXECUTE); -#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \ - ! defined(__nucleus__) +#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) GNAT_STRUCT_STAT statbuf; if (GNAT_STAT (name, &statbuf) == 0) @@ -2077,7 +2044,7 @@ __gnat_set_executable (char *name, int mode ATTRIBUTE_UNUSED) void __gnat_set_non_writable (char *name) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); @@ -2090,8 +2057,7 @@ __gnat_set_non_writable (char *name) SetFileAttributes (wname, GetFileAttributes (wname) | FILE_ATTRIBUTE_READONLY); -#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \ - ! defined(__nucleus__) +#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) GNAT_STRUCT_STAT statbuf; if (GNAT_STAT (name, &statbuf) == 0) @@ -2105,7 +2071,7 @@ __gnat_set_non_writable (char *name) void __gnat_set_readable (char *name) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); @@ -2113,8 +2079,7 @@ __gnat_set_readable (char *name) if (__gnat_can_use_acl (wname)) __gnat_set_OWNER_ACL (wname, GRANT_ACCESS, FILE_GENERIC_READ); -#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \ - ! defined(__nucleus__) +#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) GNAT_STRUCT_STAT statbuf; if (GNAT_STAT (name, &statbuf) == 0) @@ -2127,7 +2092,7 @@ __gnat_set_readable (char *name) void __gnat_set_non_readable (char *name) { -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); @@ -2135,8 +2100,7 @@ __gnat_set_non_readable (char *name) if (__gnat_can_use_acl (wname)) __gnat_set_OWNER_ACL (wname, DENY_ACCESS, FILE_GENERIC_READ); -#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) && \ - ! defined(__nucleus__) +#elif ! (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) GNAT_STRUCT_STAT statbuf; if (GNAT_STAT (name, &statbuf) == 0) @@ -2152,7 +2116,7 @@ __gnat_is_symbolic_link_attr (char* name ATTRIBUTE_UNUSED, { if (attr->symbolic_link == ATTR_UNSET) { -#if defined (__vxworks) || defined (__nucleus__) +#if defined (__vxworks) attr->symbolic_link = 0; #elif defined (_AIX) || defined (__APPLE__) || defined (__unix__) @@ -2190,8 +2154,7 @@ __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED) int finished ATTRIBUTE_UNUSED; int pid ATTRIBUTE_UNUSED; -#if defined (__vxworks) || defined(__nucleus__) || defined(RTX) \ - || defined(__PikeOS__) +#if defined (__vxworks) || defined(__PikeOS__) return -1; #elif defined (_WIN32) @@ -2309,7 +2272,7 @@ __gnat_number_of_cpus (void) /* WIN32 code to implement a wait call that wait for any child process. */ -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) /* Synchronization code, to be thread safe. */ @@ -2560,8 +2523,7 @@ int __gnat_portable_no_block_spawn (char *args[] ATTRIBUTE_UNUSED) { -#if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \ - || defined (__PikeOS__) +#if defined (__vxworks) || defined (__PikeOS__) /* Not supported. */ return -1; @@ -2601,8 +2563,7 @@ __gnat_portable_wait (int *process_status) int status = 0; int pid = 0; -#if defined (__vxworks) || defined (__nucleus__) || defined (RTX) \ - || defined (__PikeOS__) +#if defined (__vxworks) || defined (__PikeOS__) /* Not sure what to do here, so do nothing but return zero. */ #elif defined (_WIN32) @@ -2779,7 +2740,7 @@ __gnat_locate_exec_on_path (char *exec_name) { char *apath_val; -#if defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) TCHAR *wpath_val = _tgetenv (_T("PATH")); TCHAR *wapath_val; /* In Win32 systems we expand the PATH as for XP environment @@ -2918,11 +2879,10 @@ int __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED, int mode ATTRIBUTE_UNUSED) { -#if (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \ - defined (__nucleus__) +#if (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) return -1; -#elif defined (_WIN32) && !defined (RTX) +#elif defined (_WIN32) TCHAR wfrom [GNAT_MAX_PATH_LEN + 2]; TCHAR wto [GNAT_MAX_PATH_LEN + 2]; BOOL res; @@ -3076,37 +3036,6 @@ __gnat_sals_init_using_constructors (void) #endif } -#ifdef RTX - -/* In RTX mode, the procedure to get the time (as file time) is different - in RTSS mode and Win32 mode. In order to avoid duplicating an Ada file, - we introduce an intermediate procedure to link against the corresponding - one in each situation. */ - -extern void GetTimeAsFileTime (LPFILETIME pTime); - -void GetTimeAsFileTime (LPFILETIME pTime) -{ -#ifdef RTSS - RtGetRtssTimeAsFileTime (pTime); /* RTSS interface */ -#else - GetSystemTimeAsFileTime (pTime); /* w32 interface */ -#endif -} - -#ifdef RTSS -/* Add symbol that is required to link. It would otherwise be taken from - libgcc.a and it would try to use the gcc constructors that are not - supported by Microsoft linker. */ - -extern void __main (void); - -void __main (void) -{ -} -#endif /* RTSS */ -#endif /* RTX */ - #if defined (__ANDROID__) #include <pthread.h> diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 31c3972..5869e96 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -155,8 +155,8 @@ package body Debug is -- d8 Force opposite endianness in packed stuff -- d9 Allow lock free implementation - -- d.1 - -- d.2 + -- d.1 Enable unnesting of nested procedures + -- d.2 Allow statements in declarative part -- d.3 -- d.4 -- d.5 @@ -746,6 +746,14 @@ package body Debug is -- d9 This allows lock free implementation for protected objects -- (see Exp_Ch9). + -- d.1 Enable unnesting of nested procedures. This special pass does not + -- actually unnest things, but it ensures that a nested procedure + -- does not contain any uplevel references. + + -- d.2 Allow statements within declarative parts. This is not usually + -- allowed, but in some debugging contexts (e.g. testing the circuit + -- for unnesting of procedures), it is useful to allow this. + ------------------------------------------ -- Documentation for Binder Debug Flags -- ------------------------------------------ diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index 45e0540..a6c1c8f 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2001-2014, AdaCore * + * Copyright (C) 2001-2015, AdaCore * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -54,8 +54,8 @@ /* ??? See comment in adaint.c. */ # define GCC_RESOURCE_H # include <sys/wait.h> -#elif defined (__nucleus__) || defined (__PikeOS__) - /* No wait.h available on Nucleus */ +#elif defined (__PikeOS__) + /* No wait.h available */ #else #include <sys/wait.h> #endif @@ -350,7 +350,7 @@ __gnat_expect_poll (int *fd, return ready; } -#elif defined (__unix__) && !defined (__nucleus__) +#elif defined (__unix__) #ifdef __hpux__ #include <sys/ptyio.h> diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index 4f9448b..4f3ed23 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 2004-2014, Free Software Foundation, Inc. * + * Copyright (C) 2004-2015, 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- * @@ -29,7 +29,7 @@ * * ****************************************************************************/ -#if defined(__nucleus__) || defined(VTHREADS) || defined(__PikeOS__) +#if defined(VTHREADS) || defined(__PikeOS__) /* Sockets not supported on these platforms. */ #undef HAVE_SOCKETS @@ -251,4 +251,4 @@ # define HAVE_INET_PTON #endif -#endif /* defined(__nucleus__) */ +#endif /* defined(VTHREADS) */ diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index ca53594..5b8676e 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2015, 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- -- @@ -427,6 +427,7 @@ package body Impunit is ("a-coorse", T), -- Ada.Containers.Ordered_Sets ("a-coteio", T), -- Ada.Complex_Text_IO ("a-direct", T), -- Ada.Directories + ("a-dinopr", T), -- Ada.Dispatching.Non_Preemptive ("a-diroro", T), -- Ada.Dispatching.Round_Robin ("a-disedf", T), -- Ada.Dispatching.EDF ("a-dispat", T), -- Ada.Dispatching diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 80c95a9..4a393bd 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -1455,6 +1455,16 @@ package body Ch3 is else Restore_Scan_State (Scan_State); + + -- Reset Token_Node, because it already got changed from an + -- Identifier to a Defining_Identifier, and we don't want that + -- for a statement! + + Token_Node := + Make_Identifier (Sloc (Token_Node), Chars (Token_Node)); + + -- And now scan out one or more statements + Statement_When_Declaration_Expected (Decls, Done, In_Spec); return; end if; @@ -4777,6 +4787,12 @@ package body Ch3 is if In_Spec then null; + -- Just ignore it if we are in -gnatd.2 (allow statements to appear + -- in declaration sequences) mode. + + elsif Debug_Flag_Dot_2 then + null; + -- In the declarative part case, take a second statement as a sure -- sign that we really have a missing BEGIN, and end the declarative -- part now. Note that the caller will fix up the first message to @@ -4790,26 +4806,32 @@ package body Ch3 is -- Case of first occurrence of unexpected statement else - -- If we are in a package spec, then give message of statement - -- not allowed in package spec. This message never gets changed. + -- Do not give error message if we are operating in -gnatd.2 mode + -- (alllow statements to appear in declarative parts). - if In_Spec then - Error_Msg_SC ("statement not allowed in package spec"); + if not Debug_Flag_Dot_2 then - -- If in declarative part, then we give the message complaining - -- about finding a statement when a declaration is expected. This - -- gets changed to a complaint about a missing BEGIN if we later - -- find that no BEGIN is present. + -- If we are in a package spec, then give message of statement + -- not allowed in package spec. This message never gets changed. - else - Error_Msg_SC ("statement not allowed in declarative part"); - end if; + if In_Spec then + Error_Msg_SC ("statement not allowed in package spec"); - -- Capture message Id. This is used for two purposes, first to - -- stop multiple messages, see test above, and second, to allow - -- the replacement of the message in the declarative part case. + -- If in declarative part, then we give the message complaining + -- about finding a statement when a declaration is expected. This + -- gets changed to a complaint about a missing BEGIN if we later + -- find that no BEGIN is present. - Missing_Begin_Msg := Get_Msg_Id; + else + Error_Msg_SC ("statement not allowed in declarative part"); + end if; + + -- Capture message Id. This is used for two purposes, first to + -- stop multiple messages, see test above, and second, to allow + -- the replacement of the message in the declarative part case. + + Missing_Begin_Msg := Get_Msg_Id; + end if; end if; -- In all cases except the case in which we decided to terminate the diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index de2b9b9..053d4a7 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2015, 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- -- @@ -108,16 +108,7 @@ pragma Style_Checks ("M32766"); #include <fcntl.h> #include <time.h> -#if defined (__VMS) -/** VMS is unable to do vector IO operations with default value of IOV_MAX, - ** so its value is redefined to a small one which is known to work properly. - **/ -#undef IOV_MAX -#define IOV_MAX 16 -#endif - -#if ! (defined (__vxworks) || defined (__VMS) || defined (__MINGW32__) || \ - defined (__nucleus__)) +#if ! (defined (__vxworks) || defined (__MINGW32__)) # define HAVE_TERMIOS #endif @@ -286,12 +277,10 @@ package System.OS_Constants is -- General platform parameters -- --------------------------------- - type OS_Type is (Windows, VMS, Other_OS); + type OS_Type is (Windows, Other_OS); */ #if defined (__MINGW32__) # define TARGET_OS "Windows" -#elif defined (__VMS) -# define TARGET_OS "VMS" #else # define TARGET_OS "Other_OS" #endif diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 98b825a..df97ee6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5918,6 +5918,17 @@ package body Sem_Prag is -- Get name from corresponding aspect Error_Msg_Name_1 := Original_Aspect_Name (N); + + if Class_Present (N) then + + -- Replace the name with a leading underscore used + -- internally, with a name that is more user-friendly. + + if Error_Msg_Name_1 = Name_uType_Invariant then + Error_Msg_Name_1 := Name_Type_Invariant_Class; + end if; + end if; + end if; -- Return possibly modified message diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 851e0a6..d5038ee 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10715,14 +10715,22 @@ package body Sem_Res is begin -- If the type of the operand is a limited view, use the non- - -- limited view when available. + -- limited view when available. If it is a class-wide type, + -- recover class_wide type of the non-limited view. - if From_Limited_With (Opnd) - and then Ekind (Opnd) in Incomplete_Kind - and then Present (Non_Limited_View (Opnd)) - then - Opnd := Non_Limited_View (Opnd); - Set_Etype (Expression (N), Opnd); + if From_Limited_With (Opnd) then + if Ekind (Opnd) in Incomplete_Kind + and then Present (Non_Limited_View (Opnd)) + then + Opnd := Non_Limited_View (Opnd); + Set_Etype (Expression (N), Opnd); + + elsif Is_Class_Wide_Type (Opnd) + and then Present (Non_Limited_View (Etype (Opnd))) + then + Opnd := Class_Wide_Type (Non_Limited_View (Etype (Opnd))); + Set_Etype (Expression (N), Opnd); + end if; end if; if Is_Access_Type (Opnd) then diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 47a8ccd..6e1aec8 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1063,12 +1063,12 @@ package Snames is -- for FIFO_Within_Priorities). If new policy names are added, the first -- character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + $; - Name_EDF_Across_Priorities : constant Name_Id := N + $; - Name_FIFO_Within_Priorities : constant Name_Id := N + $; - Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + $; - Name_Round_Robin_Within_Priorities : constant Name_Id := N + $; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + $; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + $; + Name_EDF_Across_Priorities : constant Name_Id := N + $; + Name_FIFO_Within_Priorities : constant Name_Id := N + $; + Name_Non_Preemptive_FIFO_Within_Priorities : constant Name_Id := N + $; + Name_Round_Robin_Within_Priorities : constant Name_Id := N + $; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + $; -- Names of recognized partition elaboration policy identifiers diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 0ae05e0..fd90ffe 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2014, Free Software Foundation, Inc. * + * Copyright (C) 1992-2015, 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- * @@ -58,9 +58,6 @@ #include "tsystem.h" #include <fcntl.h> #include <sys/stat.h> -#ifdef VMS -#include <unixio.h> -#endif #else #include "config.h" #include "system.h" @@ -190,8 +187,6 @@ __gnat_ttyname (int filedes) #if defined (__CYGWIN__) || defined (__MINGW32__) #include <windows.h> -#ifndef RTX - int __gnat_is_windows_xp (void); int @@ -216,8 +211,6 @@ __gnat_is_windows_xp (void) return is_win_xp; } -#endif /* !RTX */ - /* Get the bounds of the stack. The stack pointer is supposed to be initialized to BASE when a thread is created and the stack can be extended to LIMIT before reaching a guard page. @@ -279,13 +272,13 @@ __gnat_set_mode (int handle ATTRIBUTE_UNUSED, int mode ATTRIBUTE_UNUSED) char * __gnat_ttyname (int filedes) { -#if defined (__vxworks) || defined (__nucleus) +#if defined (__vxworks) return ""; #else extern char *ttyname (int); return ttyname (filedes); -#endif /* defined (__vxworks) || defined (__nucleus) */ +#endif /* defined (__vxworks) */ } #endif @@ -306,11 +299,6 @@ __gnat_ttyname (int filedes) # include <termios.h> # endif -#else -# if defined (VMS) -extern char *decc$ga_stdscr; -static int initted = 0; -# endif #endif /* Implements the common processing for getc_immediate and @@ -424,29 +412,6 @@ getc_immediate_common (FILE *stream, } else -#elif defined (VMS) - int fd = fileno (stream); - - if (isatty (fd)) - { - if (initted == 0) - { - decc$bsd_initscr (); - initted = 1; - } - - decc$bsd_cbreak (); - *ch = decc$bsd_wgetch (decc$ga_stdscr); - - if (*ch == 4) - *end_of_file = 1; - else - *end_of_file = 0; - - *avail = 1; - decc$bsd_nocbreak (); - } - else #elif defined (__MINGW32__) int fd = fileno (stream); int char_waiting; @@ -629,23 +594,6 @@ rts_get_nShowCmd (void) } #endif /* WINNT */ -#ifdef VMS - -/* This gets around a problem with using the old threads library on VMS 7.0. */ - -extern long get_gmtoff (void); - -long -get_gmtoff (void) -{ - time_t t; - struct tm *ts; - - t = time ((time_t) 0); - ts = localtime (&t); - return ts->tm_gmtoff; -} -#endif /* This value is returned as the time zone offset when a valid value cannot be determined. It is simply a bizarre value that will never @@ -689,25 +637,18 @@ __gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off) { TIME_ZONE_INFORMATION tzi; - BOOL rtx_active; DWORD tzi_status; -#ifdef RTX - rtx_active = 1; -#else - rtx_active = 0; -#endif - (*Lock_Task) (); tzi_status = GetTimeZoneInformation (&tzi); - /* Processing for RTX targets or cases where we simply want to extract the - offset of the current time zone, regardless of the date. A value of "0" - for flag "is_historic" signifies that the date is NOT historic, see the + /* Cases where we simply want to extract the offset of the current time + zone, regardless of the date. A value of "0" for flag "is_historic" + signifies that the date is NOT historic, see the body of Ada.Calendar.UTC_Time_Offset. */ - if (rtx_active || *is_historic == 0) { + if (*is_historic == 0) { *off = tzi.Bias; /* The system is operating in the range covered by the StandardDate @@ -775,12 +716,10 @@ __gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off) (*Unlock_Task) (); } -#else +#elif defined (__Lynx__) /* On Lynx, all time values are treated in GMT */ -#if defined (__Lynx__) - /* As of LynxOS 3.1.0a patch level 040, LynuxWorks changes the prototype to the C library function localtime_r from the POSIX.4 Draft 9 to the POSIX 1.c version. Before this change the following @@ -798,13 +737,7 @@ __gnat_localtime_tzoff (const time_t *timer, const int *is_historic, long *off) #else -/* VMS does not need __gnat_localtime_tzoff */ - -#if defined (VMS) - -/* Other targets except Lynx, VMS and Windows provide a standard localtime_r */ - -#else +/* Other targets except Lynx and Windows provide a standard localtime_r */ #define Lock_Task system__soft_links__lock_task extern void (*Lock_Task) (void); @@ -898,12 +831,10 @@ __gnat_localtime_tzoff (const time_t *timer ATTRIBUTE_UNUSED, #else *off = 0; -#endif +#endif /* defined(_AIX) ... */ } #endif -#endif -#endif #ifdef __vxworks |