Commit 3be25873 authored by Jeff Chapman's avatar Jeff Chapman

update to current svn

parent 7d3f6067
This diff is collapsed.
This diff is collapsed.
......@@ -2610,7 +2610,7 @@ LIBGNAT_OBJS = adadecode.o adaint.o argv.o aux-io.o \
LIBGNAT_SRCS = $(patsubst %.o,%.c,$(LIBGNAT_OBJS)) \
adadecode.h adaint.h env.h gsocket.h raise.h standard.ads.h \
tb-gcc.c libgnarl/thread.c $(EXTRA_LIBGNAT_SRCS)
tb-gcc.c runtime.h libgnarl/thread.c $(EXTRA_LIBGNAT_SRCS)
# memtrack.o is special as not put into libgnat.
GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \
......
......@@ -29,15 +29,7 @@
* *
****************************************************************************/
#if defined(IN_RTS)
#include "tconfig.h"
#include "tsystem.h"
#elif defined(IN_GCC)
#include "config.h"
#include "system.h"
#endif
#include "runtime.h"
#include <string.h>
#include <stdio.h>
#include <ctype.h>
......
......@@ -88,8 +88,26 @@
#endif
#ifdef IN_RTS
#ifdef STANDALONE
#include <errno.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
#include <stdlib.h>
#include <string.h>
/* for CPU_SET/CPU_ZERO */
#define _GNU_SOURCE
#define __USE_GNU
#include "runtime.h"
#else
#include "tconfig.h"
#include "tsystem.h"
#endif
#include <sys/stat.h>
#include <fcntl.h>
#include <time.h>
......
......@@ -51,7 +51,7 @@ extern "C" {
determine at compile time what support the system offers for large files.
For now we just list the platforms we have manually tested. */
#if defined (__GLIBC__) || defined (__sun__) || defined (__QNX__)
#if (defined (__GLIBC__) && !defined(STANDALONE)) || defined (__sun__) || defined (__QNX__)
#define GNAT_FOPEN fopen64
#define GNAT_OPEN open64
#define GNAT_STAT stat64
......
......@@ -43,9 +43,8 @@
Ada.Command_Line.Environment package. */
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
#include <sys/stat.h>
#include "runtime.h"
#include <string.h>
#else
#include "config.h"
#include "system.h"
......
......@@ -225,7 +225,10 @@ package body Aspects is
Owner := Root_Type (Owner);
end if;
if Is_Private_Type (Owner) and then Present (Full_View (Owner)) then
if Is_Private_Type (Owner)
and then Present (Full_View (Owner))
and then not Operational_Aspect (A)
then
Owner := Full_View (Owner);
end if;
end if;
......
......@@ -277,6 +277,20 @@ package Aspects is
Aspect_Warnings => True,
others => False);
-- The following array indicates aspects that specify operational
-- characteristics, and thus are view-specific. Representation
-- aspects break privacy, as they are needed during expansion and
-- code generation.
-- List is currently incomplete ???
Operational_Aspect : constant array (Aspect_Id) of Boolean :=
(Aspect_Constant_Indexing => True,
Aspect_Default_Iterator => True,
Aspect_Iterator_Element => True,
Aspect_Iterable => True,
Aspect_Variable_Indexing => True,
others => False);
-- The following array indicates aspects for which multiple occurrences of
-- the same aspect attached to the same declaration are allowed.
......
......@@ -31,10 +31,7 @@
#include <stdio.h>
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
#else
#ifndef IN_RTS
#include "config.h"
#include "system.h"
#endif
......
......@@ -435,7 +435,7 @@ package body Checks is
-- Fall through for cases where we do set the flag
Set_Do_Overflow_Check (N, True);
Set_Do_Overflow_Check (N);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Overflow_Check;
......@@ -3622,13 +3622,14 @@ package body Checks is
-- will not be generated.
if GNATprove_Mode
or else not Is_Fixed_Point_Type (Expr_Type)
or else (not Is_Fixed_Point_Type (Expr_Type)
and then not Is_Fixed_Point_Type (Target_Type))
then
Apply_Scalar_Range_Check
(Expr, Target_Type, Fixed_Int => Conv_OK);
else
Set_Do_Range_Check (Expression (N), False);
Set_Do_Range_Check (Expr, False);
end if;
-- If the target type has predicates, we need to indicate
......@@ -6840,18 +6841,19 @@ package body Checks is
Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
procedure Convert_And_Check_Range;
-- Convert the conversion operand to the target base type and save in
-- a temporary. Then check the converted value against the range of the
-- target subtype.
procedure Convert_And_Check_Range (Suppress : Check_Id);
-- Convert N to the target base type and save the result in a temporary.
-- The action is analyzed using the default checks as modified by the
-- given Suppress argument. Then check the converted value against the
-- range of the target subtype.
-----------------------------
-- Convert_And_Check_Range --
-----------------------------
procedure Convert_And_Check_Range is
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
Conv_Node : Node_Id;
procedure Convert_And_Check_Range (Suppress : Check_Id) is
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
Conv_N : Node_Id;
begin
-- For enumeration types with non-standard representation this is a
......@@ -6866,36 +6868,26 @@ package body Checks is
and then Present (Enum_Pos_To_Rep (Source_Base_Type))
and then Is_Integer_Type (Target_Base_Type)
then
Conv_Node :=
OK_Convert_To
(Typ => Target_Base_Type,
Expr => Duplicate_Subexpr (N));
-- Common case
Conv_N := OK_Convert_To (Target_Base_Type, Duplicate_Subexpr (N));
else
Conv_Node :=
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
Expression => Duplicate_Subexpr (N));
Conv_N := Convert_To (Target_Base_Type, Duplicate_Subexpr (N));
end if;
-- We make a temporary to hold the value of the converted value
-- (converted to the base type), and then do the test against this
-- temporary. The conversion itself is replaced by an occurrence of
-- Tnn and followed by the explicit range check. Note that checks
-- are suppressed for this code, since we don't want a recursive
-- range check popping up.
-- We make a temporary to hold the value of the conversion to the
-- target base type, and then do the test against this temporary.
-- N itself is replaced by an occurrence of Tnn and followed by
-- the explicit range check.
-- Tnn : constant Target_Base_Type := Target_Base_Type (N);
-- [constraint_error when Tnn not in Target_Type]
-- Tnn
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc),
Constant_Present => True,
Expression => Conv_Node),
Expression => Conv_N),
Make_Raise_Constraint_Error (Loc,
Condition =>
......@@ -6903,7 +6895,7 @@ package body Checks is
Left_Opnd => New_Occurrence_Of (Tnn, Loc),
Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
Reason => Reason)),
Suppress => All_Checks);
Suppress => Suppress);
Rewrite (N, New_Occurrence_Of (Tnn, Loc));
......@@ -6920,7 +6912,7 @@ package body Checks is
-- First special case, if the source type is already within the range
-- of the target type, then no check is needed (probably we should have
-- stopped Do_Range_Check from being set in the first place, but better
-- late than never in preventing junk code and junk flag settings.
-- late than never in preventing junk code and junk flag settings).
if In_Subrange_Of (Source_Type, Target_Type)
......@@ -6997,7 +6989,8 @@ package body Checks is
-- Next test for the case where the target type is within the bounds
-- of the base type of the source type, since in this case we can
-- simply convert these bounds to the base type of T to do the test.
-- simply convert the bounds of the target type to this base bype
-- to do the test.
-- [constraint_error when N not in
-- Source_Base_Type (Target_Type'First)
......@@ -7046,14 +7039,18 @@ package body Checks is
Suppress => All_Checks);
-- For conversions involving at least one type that is not discrete,
-- first convert to target type and then generate the range check.
-- This avoids problems with values that are close to a bound of the
-- target type that would fail a range check when done in a larger
-- source type before converting but would pass if converted with
-- first convert to the target base type and then generate the range
-- check. This avoids problems with values that are close to a bound
-- of the target type that would fail a range check when done in a
-- larger source type before converting but pass if converted with
-- rounding and then checked (such as in float-to-float conversions).
-- Note that overflow checks are not suppressed for this code because
-- we do not know whether the source type is in range of the target
-- base type (unlike in the next case below).
else
Convert_And_Check_Range;
Convert_And_Check_Range (Suppress => Range_Check);
end if;
-- Note that at this stage we know that the Target_Base_Type is not in
......@@ -7062,10 +7059,12 @@ package body Checks is
-- in range of the target base type since we have not checked that case.
-- If that is the case, we can freely convert the source to the target,
-- and then test the target result against the bounds.
-- and then test the target result against the bounds. Note that checks
-- are suppressed for this code, since we don't want a recursive range
-- check popping up.
elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
Convert_And_Check_Range;
Convert_And_Check_Range (Suppress => All_Checks);
-- At this stage, we know that we have two scalar types, which are
-- directly convertible, and where neither scalar type has a base
......
......@@ -30,8 +30,7 @@
****************************************************************************/
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
#include "runtime.h"
#include <sys/stat.h>
#else
#include "config.h"
......
......@@ -53,9 +53,7 @@
#endif
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
#include <sys/stat.h>
#include <string.h>
#else
#include "config.h"
#include "system.h"
......
......@@ -29,11 +29,7 @@
* *
****************************************************************************/
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
#include <sys/stat.h>
#else
#ifndef IN_RTS
#include "config.h"
#include "system.h"
#endif
......
......@@ -421,7 +421,6 @@ package body Einfo is
-- Never_Set_In_Source Flag115
-- Is_Visible_Lib_Unit Flag116
-- Is_Unchecked_Union Flag117
-- Is_For_Access_Subtype Flag118
-- Has_Convention_Pragma Flag119
-- Has_Primitive_Operations Flag120
......@@ -2303,12 +2302,6 @@ package body Einfo is
return Flag70 (Id);
end Is_First_Subtype;
function Is_For_Access_Subtype (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype));
return Flag118 (Id);
end Is_For_Access_Subtype;
function Is_Formal_Subprogram (Id : E) return B is
begin
return Flag111 (Id);
......@@ -5526,12 +5519,6 @@ package body Einfo is
Set_Flag70 (Id, V);
end Set_Is_First_Subtype;
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype));
Set_Flag118 (Id, V);
end Set_Is_For_Access_Subtype;
procedure Set_Is_Formal_Subprogram (Id : E; V : B := True) is
begin
Set_Flag111 (Id, V);
......@@ -9826,7 +9813,6 @@ package body Einfo is
W ("Is_Exported", Flag99 (Id));
W ("Is_Finalized_Transient", Flag252 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id));
W ("Is_Formal_Subprogram", Flag111 (Id));
W ("Is_Frozen", Flag4 (Id));
W ("Is_Generic_Actual_Subprogram", Flag274 (Id));
......
......@@ -2608,12 +2608,6 @@ package Einfo is
-- Is_Formal_Subprogram (Flag111)
-- Defined in all entities. Set for generic formal subprograms.
-- Is_For_Access_Subtype (Flag118)
-- Defined in E_Private_Subtype and E_Record_Subtype entities. Means the
-- sole purpose of the type is to be designated by an Access_Subtype and
-- hence should not be expanded into components because the type may not
-- have been found or frozen yet.
-- Is_Frozen (Flag4)
-- Defined in all type and subtype entities. Set if type or subtype has
-- been frozen.
......@@ -6458,7 +6452,6 @@ package Einfo is
-- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
-- Is_Controlled_Active (Flag42) (base type only)
-- Is_For_Access_Subtype (Flag118) (subtype only)
-- (plus type attributes)
-- E_Procedure
......@@ -7311,7 +7304,6 @@ package Einfo is
function Is_Exported (Id : E) return B;
function Is_Finalized_Transient (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
function Is_Frozen (Id : E) return B;
function Is_Generic_Instance (Id : E) return B;
function Is_Hidden (Id : E) return B;
......@@ -8012,7 +8004,6 @@ package Einfo is
procedure Set_Is_Exported (Id : E; V : B := True);
procedure Set_Is_Finalized_Transient (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
procedure Set_Is_Formal_Subprogram (Id : E; V : B := True);
procedure Set_Is_Frozen (Id : E; V : B := True);
procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True);
......@@ -8859,7 +8850,6 @@ package Einfo is
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Is_Floating_Point_Type);
pragma Inline (Is_For_Access_Subtype);
pragma Inline (Is_Formal);
pragma Inline (Is_Formal_Object);
pragma Inline (Is_Formal_Subprogram);
......@@ -9376,7 +9366,6 @@ package Einfo is
pragma Inline (Set_Is_Exported);
pragma Inline (Set_Is_Finalized_Transient);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
pragma Inline (Set_Is_Formal_Subprogram);
pragma Inline (Set_Is_Frozen);
pragma Inline (Set_Is_Generic_Actual_Subprogram);
......
......@@ -30,15 +30,11 @@
****************************************************************************/
#ifdef IN_RTS
# include "tconfig.h"
# include "tsystem.h"
# include "runtime.h"
# include <stdio.h>
# include <stdlib.h>
# include <string.h>
# include <sys/stat.h>
# include <fcntl.h>
# include <time.h>
# ifdef VMS
# include <unixio.h>
# endif
/* We don't have libiberty, so use malloc. */
# define xmalloc(S) malloc (S)
#else /* IN_RTS */
......@@ -109,89 +105,10 @@ __gnat_getenv (char *name, int *len, char **value)
return;
}
/* VMS specific declarations for set_env_value. */
#ifdef VMS
typedef struct _ile3
{
unsigned short len, code;
__char_ptr32 adr;
__char_ptr32 retlen_adr;
} ile_s;
#endif
void
__gnat_setenv (char *name, char *value)
{
#if defined (VMS)
struct dsc$descriptor_s name_desc;
$DESCRIPTOR (table_desc, "LNM$PROCESS");
char *host_pathspec = value;
char *copy_pathspec;
int num_dirs_in_pathspec = 1;
char *ptr;
long status;
name_desc.dsc$w_length = strlen (name);
name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
name_desc.dsc$b_class = DSC$K_CLASS_S;
name_desc.dsc$a_pointer = name; /* ??? Danger, not 64bit safe. */
if (*host_pathspec == 0)
/* deassign */
{
status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
/* no need to check status; if the logical name is not
defined, that's fine. */
return;
}
ptr = host_pathspec;
while (*ptr++)
if (*ptr == ',')
num_dirs_in_pathspec++;
{
int i, status;
/* Alloca is guaranteed to be 32bit. */
ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
char *curr, *next;
strcpy (copy_pathspec, host_pathspec);
curr = copy_pathspec;
for (i = 0; i < num_dirs_in_pathspec; i++)
{
next = strchr (curr, ',');
if (next == 0)
next = strchr (curr, 0);
*next = 0;
ile_array[i].len = strlen (curr);
/* Code 2 from lnmdef.h means it's a string. */
ile_array[i].code = 2;
ile_array[i].adr = curr;
/* retlen_adr is ignored. */
ile_array[i].retlen_adr = 0;
curr = next + 1;
}
/* Terminating item must be zero. */
ile_array[i].len = 0;
ile_array[i].code = 0;
ile_array[i].adr = 0;
ile_array[i].retlen_adr = 0;
status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
if ((status & 1) != 1)
LIB$SIGNAL (status);
}
#elif (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__)
#if (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__)
setenv (name, value, 1);
#else
......@@ -213,10 +130,7 @@ __gnat_setenv (char *name, char *value)
char **
__gnat_environ (void)
{
#if defined (VMS) || defined (RTX)
/* Not implemented */
return NULL;
#elif defined (__MINGW32__)
#if defined (__MINGW32__)
return _environ;
#elif defined (__sun__)
extern char **_environ;
......@@ -247,10 +161,7 @@ __gnat_environ (void)