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

[multiple changes]

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

From-SVN: r220852
This commit is contained in:
Arnaud Charlet 2015-02-20 12:48:57 +01:00
parent 5865a63df4
commit 5ae7c3cf2e
15 changed files with 270 additions and 244 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/ada/ChangeLog
View File

@ -1,3 +1,40 @@
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.

31
gcc/ada/a-dinopr.ads Normal file
View File

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

57
gcc/ada/a-dispat.adb Normal file
View File

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

4
gcc/ada/a-dispat.ads
View File

@ -14,7 +14,9 @@
------------------------------------------------------------------------------
package Ada.Dispatching is
pragma Pure (Dispatching);
pragma Preelaborate (Dispatching);
procedure Yield;
Dispatching_Policy_Error : exception;
end Ada.Dispatching;

147
gcc/ada/adaint.c
View File

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

14
gcc/ada/debug.adb
View File

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

8
gcc/ada/expect.c
View File

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

6
gcc/ada/gsocket.h
View File

@ -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) */

3
gcc/ada/impunit.adb
View File

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

56
gcc/ada/par-ch3.adb
View File

@ -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");
if In_Spec then
Error_Msg_SC ("statement not allowed in package spec");
-- 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.
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;
-- 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;
-- In all cases except the case in which we decided to terminate the

17
gcc/ada/s-oscons-tmplt.c
View File

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

11
gcc/ada/sem_prag.adb
View File

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

22
gcc/ada/sem_res.adb
View File

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

12
gcc/ada/snames.ads-tmpl
View File

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

89
gcc/ada/sysdep.c
View File

@ -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,11 +831,9 @@ __gnat_localtime_tzoff (const time_t *timer ATTRIBUTE_UNUSED,
#else
*off = 0;
#endif
#endif /* defined(_AIX) ... */
}
#endif
#endif
#endif
#ifdef __vxworks