mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-05 16:41:02 +08:00
re PR ada/12806 (Program_Error sinput.adb:397)
* sysdep.c: Problem discovered during IA64 VMS port. [VMS] #include <unixio.h> to get proper prototypes. * adaint.c: Issues discovered/problems fixed during IA64 VMS port. [VMS] #define _POSIX_EXIT for proper semantics. [VMS] #include <unixio.h> for proper prototypes. [VMS] (fork): #define IA64 version. (__gnat_os_exit): Remove unnecessary VMS specific code. * 3vtrasym.adb: Minor reformatting Use terminology encoded/decoded name, rather than C++ specific notion of mangling (this is the terminology used throughout GNAT). * einfo.h: Regenerated * einfo.ads, einfo.adb: Add new flag Is_Thread_Body * exp_ch6.adb: (Expand_N_Subprogram_Body): Handle expansion of thread body procedure * par-prag.adb: Add dummy entry for Thread_Body pragma * rtsfind.ads: Add entries for System.Threads entities for thread body processing * sem_attr.adb: (Analyze_Pragma, Access attributes): Check these are not applied to a thread body, since this is not permitted * sem_prag.adb: Add processing for Thread_Body pragma. Minor comment fix. * sem_res.adb: (Resolve_Call): Check for incorrect attempt to call a thread body procedure with a direct call. * snames.ads, snames.adb: Add entry for Thread_Body pragma Add names associated with thread body expansion * snames.h: Add entry for Thread_Body pragma * s-thread.adb: Add entries for thread body processing These are dummy bodies so far * s-thread.ads: Add documentation on thread body handling. Add entries for thread body processing. * sem_ch10.adb: (Build_Limited_Views): Return after posting an error in case of limited with_clause on subprograms, generics, instances or generic renamings (Install_Limited_Withed_Unit): Do nothing in case of limited with_clause on subprograms, generics, instances or generic renamings * raise.c (setup_to_install): Correct mistake in last revision; two arguments out of order. * trans.c, cuintp.c, argv.c, aux-io.c, cal.c, errno.c, exit.c, gnatbl.c, init.c, stringt.h, utils.c, utils2.c: Update copyright notice, missed in previous change. Remove trailing blanks and other style errors introduced in previous change. * decl.c (gnat_to_gnu_field): Adjust the conditions under which we get rid of the wrapper for a LJM type, ensuring we don't do that if the field is addressable. This avoids potential low level type view mismatches later on, for instance in a by-reference argument passing process. * decl.c (gnat_to_gnu_field): No longer check for BLKmode being aligned at byte boundary. * decl.c (components_to_record): Do not delete the empty variants from the end of the union type. * exp_ch4.adb (Expand_N_Op_Eq): Use base type when locating primitive operation for a derived type, an explicit declaration may use a local subtype of Boolean. * make.adb (Gnatmake): Allow main sources on the command line with a library project when it is only for compilation (no binding or linking). Part of PR ada/12806: * ada-tree.h (TYPE_DIGITS_VALUE, SET_TYPE_DIGITS_VALUE): Save count as tree, not integer. * decl.c: (gnat_to_gnu_entity, case E_Floating_Point_Type): Save count as tree, not integer. * targtyps.c, decl.c, misc.c, gigi.h (fp_prec_to_size, fp_size_to_prec): Temporary routines to work around change in FP sizing semantics in GCC. * utils.c: (build_vms_descriptor): TYPE_DIGITS_VALUE is tree, not integer. * gigi.h: (enumerate_modes): New function. * Make-lang.in: (ada/misc.o): Add real.h. * misc.c: (enumerate_modes): New function. From-SVN: r73250
This commit is contained in:
Arnaud Charlet
parent
21e9fc4735
commit
12e0c41c11
@ -97,76 +97,73 @@ package body GNAT.Traceback.Symbolic is
|
||||
Value, Value),
|
||||
User_Act_Proc);
|
||||
|
||||
function Demangle_Ada (Mangled : String) return String;
|
||||
-- Demangles an Ada symbol. Removes leading "_ada_" and trailing
|
||||
function Decode_Ada_Name (Encoded_Name : String) return String;
|
||||
-- Decodes an Ada identifier name. Removes leading "_ada_" and trailing
|
||||
-- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
|
||||
|
||||
---------------------
|
||||
-- Decode_Ada_Name --
|
||||
---------------------
|
||||
|
||||
------------------
|
||||
-- Demangle_Ada --
|
||||
------------------
|
||||
function Decode_Ada_Name (Encoded_Name : String) return String is
|
||||
Decoded_Name : String (1 .. Encoded_Name'Length);
|
||||
Pos : Integer := Encoded_Name'First;
|
||||
Last : Integer := Encoded_Name'Last;
|
||||
DPos : Integer := 1;
|
||||
|
||||
function Demangle_Ada (Mangled : String) return String is
|
||||
Demangled : String (1 .. Mangled'Length);
|
||||
Pos : Integer := Mangled'First;
|
||||
Last : Integer := Mangled'Last;
|
||||
DPos : Integer := 1;
|
||||
begin
|
||||
|
||||
if Pos > Last then
|
||||
return "";
|
||||
end if;
|
||||
|
||||
-- Skip leading _ada_
|
||||
|
||||
if Mangled'Length > 4 and then Mangled (Pos .. Pos + 4) = "_ada_" then
|
||||
if Encoded_Name'Length > 4
|
||||
and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
|
||||
then
|
||||
Pos := Pos + 5;
|
||||
end if;
|
||||
|
||||
-- Skip trailing __{DIGIT}+ or ${DIGIT}+
|
||||
|
||||
if Mangled (Last) in '0' .. '9' then
|
||||
|
||||
if Encoded_Name (Last) in '0' .. '9' then
|
||||
for J in reverse Pos + 2 .. Last - 1 loop
|
||||
|
||||
case Mangled (J) is
|
||||
case Encoded_Name (J) is
|
||||
when '0' .. '9' =>
|
||||
null;
|
||||
when '$' =>
|
||||
Last := J - 1;
|
||||
exit;
|
||||
when '_' =>
|
||||
if Mangled (J - 1) = '_' then
|
||||
if Encoded_Name (J - 1) = '_' then
|
||||
Last := J - 2;
|
||||
end if;
|
||||
exit;
|
||||
when others =>
|
||||
exit;
|
||||
end case;
|
||||
|
||||
end loop;
|
||||
|
||||
end if;
|
||||
|
||||
-- Now just copy Mangled to Demangled, converting "__" to '.' on the fly
|
||||
-- Now just copy encoded name to decoded name, converting "__" to '.'
|
||||
|
||||
while Pos <= Last loop
|
||||
|
||||
if Mangled (Pos) = '_' and then Mangled (Pos + 1) = '_'
|
||||
and then Pos /= Mangled'First then
|
||||
Demangled (DPos) := '.';
|
||||
if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
|
||||
and then Pos /= Encoded_Name'First
|
||||
then
|
||||
Decoded_Name (DPos) := '.';
|
||||
Pos := Pos + 2;
|
||||
|
||||
else
|
||||
Demangled (DPos) := Mangled (Pos);
|
||||
Decoded_Name (DPos) := Encoded_Name (Pos);
|
||||
Pos := Pos + 1;
|
||||
end if;
|
||||
|
||||
DPos := DPos + 1;
|
||||
|
||||
end loop;
|
||||
|
||||
return Demangled (1 .. DPos - 1);
|
||||
end Demangle_Ada;
|
||||
return Decoded_Name (1 .. DPos - 1);
|
||||
end Decode_Ada_Name;
|
||||
|
||||
------------------------
|
||||
-- Symbolic_Traceback --
|
||||
@ -225,7 +222,7 @@ package body GNAT.Traceback.Symbolic is
|
||||
First : Integer := Len + 1;
|
||||
Last : Integer := First + 80 - 1;
|
||||
Pos : Integer;
|
||||
Routine_Name_D : String := Demangle_Ada
|
||||
Routine_Name_D : String := Decode_Ada_Name
|
||||
(To_Ada
|
||||
(Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
|
||||
False));
|
||||
|
||||
@ -1201,7 +1201,7 @@ ada/misc.o : ada/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
|
||||
$(LANGHOOKS_DEF_H) libfuncs.h $(OPTABS_H) ada/ada.h ada/types.h \
|
||||
ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \
|
||||
ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \
|
||||
ada/adadecode.h opts.h options.h target.h
|
||||
ada/adadecode.h opts.h options.h target.h real.h
|
||||
|
||||
ada/targtyps.o : ada/targtyps.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
|
||||
ada/ada.h ada/types.h ada/atree.h ada/nlists.h ada/elists.h ada/uintp.h \
|
||||
|
||||
@ -174,14 +174,14 @@ struct lang_type GTY(())
|
||||
#define TYPE_INDEX_TYPE(NODE) \
|
||||
(&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic)
|
||||
#define SET_TYPE_INDEX_TYPE(NODE, X) \
|
||||
(TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *)(X))
|
||||
(TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *) (X))
|
||||
|
||||
/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the
|
||||
Digits_Value. */
|
||||
#define TYPE_DIGITS_VALUE(NODE) \
|
||||
((long) TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)))
|
||||
#define TYPE_DIGITS_VALUE(NODE) \
|
||||
(&TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))->t.generic)
|
||||
#define SET_TYPE_DIGITS_VALUE(NODE, X) \
|
||||
(TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *)(size_t)(X))
|
||||
(TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) = (struct lang_type *) (X))
|
||||
|
||||
/* For INTEGER_TYPE, stores the RM_Size of the type. */
|
||||
#define TYPE_RM_SIZE_INT(NODE) TYPE_VALUES (INTEGER_TYPE_CHECK (NODE))
|
||||
@ -271,10 +271,9 @@ struct lang_type GTY(())
|
||||
discriminant number. */
|
||||
#define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))
|
||||
|
||||
/* This is a horrible kludge to store the loop_id of a loop into a tree
|
||||
node. We need to find some other place to store it! */
|
||||
/* This is the loop id for a GNAT_LOOP_ID node. */
|
||||
#define TREE_LOOP_ID(NODE) \
|
||||
(((union lang_tree_node *)TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id)
|
||||
((union lang_tree_node *) TREE_CHECK (NODE, GNAT_LOOP_ID))->loop_id.loop_id
|
||||
|
||||
/* Define fields and macros for statements.
|
||||
|
||||
|
||||
@ -50,6 +50,10 @@
|
||||
|
||||
#endif /* VxWorks */
|
||||
|
||||
#ifdef VMS
|
||||
#define _POSIX_EXIT 1
|
||||
#endif
|
||||
|
||||
#ifdef IN_RTS
|
||||
#include "tconfig.h"
|
||||
#include "tsystem.h"
|
||||
@ -57,6 +61,9 @@
|
||||
#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)
|
||||
@ -1463,8 +1470,13 @@ __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
|
||||
|
||||
#ifdef VMS
|
||||
/* Defined in VMS header files. */
|
||||
#if defined (__ALPHA)
|
||||
#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
|
||||
LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
|
||||
LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
|
||||
#elif defined (__IA64)
|
||||
#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
|
||||
LIB$I64_GET_CURR_INVO_CONTEXT(decc$$get_vfork_jmpbuf()) : -1)
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#if defined (sun) && defined (__SVR4)
|
||||
@ -1816,12 +1828,7 @@ __gnat_waitpid (int pid)
|
||||
void
|
||||
__gnat_os_exit (int status)
|
||||
{
|
||||
#ifdef VMS
|
||||
/* Exit without changing 0 to 1. */
|
||||
__posix_exit (status);
|
||||
#else
|
||||
exit (status);
|
||||
#endif
|
||||
}
|
||||
|
||||
/* Locate a regular file, give a Path value. */
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* Copyright (C) 1992-2002 Free Software Foundation, Inc. *
|
||||
* Copyright (C) 1992-2003 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- *
|
||||
@ -83,7 +83,7 @@ __gnat_len_arg (int arg_num)
|
||||
}
|
||||
|
||||
void
|
||||
__gnat_fill_arg ( char *a, int i)
|
||||
__gnat_fill_arg (char *a, int i)
|
||||
{
|
||||
strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
|
||||
}
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
|
||||
* Copyright (C) 1992-2003 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- *
|
||||
@ -52,20 +52,20 @@ void *null_function (void);
|
||||
int c_fileno (FILE *);
|
||||
|
||||
FILE *
|
||||
c_stdin (void)
|
||||
{
|
||||
return stdin;
|
||||
c_stdin (void)
|
||||
{
|
||||
return stdin;
|
||||
}
|
||||
|
||||
FILE *
|
||||
c_stdout (void)
|
||||
{
|
||||
c_stdout (void)
|
||||
{
|
||||
return stdout;
|
||||
}
|
||||
|
||||
FILE *
|
||||
c_stderr (void)
|
||||
{
|
||||
c_stderr (void)
|
||||
{
|
||||
return stderr;
|
||||
}
|
||||
|
||||
@ -75,25 +75,25 @@ c_stderr (void)
|
||||
#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */
|
||||
#endif
|
||||
|
||||
int
|
||||
seek_set_function (void)
|
||||
{
|
||||
return SEEK_SET;
|
||||
int
|
||||
seek_set_function (void)
|
||||
{
|
||||
return SEEK_SET;
|
||||
}
|
||||
|
||||
int
|
||||
seek_end_function (void)
|
||||
{
|
||||
return SEEK_END;
|
||||
int
|
||||
seek_end_function (void)
|
||||
{
|
||||
return SEEK_END;
|
||||
}
|
||||
|
||||
void *null_function (void)
|
||||
{
|
||||
return NULL;
|
||||
void *null_function (void)
|
||||
{
|
||||
return NULL;
|
||||
}
|
||||
|
||||
int
|
||||
c_fileno (FILE *s)
|
||||
{
|
||||
return fileno (s);
|
||||
int
|
||||
c_fileno (FILE *s)
|
||||
{
|
||||
return fileno (s);
|
||||
}
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* Copyright (C) 1992-2002, Free Software Foundation, Inc. *
|
||||
* Copyright (C) 1992-2003, 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- *
|
||||
|
||||
@ -62,7 +62,7 @@ UI_To_gnu (Uint Input, tree type)
|
||||
tree gnu_ret;
|
||||
|
||||
if (Input <= Uint_Direct_Last)
|
||||
gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias,
|
||||
gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias,
|
||||
Input < Uint_Direct_Bias ? -1 : 0));
|
||||
else
|
||||
{
|
||||
|
||||
@ -166,7 +166,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
&& UI_Is_In_Int_Range (Esize (gnat_entity)))
|
||||
? MIN (UI_To_Int (Esize (gnat_entity)),
|
||||
IN (kind, Float_Kind)
|
||||
? LONG_DOUBLE_TYPE_SIZE
|
||||
? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
|
||||
: IN (kind, Access_Kind) ? POINTER_SIZE * 2
|
||||
: LONG_LONG_TYPE_SIZE)
|
||||
: LONG_LONG_TYPE_SIZE);
|
||||
@ -1337,14 +1337,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
gnu_type = make_signed_type (esize);
|
||||
TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
|
||||
SET_TYPE_DIGITS_VALUE (gnu_type,
|
||||
UI_To_Int (Digits_Value (gnat_entity)));
|
||||
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);
|
||||
TYPE_PRECISION (gnu_type) = esize;
|
||||
TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
|
||||
layout_type (gnu_type);
|
||||
break;
|
||||
|
||||
@ -1560,8 +1561,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
tem = gnat_to_gnu_type (Component_Type (gnat_entity));
|
||||
|
||||
/* Get and validate any specified Component_Size, but if Packed,
|
||||
ignore it since the front end will have taken care of it. Also,
|
||||
allow sizes not a multiple of Storage_Unit if packed. */
|
||||
ignore it since the front end will have taken care of it. */
|
||||
gnu_comp_size
|
||||
= validate_size (Component_Size (gnat_entity), tem,
|
||||
gnat_entity,
|
||||
@ -1884,8 +1884,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
}
|
||||
|
||||
/* Get and validate any specified Component_Size, but if Packed,
|
||||
ignore it since the front end will have taken care of it. Also,
|
||||
allow sizes not a multiple of Storage_Unit if packed. */
|
||||
ignore it since the front end will have taken care of it. */
|
||||
gnu_comp_size
|
||||
= validate_size (Component_Size (gnat_entity), gnu_type,
|
||||
gnat_entity,
|
||||
@ -4924,10 +4923,14 @@ gnat_to_gnu_field (Entity_Id gnat_field,
|
||||
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
|
||||
gnat_field, FIELD_DECL, 0, 1);
|
||||
|
||||
/* If the field's type is a left-justified modular type, make the field
|
||||
the type of the inner object unless it is aliases. We don't need
|
||||
the the wrapper here and it can prevent packing. */
|
||||
if (! Is_Aliased (gnat_field) && TREE_CODE (gnu_field_type) == RECORD_TYPE
|
||||
/* If the field's type is left-justified modular, the wrapper can prevent
|
||||
packing so we make the field the type of the inner object unless the
|
||||
situation forbids it. We may not do that when the field is addressable_p,
|
||||
typically because in that case this field may later be passed by-ref for
|
||||
a formal argument expecting the left justification. The condition below
|
||||
is then matching the addressable_p code for COMPONENT_REF. */
|
||||
if (! Is_Aliased (gnat_field) && flag_strict_aliasing
|
||||
&& TREE_CODE (gnu_field_type) == RECORD_TYPE
|
||||
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
|
||||
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
|
||||
|
||||
@ -5050,17 +5053,6 @@ gnat_to_gnu_field (Entity_Id gnat_field,
|
||||
|
||||
if (Is_Atomic (gnat_field))
|
||||
check_ok_for_atomic (gnu_field_type, gnat_field, 0);
|
||||
|
||||
if (gnu_pos != 0 && TYPE_MODE (gnu_field_type) == BLKmode
|
||||
&& (! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
|
||||
bitsize_unit_node)))
|
||||
&& TYPE_MODE (gnu_field_type) == BLKmode)
|
||||
{
|
||||
post_error_ne ("fields of& must start at storage unit boundary",
|
||||
First_Bit (Component_Clause (gnat_field)),
|
||||
Etype (gnat_field));
|
||||
gnu_pos = 0;
|
||||
}
|
||||
}
|
||||
|
||||
/* If the record has rep clauses and this is the tag field, make a rep
|
||||
@ -5072,17 +5064,6 @@ gnat_to_gnu_field (Entity_Id gnat_field,
|
||||
gnu_size = TYPE_SIZE (gnu_field_type);
|
||||
}
|
||||
|
||||
/* If a size is specified and this is a BLKmode field, it must be an
|
||||
integral number of bytes. */
|
||||
if (gnu_size != 0 && TYPE_MODE (gnu_field_type) == BLKmode
|
||||
&& ! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size,
|
||||
bitsize_unit_node)))
|
||||
{
|
||||
post_error_ne ("size of fields of& must be multiple of a storage unit",
|
||||
gnat_field, Etype (gnat_field));
|
||||
gnu_pos = gnu_size = 0;
|
||||
}
|
||||
|
||||
/* We need to make the size the maximum for the type if it is
|
||||
self-referential and an unconstrained type. In that case, we can't
|
||||
pack the field since we can't make a copy to align it. */
|
||||
@ -5341,11 +5322,11 @@ components_to_record (tree gnu_record_type,
|
||||
gnu_variant_list = gnu_field;
|
||||
}
|
||||
|
||||
/* We can delete any empty variants from the end. This may leave none
|
||||
left. Note we cannot delete variants from anywhere else. */
|
||||
while (gnu_variant_list != 0
|
||||
&& TYPE_FIELDS (TREE_TYPE (gnu_variant_list)) == 0)
|
||||
gnu_variant_list = TREE_CHAIN (gnu_variant_list);
|
||||
/* We use to delete the empty variants from the end. However,
|
||||
we no longer do that because we need them to generate complete
|
||||
debugging information for the variant record. Otherwise,
|
||||
the union type definition will be missing the fields associated
|
||||
to these empty variants. */
|
||||
|
||||
/* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
|
||||
if (gnu_variant_list != 0)
|
||||
|
||||
@ -302,6 +302,7 @@ package body Einfo is
|
||||
-- Is_CPP_Class Flag74
|
||||
-- Has_Non_Standard_Rep Flag75
|
||||
-- Is_Constructor Flag76
|
||||
-- Is_Thread_Body Flag77
|
||||
-- Is_Tag Flag78
|
||||
-- Has_All_Calls_Remote Flag79
|
||||
-- Is_Constr_Subt_For_U_Nominal Flag80
|
||||
@ -420,7 +421,6 @@ package body Einfo is
|
||||
|
||||
-- Remaining flags are currently unused and available
|
||||
|
||||
-- (unused) Flag77
|
||||
-- (unused) Flag136
|
||||
-- (unused) Flag183
|
||||
|
||||
@ -1640,6 +1640,11 @@ package body Einfo is
|
||||
return Flag55 (Id);
|
||||
end Is_Tagged_Type;
|
||||
|
||||
function Is_Thread_Body (Id : E) return B is
|
||||
begin
|
||||
return Flag77 (Id);
|
||||
end Is_Thread_Body;
|
||||
|
||||
function Is_True_Constant (Id : E) return B is
|
||||
begin
|
||||
return Flag163 (Id);
|
||||
@ -3581,6 +3586,11 @@ package body Einfo is
|
||||
Set_Flag55 (Id, V);
|
||||
end Set_Is_Tagged_Type;
|
||||
|
||||
procedure Set_Is_Thread_Body (Id : E; V : B := True) is
|
||||
begin
|
||||
Set_Flag77 (Id, V);
|
||||
end Set_Is_Thread_Body;
|
||||
|
||||
procedure Set_Is_True_Constant (Id : E; V : B := True) is
|
||||
begin
|
||||
Set_Flag163 (Id, V);
|
||||
@ -6199,6 +6209,7 @@ package body Einfo is
|
||||
W ("Is_Statically_Allocated", Flag28 (Id));
|
||||
W ("Is_Tag", Flag78 (Id));
|
||||
W ("Is_Tagged_Type", Flag55 (Id));
|
||||
W ("Is_Thread_Body", Flag77 (Id));
|
||||
W ("Is_True_Constant", Flag163 (Id));
|
||||
W ("Is_Unchecked_Union", Flag117 (Id));
|
||||
W ("Is_Unsigned_Type", Flag144 (Id));
|
||||
|
||||
@ -2276,6 +2276,10 @@ package Einfo is
|
||||
-- Is_Task_Type (synthesized)
|
||||
-- Applies to all entities, true for task types and subtypes
|
||||
|
||||
-- Is_Thread_Body (Flag77)
|
||||
-- Applies to subprogram entities. Set if a valid Thread_Body pragma
|
||||
-- applies to this subprogram, which is thus a thread body.
|
||||
|
||||
-- Is_True_Constant (Flag163)
|
||||
-- This flag is set in constants and variables which have an initial
|
||||
-- value specified but which are never assigned, partially or in the
|
||||
@ -4252,6 +4256,7 @@ package Einfo is
|
||||
-- Is_Overriding_Operation (Flag39) (non-generic case only)
|
||||
-- Is_Private_Descendant (Flag53)
|
||||
-- Is_Pure (Flag44)
|
||||
-- Is_Thread_Body (Flag77) (non-generic case only)
|
||||
-- Is_Visible_Child_Unit (Flag116)
|
||||
-- Needs_No_Actuals (Flag22)
|
||||
-- Return_Present (Flag54)
|
||||
@ -4496,6 +4501,7 @@ package Einfo is
|
||||
-- Is_Overriding_Operation (Flag39) (non-generic case only)
|
||||
-- Is_Private_Descendant (Flag53)
|
||||
-- Is_Pure (Flag44)
|
||||
-- Is_Thread_Body (Flag77) (non-generic case only)
|
||||
-- Is_Valued_Procedure (Flag127)
|
||||
-- Is_Visible_Child_Unit (Flag116)
|
||||
-- Needs_No_Actuals (Flag22)
|
||||
@ -5117,6 +5123,7 @@ package Einfo is
|
||||
function Is_Statically_Allocated (Id : E) return B;
|
||||
function Is_Tag (Id : E) return B;
|
||||
function Is_Tagged_Type (Id : E) return B;
|
||||
function Is_Thread_Body (Id : E) return B;
|
||||
function Is_True_Constant (Id : E) return B;
|
||||
function Is_Unchecked_Union (Id : E) return B;
|
||||
function Is_Unsigned_Type (Id : E) return B;
|
||||
@ -5589,6 +5596,7 @@ package Einfo is
|
||||
procedure Set_Is_Statically_Allocated (Id : E; V : B := True);
|
||||
procedure Set_Is_Tag (Id : E; V : B := True);
|
||||
procedure Set_Is_Tagged_Type (Id : E; V : B := True);
|
||||
procedure Set_Is_Thread_Body (Id : E; V : B := True);
|
||||
procedure Set_Is_True_Constant (Id : E; V : B := True);
|
||||
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
|
||||
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
|
||||
@ -6111,6 +6119,7 @@ package Einfo is
|
||||
pragma Inline (Is_Subprogram);
|
||||
pragma Inline (Is_Tag);
|
||||
pragma Inline (Is_Tagged_Type);
|
||||
pragma Inline (Is_Thread_Body);
|
||||
pragma Inline (Is_True_Constant);
|
||||
pragma Inline (Is_Task_Type);
|
||||
pragma Inline (Is_Type);
|
||||
@ -6418,6 +6427,7 @@ package Einfo is
|
||||
pragma Inline (Set_Is_Statically_Allocated);
|
||||
pragma Inline (Set_Is_Tag);
|
||||
pragma Inline (Set_Is_Tagged_Type);
|
||||
pragma Inline (Set_Is_Thread_Body);
|
||||
pragma Inline (Set_Is_True_Constant);
|
||||
pragma Inline (Set_Is_Unchecked_Union);
|
||||
pragma Inline (Set_Is_Unsigned_Type);
|
||||
|
||||
@ -450,6 +450,7 @@
|
||||
INLINE B Is_Statically_Allocated (E Id);
|
||||
INLINE B Is_Tag (E Id);
|
||||
INLINE B Is_Tagged_Type (E Id);
|
||||
INLINE B Is_Thread_Body (E Id);
|
||||
INLINE B Is_True_Constant (E Id);
|
||||
INLINE B Is_Unchecked_Union (E Id);
|
||||
INLINE B Is_Unsigned_Type (E Id);
|
||||
@ -1438,6 +1439,9 @@
|
||||
INLINE B Is_Tagged_Type (E Id)
|
||||
{ return Flag55 (Id); }
|
||||
|
||||
INLINE B Is_Thread_Body (E Id)
|
||||
{ return Flag77 (Id); }
|
||||
|
||||
INLINE B Is_True_Constant (E Id)
|
||||
{ return Flag163 (Id); }
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
|
||||
* Copyright (C) 1992-2003 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- *
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
|
||||
* Copyright (C) 1992-2003 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- *
|
||||
|
||||
@ -3713,7 +3713,8 @@ package body Exp_Ch4 is
|
||||
exit when Chars (Node (Prim)) = Name_Op_Eq
|
||||
and then Etype (First_Formal (Node (Prim))) =
|
||||
Etype (Next_Formal (First_Formal (Node (Prim))))
|
||||
and then Etype (Node (Prim)) = Standard_Boolean;
|
||||
and then
|
||||
Base_Type (Etype (Node (Prim))) = Standard_Boolean;
|
||||
|
||||
Next_Elmt (Prim);
|
||||
pragma Assert (Present (Prim));
|
||||
|
||||
@ -59,12 +59,14 @@ with Sem_Ch12; use Sem_Ch12;
|
||||
with Sem_Ch13; use Sem_Ch13;
|
||||
with Sem_Disp; use Sem_Disp;
|
||||
with Sem_Dist; use Sem_Dist;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Tbuild; use Tbuild;
|
||||
with Ttypes; use Ttypes;
|
||||
with Uintp; use Uintp;
|
||||
with Validsw; use Validsw;
|
||||
|
||||
@ -2849,6 +2851,8 @@ package body Exp_Ch6 is
|
||||
|
||||
-- Reset Pure indication if any parameter has root type System.Address
|
||||
|
||||
-- Wrap thread body
|
||||
|
||||
procedure Expand_N_Subprogram_Body (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
H : constant Node_Id := Handled_Statement_Sequence (N);
|
||||
@ -2866,6 +2870,9 @@ package body Exp_Ch6 is
|
||||
-- the latter test is not critical, it does not matter if we add a
|
||||
-- few extra returns, since they get eliminated anyway later on.
|
||||
|
||||
procedure Expand_Thread_Body;
|
||||
-- Perform required expansion of a thread body
|
||||
|
||||
----------------
|
||||
-- Add_Return --
|
||||
----------------
|
||||
@ -2882,6 +2889,165 @@ package body Exp_Ch6 is
|
||||
end if;
|
||||
end Add_Return;
|
||||
|
||||
------------------------
|
||||
-- Expand_Thread_Body --
|
||||
------------------------
|
||||
|
||||
-- The required expansion of a thread body is as follows
|
||||
|
||||
-- procedure <thread body procedure name> is
|
||||
|
||||
-- _Secondary_Stack : aliased
|
||||
-- Storage_Elements.Storage_Array
|
||||
-- (1 .. Storage_Offset (Sec_Stack_Size));
|
||||
-- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
|
||||
|
||||
-- _Process_ATSD : aliased System.Threads.ATSD;
|
||||
|
||||
-- begin
|
||||
-- System.Threads.Thread_Body_Enter;
|
||||
-- (_Secondary_Stack'Address,
|
||||
-- _Secondary_Stack'Length,
|
||||
-- _Process_ATSD'Address);
|
||||
|
||||
-- declare
|
||||
-- <user declarations>
|
||||
-- begin
|
||||
-- <user statements>
|
||||
-- <user exception handlers>
|
||||
-- end;
|
||||
|
||||
-- System.Threads.Thread_Body_Leave;
|
||||
|
||||
-- exception
|
||||
-- when E : others =>
|
||||
-- System.Threads.Thread_Body_Exceptional_Exit (E);
|
||||
-- end;
|
||||
|
||||
-- Note the exception handler is omitted if pragma Restriction
|
||||
-- No_Exception_Handlers is currently active.
|
||||
|
||||
procedure Expand_Thread_Body is
|
||||
User_Decls : constant List_Id := Declarations (N);
|
||||
Sec_Stack_Len : Node_Id;
|
||||
|
||||
TB_Pragma : constant Node_Id :=
|
||||
Get_Rep_Pragma (Spec_Id, Name_Thread_Body);
|
||||
|
||||
Ent_SS : Entity_Id;
|
||||
Ent_ATSD : Entity_Id;
|
||||
Ent_EO : Entity_Id;
|
||||
|
||||
Decl_SS : Node_Id;
|
||||
Decl_ATSD : Node_Id;
|
||||
|
||||
Excep_Handlers : List_Id;
|
||||
|
||||
begin
|
||||
-- Get proper setting for secondary stack size
|
||||
|
||||
if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
|
||||
Sec_Stack_Len :=
|
||||
Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
|
||||
else
|
||||
Sec_Stack_Len :=
|
||||
Make_Integer_Literal (Loc,
|
||||
Intval =>
|
||||
Expr_Value
|
||||
(Expression (RTE (RE_Default_Secondary_Stack_Size))));
|
||||
end if;
|
||||
|
||||
Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
|
||||
|
||||
-- Build and set declarations for the wrapped thread body
|
||||
|
||||
Ent_SS := Make_Defining_Identifier (Loc, Name_uSecondary_Stack);
|
||||
Ent_ATSD := Make_Defining_Identifier (Loc, Name_uProcess_ATSD);
|
||||
|
||||
Decl_SS :=
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Ent_SS,
|
||||
Aliased_Present => True,
|
||||
Object_Definition =>
|
||||
Make_Subtype_Indication (Loc,
|
||||
Subtype_Mark =>
|
||||
New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
|
||||
Constraint =>
|
||||
Make_Index_Or_Discriminant_Constraint (Loc,
|
||||
Constraints => New_List (
|
||||
Make_Range (Loc,
|
||||
Low_Bound => Make_Integer_Literal (Loc, 1),
|
||||
High_Bound => Sec_Stack_Len)))));
|
||||
|
||||
Decl_ATSD :=
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Ent_ATSD,
|
||||
Aliased_Present => True,
|
||||
Object_Definition => New_Occurrence_Of (RTE (RE_ATSD), Loc));
|
||||
|
||||
Set_Declarations (N, New_List (Decl_SS, Decl_ATSD));
|
||||
Analyze (Decl_SS);
|
||||
Analyze (Decl_ATSD);
|
||||
Set_Alignment (Ent_SS, UI_From_Int (Maximum_Alignment));
|
||||
|
||||
-- Create new exception handler
|
||||
|
||||
if Restrictions (No_Exception_Handlers) then
|
||||
Excep_Handlers := No_List;
|
||||
|
||||
else
|
||||
Check_Restriction (No_Exception_Handlers, N);
|
||||
|
||||
Ent_EO := Make_Defining_Identifier (Loc, Name_uE);
|
||||
|
||||
Excep_Handlers := New_List (
|
||||
Make_Exception_Handler (Loc,
|
||||
Choice_Parameter => Ent_EO,
|
||||
Exception_Choices => New_List (
|
||||
Make_Others_Choice (Loc)),
|
||||
Statements => New_List (
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of
|
||||
(RTE (RE_Thread_Body_Exceptional_Exit), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
New_Occurrence_Of (Ent_EO, Loc))))));
|
||||
end if;
|
||||
|
||||
-- Now build new handled statement sequence and analyze it
|
||||
|
||||
Set_Handled_Statement_Sequence (N,
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => New_List (
|
||||
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Occurrence_Of (RTE (RE_Thread_Body_Enter), Loc),
|
||||
Parameter_Associations => New_List (
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Ent_SS, Loc),
|
||||
Attribute_Name => Name_Address),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Ent_SS, Loc),
|
||||
Attribute_Name => Name_Length),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Ent_ATSD, Loc),
|
||||
Attribute_Name => Name_Address))),
|
||||
|
||||
Make_Block_Statement (Loc,
|
||||
Declarations => User_Decls,
|
||||
Handled_Statement_Sequence => H),
|
||||
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Occurrence_Of (RTE (RE_Thread_Body_Leave), Loc))),
|
||||
|
||||
Exception_Handlers => Excep_Handlers));
|
||||
|
||||
Analyze (Handled_Statement_Sequence (N));
|
||||
end Expand_Thread_Body;
|
||||
|
||||
-- Start of processing for Expand_N_Subprogram_Body
|
||||
|
||||
begin
|
||||
@ -3150,6 +3316,12 @@ package body Exp_Ch6 is
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Deal with thread body
|
||||
|
||||
if Is_Thread_Body (Spec_Id) then
|
||||
Expand_Thread_Body;
|
||||
end if;
|
||||
|
||||
-- If the subprogram does not have pending instantiations, then we
|
||||
-- must generate the subprogram descriptor now, since the code for
|
||||
-- the subprogram is complete, and this is our last chance. However
|
||||
|
||||
@ -570,7 +570,7 @@ extern tree create_param_decl (tree, tree, int);
|
||||
|
||||
INLINE_FLAG, PUBLIC_FLAG, and EXTERN_FLAG are used to set the appropriate
|
||||
fields in the FUNCTION_DECL. */
|
||||
extern tree create_subprog_decl (tree, tree, tree, tree, int, int, int,
|
||||
extern tree create_subprog_decl (tree, tree, tree, tree, int, int, int,
|
||||
struct attrib *);
|
||||
|
||||
/* Returns a LABEL_DECL node for LABEL_NAME. */
|
||||
@ -721,6 +721,25 @@ extern tree fill_vms_descriptor (tree, Entity_Id);
|
||||
should not be allocated in a register. Return true if successful. */
|
||||
extern bool gnat_mark_addressable (tree);
|
||||
|
||||
/* This function is called by the front end to enumerate all the supported
|
||||
modes for the machine. We pass a function which is called back with
|
||||
the following integer parameters:
|
||||
|
||||
FLOAT_P nonzero if this represents a floating-point mode
|
||||
COMPLEX_P nonzero is this represents a complex mode
|
||||
COUNT count of number of items, nonzero for vector mode
|
||||
PRECISION number of bits in data representation
|
||||
MANTISSA number of bits in mantissa, if FP and known, else zero.
|
||||
SIZE number of bits used to store data
|
||||
ALIGN number of bits to which mode is aligned. */
|
||||
extern void enumerate_modes (void (*f) (int, int, int, int, int, int,
|
||||
unsigned int));
|
||||
|
||||
/* These are temporary function to deal with recent GCC changes related to
|
||||
FP type sizes and precisions. */
|
||||
extern int fp_prec_to_size (int);
|
||||
extern int fp_size_to_prec (int);
|
||||
|
||||
/* These functions return the basic data type sizes and related parameters
|
||||
about the target machine. */
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* C Implementation File *
|
||||
* *
|
||||
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
|
||||
* Copyright (C) 1992-2003 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- *
|
||||
@ -289,7 +289,7 @@ main (int argc, char **argv)
|
||||
{
|
||||
if (done_an_ali)
|
||||
{
|
||||
fprintf (stderr,
|
||||
fprintf (stderr,
|
||||
"Sorry - cannot handle more than one ALI file\n");
|
||||
exit (1);
|
||||
}
|
||||
@ -323,7 +323,7 @@ main (int argc, char **argv)
|
||||
exit (retcode);
|
||||
}
|
||||
}
|
||||
else
|
||||
else
|
||||
addarg (argv[i]);
|
||||
}
|
||||
#ifdef MSDOS
|
||||
|
||||
@ -82,17 +82,17 @@ extern struct Machine_State *(*Get_Machine_State_Addr) (void);
|
||||
|
||||
#define Check_Abort_Status \
|
||||
system__soft_links__check_abort_status
|
||||
extern int (*Check_Abort_Status) (void);
|
||||
extern int (*Check_Abort_Status) (void);
|
||||
|
||||
#define Raise_From_Signal_Handler \
|
||||
ada__exceptions__raise_from_signal_handler
|
||||
extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
|
||||
extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
|
||||
|
||||
#define Propagate_Signal_Exception \
|
||||
__gnat_propagate_sig_exc
|
||||
extern void Propagate_Signal_Exception (struct Machine_State *,
|
||||
struct Exception_Data *,
|
||||
const char *);
|
||||
extern void Propagate_Signal_Exception (struct Machine_State *,
|
||||
struct Exception_Data *,
|
||||
const char *);
|
||||
|
||||
/* Copies of global values computed by the binder */
|
||||
int __gl_main_priority = -1;
|
||||
|
||||
@ -3363,7 +3363,10 @@ package body Make is
|
||||
-- cannot be specified on the command line.
|
||||
|
||||
if Osint.Number_Of_Files /= 0 then
|
||||
if Projects.Table (Main_Project).Library then
|
||||
if Projects.Table (Main_Project).Library
|
||||
and then not Unique_Compile
|
||||
and then ((not Make_Steps) or else Bind_Only or else Link_Only)
|
||||
then
|
||||
Make_Failed ("cannot specify a main program " &
|
||||
"on the command line for a library project file");
|
||||
|
||||
|
||||
118
gcc/ada/misc.c
118
gcc/ada/misc.c
@ -39,6 +39,7 @@
|
||||
#include "coretypes.h"
|
||||
#include "tm.h"
|
||||
#include "tree.h"
|
||||
#include "real.h"
|
||||
#include "rtl.h"
|
||||
#include "errors.h"
|
||||
#include "diagnostic.h"
|
||||
@ -146,7 +147,7 @@ static void gnat_adjust_rli (record_layout_info);
|
||||
|
||||
const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
|
||||
|
||||
/* Tables describing GCC tree codes used only by GNAT.
|
||||
/* Tables describing GCC tree codes used only by GNAT.
|
||||
|
||||
Table indexed by tree code giving a string containing a character
|
||||
classifying the tree code. Possibilities are
|
||||
@ -272,7 +273,7 @@ gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
|
||||
|
||||
case OPT_gant:
|
||||
warning ("`-gnat' misspelled as `-gant'");
|
||||
|
||||
|
||||
/* ... fall through ... */
|
||||
|
||||
case OPT_gnat:
|
||||
@ -283,7 +284,7 @@ gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
|
||||
gnat_argc++;
|
||||
|
||||
if (arg[0] == 'O')
|
||||
for (i = 1; i < save_argc - 1; i++)
|
||||
for (i = 1; i < save_argc - 1; i++)
|
||||
if (!strncmp (save_argv[i], "-gnatO", 6))
|
||||
if (save_argv[++i][0] != '-')
|
||||
{
|
||||
@ -304,8 +305,8 @@ static unsigned int
|
||||
gnat_init_options (unsigned int argc, const char **argv)
|
||||
{
|
||||
/* Initialize gnat_argv with save_argv size. */
|
||||
gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
|
||||
gnat_argv[0] = xstrdup (argv[0]); /* name of the command */
|
||||
gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
|
||||
gnat_argv[0] = xstrdup (argv[0]); /* name of the command */
|
||||
gnat_argc = 1;
|
||||
|
||||
save_argc = argc;
|
||||
@ -706,7 +707,7 @@ static int
|
||||
gnat_eh_type_covers (tree a, tree b)
|
||||
{
|
||||
/* a catches b if they represent the same exception id or if a
|
||||
is an "others".
|
||||
is an "others".
|
||||
|
||||
??? integer_zero_node for "others" is hardwired in too many places
|
||||
currently. */
|
||||
@ -886,3 +887,108 @@ must_pass_by_ref (tree gnu_type)
|
||||
|| (TYPE_SIZE (gnu_type) != 0
|
||||
&& TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
|
||||
}
|
||||
|
||||
/* This function is called by the front end to enumerate all the supported
|
||||
modes for the machine. We pass a function which is called back with
|
||||
the following integer parameters:
|
||||
|
||||
FLOAT_P nonzero if this represents a floating-point mode
|
||||
COMPLEX_P nonzero is this represents a complex mode
|
||||
COUNT count of number of items, nonzero for vector mode
|
||||
PRECISION number of bits in data representation
|
||||
MANTISSA number of bits in mantissa, if FP and known, else zero.
|
||||
SIZE number of bits used to store data
|
||||
ALIGN number of bits to which mode is aligned. */
|
||||
|
||||
void
|
||||
enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
|
||||
{
|
||||
enum machine_mode i;
|
||||
|
||||
for (i = 0; i < NUM_MACHINE_MODES; i++)
|
||||
{
|
||||
enum machine_mode j;
|
||||
bool float_p = 0;
|
||||
bool complex_p = 0;
|
||||
bool vector_p = 0;
|
||||
bool skip_p = 0;
|
||||
int mantissa = 0;
|
||||
enum machine_mode inner_mode = i;
|
||||
|
||||
switch (GET_MODE_CLASS (i))
|
||||
{
|
||||
case MODE_INT:
|
||||
break;
|
||||
case MODE_FLOAT:
|
||||
float_p = 1;
|
||||
break;
|
||||
case MODE_COMPLEX_INT:
|
||||
complex_p = 1;
|
||||
inner_mode = GET_MODE_INNER (i);
|
||||
break;
|
||||
case MODE_COMPLEX_FLOAT:
|
||||
float_p = 1;
|
||||
complex_p = 1;
|
||||
inner_mode = GET_MODE_INNER (i);
|
||||
break;
|
||||
case MODE_VECTOR_INT:
|
||||
vector_p = 1;
|
||||
inner_mode = GET_MODE_INNER (i);
|
||||
break;
|
||||
case MODE_VECTOR_FLOAT:
|
||||
float_p = 1;
|
||||
vector_p = 1;
|
||||
inner_mode = GET_MODE_INNER (i);
|
||||
break;
|
||||
default:
|
||||
skip_p = 1;
|
||||
}
|
||||
|
||||
/* Skip this mode if it's one the front end doesn't need to know about
|
||||
(e.g., the CC modes) or if there is no add insn for that mode (or
|
||||
any wider mode), meaning it is not supported by the hardware. If
|
||||
this a complex or vector mode, we care about the inner mode. */
|
||||
for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
|
||||
if (add_optab->handlers[j].insn_code != CODE_FOR_nothing)
|
||||
break;
|
||||
|
||||
if (float_p)
|
||||
{
|
||||
const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
|
||||
|
||||
mantissa = fmt->p * fmt->log2_b;
|
||||
}
|
||||
|
||||
if (!skip_p && j != VOIDmode)
|
||||
(*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
|
||||
GET_MODE_BITSIZE (i), mantissa,
|
||||
GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
fp_prec_to_size (int prec)
|
||||
{
|
||||
enum machine_mode mode;
|
||||
|
||||
for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
|
||||
mode = GET_MODE_WIDER_MODE (mode))
|
||||
if (GET_MODE_BITSIZE (mode) == prec)
|
||||
return GET_MODE_SIZE (mode) * BITS_PER_UNIT;
|
||||
|
||||
abort ();
|
||||
}
|
||||
|
||||
int
|
||||
fp_size_to_prec (int size)
|
||||
{
|
||||
enum machine_mode mode;
|
||||
|
||||
for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
|
||||
mode = GET_MODE_WIDER_MODE (mode))
|
||||
if (GET_MODE_SIZE (mode) * BITS_PER_UNIT == size)
|
||||
return GET_MODE_BITSIZE (mode);
|
||||
|
||||
abort ();
|
||||
}
|
||||
|
||||
|
||||
@ -980,6 +980,7 @@ begin
|
||||
Pragma_Task_Info |
|
||||
Pragma_Task_Name |
|
||||
Pragma_Task_Storage |
|
||||
Pragma_Thread_Body |
|
||||
Pragma_Time_Slice |
|
||||
Pragma_Title |
|
||||
Pragma_Unchecked_Union |
|
||||
|
||||
@ -940,8 +940,8 @@ get_action_description_for (_Unwind_Context *uw_context,
|
||||
static void
|
||||
setup_to_install (_Unwind_Context *uw_context,
|
||||
_Unwind_Exception *uw_exception,
|
||||
int uw_filter,
|
||||
_Unwind_Ptr uw_landing_pad)
|
||||
_Unwind_Ptr uw_landing_pad,
|
||||
int uw_filter)
|
||||
{
|
||||
#ifndef EH_RETURN_DATA_REGNO
|
||||
/* We should not be called if the appropriate underlying support is not
|
||||
|
||||
@ -298,6 +298,7 @@ package Rtsfind is
|
||||
System_String_Ops_Concat_5,
|
||||
System_Task_Info,
|
||||
System_Tasking,
|
||||
System_Threads,
|
||||
System_Unsigned_Types,
|
||||
System_Val_Bool,
|
||||
System_Val_Char,
|
||||
@ -1034,6 +1035,7 @@ package Rtsfind is
|
||||
RE_IS_Ilf, -- System.Scalar_Values
|
||||
RE_IS_Ill, -- System.Scalar_Values
|
||||
|
||||
RE_Default_Secondary_Stack_Size, -- System.Secondary_Stack
|
||||
RE_Mark_Id, -- System.Secondary_Stack
|
||||
RE_SS_Allocate, -- System.Secondary_Stack
|
||||
RE_SS_Pool, -- System.Secondary_Stack
|
||||
@ -1164,6 +1166,11 @@ package Rtsfind is
|
||||
RE_Get_GNAT_Exception, -- System.Soft_Links
|
||||
RE_Update_Exception, -- System.Soft_Links
|
||||
|
||||
RE_ATSD, -- System.Threads
|
||||
RE_Thread_Body_Enter, -- System.Threads
|
||||
RE_Thread_Body_Exceptional_Exit, -- System.Threads
|
||||
RE_Thread_Body_Leave, -- System.Threads
|
||||
|
||||
RE_Bits_1, -- System.Unsigned_Types
|
||||
RE_Bits_2, -- System.Unsigned_Types
|
||||
RE_Bits_4, -- System.Unsigned_Types
|
||||
@ -1968,6 +1975,7 @@ package Rtsfind is
|
||||
RE_IS_Ilf => System_Scalar_Values,
|
||||
RE_IS_Ill => System_Scalar_Values,
|
||||
|
||||
RE_Default_Secondary_Stack_Size => System_Secondary_Stack,
|
||||
RE_Mark_Id => System_Secondary_Stack,
|
||||
RE_SS_Allocate => System_Secondary_Stack,
|
||||
RE_SS_Mark => System_Secondary_Stack,
|
||||
@ -2098,6 +2106,11 @@ package Rtsfind is
|
||||
RE_Get_GNAT_Exception => System_Soft_Links,
|
||||
RE_Update_Exception => System_Soft_Links,
|
||||
|
||||
RE_ATSD => System_Threads,
|
||||
RE_Thread_Body_Enter => System_Threads,
|
||||
RE_Thread_Body_Exceptional_Exit => System_Threads,
|
||||
RE_Thread_Body_Leave => System_Threads,
|
||||
|
||||
RE_Bits_1 => System_Unsigned_Types,
|
||||
RE_Bits_2 => System_Unsigned_Types,
|
||||
RE_Bits_4 => System_Unsigned_Types,
|
||||
|
||||
@ -43,6 +43,8 @@ package body System.Threads is
|
||||
function From_Address is
|
||||
new Unchecked_Conversion (Address, ATSD_Access);
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
-- Get_Current_Excep --
|
||||
-----------------------
|
||||
@ -98,4 +100,41 @@ package body System.Threads is
|
||||
CTSD.Sec_Stack_Addr := Addr;
|
||||
end Set_Sec_Stack_Addr;
|
||||
|
||||
-----------------------
|
||||
-- Thread_Body_Enter --
|
||||
-----------------------
|
||||
|
||||
procedure Thread_Body_Enter
|
||||
(Sec_Stack_Address : System.Address;
|
||||
Sec_Stack_Size : Natural;
|
||||
Process_ATSD_Address : System.Address)
|
||||
is
|
||||
pragma Unreferenced (Sec_Stack_Address);
|
||||
pragma Unreferenced (Sec_Stack_Size);
|
||||
pragma Unreferenced (Process_ATSD_Address);
|
||||
begin
|
||||
null;
|
||||
end Thread_Body_Enter;
|
||||
|
||||
----------------------------------
|
||||
-- Thread_Body_Exceptional_Exit --
|
||||
----------------------------------
|
||||
|
||||
procedure Thread_Body_Exceptional_Exit
|
||||
(EO : Ada.Exceptions.Exception_Occurrence)
|
||||
is
|
||||
pragma Unreferenced (EO);
|
||||
begin
|
||||
null;
|
||||
end Thread_Body_Exceptional_Exit;
|
||||
|
||||
-----------------------
|
||||
-- Thread_Body_Leave --
|
||||
-----------------------
|
||||
|
||||
procedure Thread_Body_Leave is
|
||||
begin
|
||||
null;
|
||||
end Thread_Body_Leave;
|
||||
|
||||
end System.Threads;
|
||||
|
||||
@ -48,7 +48,7 @@ package System.Threads is
|
||||
|
||||
type ATSD_Access is access ATSD;
|
||||
|
||||
-- Get/Set for the attributes of the current thread.
|
||||
-- Get/Set for the attributes of the current thread
|
||||
|
||||
function Get_Jmpbuf_Address return Address;
|
||||
pragma Inline (Get_Jmpbuf_Address);
|
||||
@ -65,6 +65,73 @@ package System.Threads is
|
||||
function Get_Current_Excep return EOA;
|
||||
pragma Inline (Get_Current_Excep);
|
||||
|
||||
--------------------------
|
||||
-- Thread Body Handling --
|
||||
--------------------------
|
||||
|
||||
-- The subprograms in this section are called by the expansion of a
|
||||
-- subprogram body to which a Thread_Body pragma has been applied:
|
||||
|
||||
-- Given a subprogram body
|
||||
|
||||
-- procedure xyz (params ....) is -- can also be a function
|
||||
-- <user declarations>
|
||||
-- begin
|
||||
-- <user statements>
|
||||
-- <user exception handlers>
|
||||
-- end xyz;
|
||||
|
||||
-- The expansion resulting from use of the Thread_Body pragma is:
|
||||
|
||||
-- procedure xyz (params ...) is
|
||||
|
||||
-- _Secondary_Stack : aliased
|
||||
-- Storage_Elements.Storage_Array
|
||||
-- (1 .. Storage_Offset (Sec_Stack_Size));
|
||||
-- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
|
||||
|
||||
-- _Process_ATSD : aliased System.Threads.ATSD;
|
||||
|
||||
-- begin
|
||||
-- System.Threads.Thread_Body_Enter;
|
||||
-- (_Secondary_Stack'Address,
|
||||
-- _Secondary_Stack'Length,
|
||||
-- _Process_ATSD'Address);
|
||||
|
||||
-- declare
|
||||
-- <user declarations>
|
||||
-- begin
|
||||
-- <user statements>
|
||||
-- <user exception handlers>
|
||||
-- end;
|
||||
|
||||
-- System.Threads.Thread_Body_Leave;
|
||||
|
||||
-- exception
|
||||
-- when E : others =>
|
||||
-- System.Threads.Thread_Body_Exceptional_Exit (E);
|
||||
-- end;
|
||||
|
||||
-- Note the exception handler is omitted if pragma Restriction
|
||||
-- No_Exception_Handlers is currently active.
|
||||
|
||||
-- Note: the secondary stack size (Sec_Stack_Size) comes either from
|
||||
-- the pragma, if specified, or is the default value taken from
|
||||
-- the declaration in System.Secondary_Stack.
|
||||
|
||||
procedure Thread_Body_Enter
|
||||
(Sec_Stack_Address : System.Address;
|
||||
Sec_Stack_Size : Natural;
|
||||
Process_ATSD_Address : System.Address);
|
||||
-- Enter thread body, see above for details
|
||||
|
||||
procedure Thread_Body_Leave;
|
||||
-- Leave thread body (normally), see above for details
|
||||
|
||||
procedure Thread_Body_Exceptional_Exit
|
||||
(EO : Ada.Exceptions.Exception_Occurrence);
|
||||
-- Leave thread body (abnormally on exception), see above for details
|
||||
|
||||
private
|
||||
|
||||
------------------------
|
||||
|
||||
@ -372,8 +372,8 @@ package body Sem_Attr is
|
||||
----------------------------------
|
||||
|
||||
procedure Build_Access_Subprogram_Type (P : Node_Id) is
|
||||
Index : Interp_Index;
|
||||
It : Interp;
|
||||
Index : Interp_Index;
|
||||
It : Interp;
|
||||
|
||||
function Get_Kind (E : Entity_Id) return Entity_Kind;
|
||||
-- Distinguish between access to regular and protected
|
||||
@ -395,6 +395,10 @@ package body Sem_Attr is
|
||||
-- Start of processing for Build_Access_Subprogram_Type
|
||||
|
||||
begin
|
||||
-- In the case of an access to subprogram, use the name of the
|
||||
-- subprogram itself as the designated type. Type-checking in
|
||||
-- this case compares the signatures of the designated types.
|
||||
|
||||
if not Is_Overloaded (P) then
|
||||
Acc_Type :=
|
||||
New_Internal_Entity
|
||||
@ -408,7 +412,6 @@ package body Sem_Attr is
|
||||
Set_Etype (N, Any_Type);
|
||||
|
||||
while Present (It.Nam) loop
|
||||
|
||||
if not Is_Intrinsic_Subprogram (It.Nam) then
|
||||
Acc_Type :=
|
||||
New_Internal_Entity
|
||||
@ -437,17 +440,20 @@ package body Sem_Attr is
|
||||
("prefix of % attribute cannot be enumeration literal", P);
|
||||
end if;
|
||||
|
||||
-- In the case of an access to subprogram, use the name of the
|
||||
-- subprogram itself as the designated type. Type-checking in
|
||||
-- this case compares the signatures of the designated types.
|
||||
-- Case of access to subprogram
|
||||
|
||||
if Is_Entity_Name (P)
|
||||
and then Is_Overloadable (Entity (P))
|
||||
then
|
||||
-- Not allowed for nested subprograms if No_Implicit_Dynamic_Code
|
||||
-- restriction set (since in general a trampoline is required).
|
||||
|
||||
if not Is_Library_Level_Entity (Entity (P)) then
|
||||
Check_Restriction (No_Implicit_Dynamic_Code, P);
|
||||
end if;
|
||||
|
||||
-- Build the appropriate subprogram type
|
||||
|
||||
Build_Access_Subprogram_Type (P);
|
||||
|
||||
-- For unrestricted access, kill current values, since this
|
||||
@ -460,7 +466,7 @@ package body Sem_Attr is
|
||||
|
||||
return;
|
||||
|
||||
-- Component is an operation of a protected type.
|
||||
-- Component is an operation of a protected type
|
||||
|
||||
elsif Nkind (P) = N_Selected_Component
|
||||
and then Is_Overloadable (Entity (Selector_Name (P)))
|
||||
@ -6406,7 +6412,6 @@ package body Sem_Attr is
|
||||
end if;
|
||||
|
||||
if Is_Entity_Name (P) then
|
||||
|
||||
if Is_Overloaded (P) then
|
||||
Get_First_Interp (P, Index, It);
|
||||
|
||||
@ -6437,19 +6442,18 @@ package body Sem_Attr is
|
||||
Resolve (P);
|
||||
end if;
|
||||
|
||||
Error_Msg_Name_1 := Aname;
|
||||
|
||||
if not Is_Entity_Name (P) then
|
||||
null;
|
||||
|
||||
elsif Is_Abstract (Entity (P))
|
||||
and then Is_Overloadable (Entity (P))
|
||||
then
|
||||
Error_Msg_Name_1 := Aname;
|
||||
Error_Msg_N ("prefix of % attribute cannot be abstract", P);
|
||||
Set_Etype (N, Any_Type);
|
||||
|
||||
elsif Convention (Entity (P)) = Convention_Intrinsic then
|
||||
Error_Msg_Name_1 := Aname;
|
||||
|
||||
if Ekind (Entity (P)) = E_Enumeration_Literal then
|
||||
Error_Msg_N
|
||||
("prefix of % attribute cannot be enumeration literal",
|
||||
@ -6460,6 +6464,10 @@ package body Sem_Attr is
|
||||
end if;
|
||||
|
||||
Set_Etype (N, Any_Type);
|
||||
|
||||
elsif Is_Thread_Body (Entity (P)) then
|
||||
Error_Msg_N
|
||||
("prefix of % attribute cannot be a thread body", P);
|
||||
end if;
|
||||
|
||||
-- Assignments, return statements, components of aggregates,
|
||||
|
||||
@ -3233,8 +3233,7 @@ package body Sem_Ch10 is
|
||||
Unum : Unit_Number_Type :=
|
||||
Get_Source_Unit (Library_Unit (N));
|
||||
P_Unit : Entity_Id := Unit (Library_Unit (N));
|
||||
P : Entity_Id :=
|
||||
Defining_Unit_Name (Specification (P_Unit));
|
||||
P : Entity_Id;
|
||||
Lim_Elmt : Elmt_Id;
|
||||
Lim_Typ : Entity_Id;
|
||||
Is_Child_Package : Boolean := False;
|
||||
@ -3261,6 +3260,33 @@ package body Sem_Ch10 is
|
||||
-- Start of processing for Install_Limited_Withed_Unit
|
||||
|
||||
begin
|
||||
-- In case of limited with_clause on subprograms, generics, instances,
|
||||
-- or generic renamings, the corresponding error was previously posted
|
||||
-- and we have nothing to do here.
|
||||
|
||||
case Nkind (P_Unit) is
|
||||
|
||||
when N_Package_Declaration =>
|
||||
null;
|
||||
|
||||
when N_Subprogram_Declaration |
|
||||
N_Generic_Package_Declaration |
|
||||
N_Generic_Subprogram_Declaration |
|
||||
N_Package_Instantiation |
|
||||
N_Function_Instantiation |
|
||||
N_Procedure_Instantiation |
|
||||
N_Generic_Package_Renaming_Declaration |
|
||||
N_Generic_Procedure_Renaming_Declaration |
|
||||
N_Generic_Function_Renaming_Declaration =>
|
||||
return;
|
||||
|
||||
when others =>
|
||||
pragma Assert (False);
|
||||
null;
|
||||
end case;
|
||||
|
||||
P := Defining_Unit_Name (Specification (P_Unit));
|
||||
|
||||
if Nkind (P) = N_Defining_Program_Unit_Name then
|
||||
|
||||
-- Retrieve entity of child package
|
||||
@ -3803,23 +3829,27 @@ package body Sem_Ch10 is
|
||||
when N_Subprogram_Declaration =>
|
||||
Error_Msg_N ("subprograms not allowed in "
|
||||
& "limited with_clauses", N);
|
||||
return;
|
||||
|
||||
when N_Generic_Package_Declaration |
|
||||
N_Generic_Subprogram_Declaration =>
|
||||
Error_Msg_N ("generics not allowed in "
|
||||
& "limited with_clauses", N);
|
||||
return;
|
||||
|
||||
when N_Package_Instantiation |
|
||||
N_Function_Instantiation |
|
||||
N_Procedure_Instantiation =>
|
||||
Error_Msg_N ("generic instantiations not allowed in "
|
||||
& "limited with_clauses", N);
|
||||
return;
|
||||
|
||||
when N_Generic_Package_Renaming_Declaration |
|
||||
N_Generic_Procedure_Renaming_Declaration |
|
||||
N_Generic_Function_Renaming_Declaration =>
|
||||
Error_Msg_N ("generic renamings not allowed in "
|
||||
& "limited with_clauses", N);
|
||||
return;
|
||||
|
||||
when others =>
|
||||
pragma Assert (False);
|
||||
|
||||
@ -9082,6 +9082,80 @@ package body Sem_Prag is
|
||||
end if;
|
||||
end Task_Storage;
|
||||
|
||||
-----------------
|
||||
-- Thread_Body --
|
||||
-----------------
|
||||
|
||||
-- pragma Thread_Body
|
||||
-- ( [Entity =>] LOCAL_NAME
|
||||
-- [,[Secondary_Stack_Size =>] static_integer_EXPRESSION]);
|
||||
|
||||
when Pragma_Thread_Body => Thread_Body : declare
|
||||
Id : Node_Id;
|
||||
SS : Node_Id;
|
||||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
GNAT_Pragma;
|
||||
Check_At_Least_N_Arguments (1);
|
||||
Check_At_Most_N_Arguments (2);
|
||||
Check_Optional_Identifier (Arg1, Name_Entity);
|
||||
Check_Arg_Is_Local_Name (Arg1);
|
||||
|
||||
Id := Expression (Arg1);
|
||||
|
||||
if not Is_Entity_Name (Id)
|
||||
or else not Is_Subprogram (Entity (Id))
|
||||
then
|
||||
Error_Pragma_Arg ("subprogram name required", Arg1);
|
||||
end if;
|
||||
|
||||
E := Entity (Id);
|
||||
|
||||
-- Go to renamed subprogram if present, since Thread_Body applies
|
||||
-- to the actual renamed entity, not to the renaming entity.
|
||||
|
||||
if Present (Alias (E))
|
||||
and then Nkind (Parent (Declaration_Node (E))) =
|
||||
N_Subprogram_Renaming_Declaration
|
||||
then
|
||||
E := Alias (E);
|
||||
end if;
|
||||
|
||||
-- Various error checks
|
||||
|
||||
if Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body then
|
||||
Error_Pragma
|
||||
("pragma% requires separate spec and must come before body");
|
||||
|
||||
elsif Rep_Item_Too_Early (E, N)
|
||||
or else
|
||||
Rep_Item_Too_Late (E, N)
|
||||
then
|
||||
raise Pragma_Exit;
|
||||
|
||||
elsif Is_Thread_Body (E) then
|
||||
Error_Pragma_Arg
|
||||
("only one thread body pragma allowed", Arg1);
|
||||
|
||||
elsif Present (Homonym (E))
|
||||
and then Scope (Homonym (E)) = Current_Scope
|
||||
then
|
||||
Error_Pragma_Arg
|
||||
("thread body subprogram must not be overloaded", Arg1);
|
||||
end if;
|
||||
|
||||
Set_Is_Thread_Body (E);
|
||||
|
||||
-- Deal with secondary stack argument
|
||||
|
||||
if Arg_Count = 2 then
|
||||
Check_Optional_Identifier (Arg2, Name_Secondary_Stack_Size);
|
||||
SS := Expression (Arg2);
|
||||
Analyze_And_Resolve (SS, Any_Integer);
|
||||
end if;
|
||||
end Thread_Body;
|
||||
|
||||
----------------
|
||||
-- Time_Slice --
|
||||
----------------
|
||||
@ -9812,6 +9886,7 @@ package body Sem_Prag is
|
||||
Pragma_Task_Info => -1,
|
||||
Pragma_Task_Name => -1,
|
||||
Pragma_Task_Storage => 0,
|
||||
Pragma_Thread_Body => +2,
|
||||
Pragma_Time_Slice => -1,
|
||||
Pragma_Title => -1,
|
||||
Pragma_Unchecked_Union => -1,
|
||||
|
||||
@ -3315,7 +3315,6 @@ package body Sem_Res is
|
||||
-- dereference made explicit in Analyze_Call.
|
||||
|
||||
if Ekind (Etype (Subp)) = E_Subprogram_Type then
|
||||
|
||||
if not Is_Overloaded (Subp) then
|
||||
Nam := Etype (Subp);
|
||||
|
||||
@ -3423,6 +3422,12 @@ package body Sem_Res is
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Cannot call thread body directly
|
||||
|
||||
if Is_Thread_Body (Nam) then
|
||||
Error_Msg_N ("cannot call thread body directly", N);
|
||||
end if;
|
||||
|
||||
-- If the subprogram is not global, then kill all checks. This is
|
||||
-- a bit conservative, since in many cases we could do better, but
|
||||
-- it is not worth the effort. Similarly, we kill constant values.
|
||||
|
||||
1984
gcc/ada/snames.adb
1984
gcc/ada/snames.adb
File diff suppressed because it is too large
Load Diff
2825
gcc/ada/snames.ads
2825
gcc/ada/snames.ads
File diff suppressed because it is too large
Load Diff
@ -326,21 +326,22 @@ extern unsigned char Get_Pragma_Id (int);
|
||||
#define Pragma_Task_Info 124
|
||||
#define Pragma_Task_Name 125
|
||||
#define Pragma_Task_Storage 126
|
||||
#define Pragma_Time_Slice 127
|
||||
#define Pragma_Title 128
|
||||
#define Pragma_Unchecked_Union 129
|
||||
#define Pragma_Unimplemented_Unit 130
|
||||
#define Pragma_Unreferenced 131
|
||||
#define Pragma_Unreserve_All_Interrupts 132
|
||||
#define Pragma_Volatile 133
|
||||
#define Pragma_Volatile_Components 134
|
||||
#define Pragma_Weak_External 135
|
||||
#define Pragma_Thread_Body 127
|
||||
#define Pragma_Time_Slice 128
|
||||
#define Pragma_Title 129
|
||||
#define Pragma_Unchecked_Union 130
|
||||
#define Pragma_Unimplemented_Unit 131
|
||||
#define Pragma_Unreferenced 132
|
||||
#define Pragma_Unreserve_All_Interrupts 133
|
||||
#define Pragma_Volatile 134
|
||||
#define Pragma_Volatile_Components 135
|
||||
#define Pragma_Weak_External 136
|
||||
|
||||
/* The following are deliberately out of alphabetical order, see Snames */
|
||||
|
||||
#define Pragma_AST_Entry 136
|
||||
#define Pragma_Storage_Size 137
|
||||
#define Pragma_Storage_Unit 138
|
||||
#define Pragma_AST_Entry 137
|
||||
#define Pragma_Storage_Size 138
|
||||
#define Pragma_Storage_Unit 139
|
||||
|
||||
/* Define the numeric values for the conventions. */
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* C Header File *
|
||||
* *
|
||||
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
|
||||
* Copyright (C) 1992-2003 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- *
|
||||
@ -26,23 +26,23 @@
|
||||
|
||||
/* This file is the C file that corresponds to the Ada package spec
|
||||
Stringt. It was created manually from stringt.ads and stringt.adb
|
||||
|
||||
|
||||
Note: only the access functions are provided, since the tree transformer
|
||||
is not allowed to modify the tree or its auxiliary structures.
|
||||
|
||||
|
||||
This package contains routines for handling the strings table which is
|
||||
used to store string constants encountered in the source, and also those
|
||||
additional string constants generated by compile time concatenation and
|
||||
other similar processing.
|
||||
|
||||
|
||||
A string constant in this table consists of a series of Char_Code values,
|
||||
so that 16-bit character codes can be properly handled if this feature is
|
||||
implemented in the scanner.
|
||||
|
||||
|
||||
There is no guarantee that hashing is used in the implementation. This
|
||||
means that the caller cannot count on having the same Id value for two
|
||||
identical strings stored separately.
|
||||
|
||||
|
||||
The String_Id values reference entries in the Strings table, which
|
||||
contains String_Entry records that record the length of each stored string
|
||||
and its starting location in the String_Chars table. */
|
||||
|
||||
@ -45,6 +45,9 @@
|
||||
#include <fcntl.h>
|
||||
#include <sys/stat.h>
|
||||
#include "time.h"
|
||||
#ifdef VMS
|
||||
#include <unixio.h>
|
||||
#endif
|
||||
#else
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
|
||||
@ -120,21 +120,22 @@ get_target_long_long_size (void)
|
||||
Pos
|
||||
get_target_float_size (void)
|
||||
{
|
||||
return FLOAT_TYPE_SIZE;
|
||||
return fp_prec_to_size (FLOAT_TYPE_SIZE);
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_double_size (void)
|
||||
{
|
||||
return DOUBLE_TYPE_SIZE;
|
||||
return fp_prec_to_size (DOUBLE_TYPE_SIZE);
|
||||
}
|
||||
|
||||
Pos
|
||||
get_target_long_double_size (void)
|
||||
{
|
||||
return WIDEST_HARDWARE_FP_SIZE;
|
||||
return fp_prec_to_size (WIDEST_HARDWARE_FP_SIZE);
|
||||
}
|
||||
|
||||
|
||||
Pos
|
||||
get_target_pointer_size (void)
|
||||
{
|
||||
|
||||
@ -4406,7 +4406,7 @@ static void
|
||||
process_decls (List_Id gnat_decls,
|
||||
List_Id gnat_decls2,
|
||||
Node_Id gnat_end_list,
|
||||
int pass1p,
|
||||
int pass1p,
|
||||
int pass2p)
|
||||
{
|
||||
List_Id gnat_decl_array[2];
|
||||
|
||||
@ -2306,7 +2306,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
|
||||
case INTEGER_TYPE:
|
||||
case ENUMERAL_TYPE:
|
||||
if (TYPE_VAX_FLOATING_POINT_P (type))
|
||||
switch ((int) TYPE_DIGITS_VALUE (type))
|
||||
switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
|
||||
{
|
||||
case 6:
|
||||
dtype = 10;
|
||||
@ -2346,7 +2346,7 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
|
||||
case COMPLEX_TYPE:
|
||||
if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
|
||||
&& TYPE_VAX_FLOATING_POINT_P (type))
|
||||
switch ((int) TYPE_DIGITS_VALUE (type))
|
||||
switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
|
||||
{
|
||||
case 6:
|
||||
dtype = 12;
|
||||
@ -2544,7 +2544,8 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
|
||||
/* Utility routine for above code to make a field. */
|
||||
|
||||
static tree
|
||||
make_descriptor_field (const char *name, tree type, tree rec_type, tree initial)
|
||||
make_descriptor_field (const char *name, tree type,
|
||||
tree rec_type, tree initial)
|
||||
{
|
||||
tree field
|
||||
= create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
|
||||
|
||||
@ -153,8 +153,8 @@ known_alignment (tree exp)
|
||||
We always compute a type_alignment value and return the MAX of it
|
||||
compared with what we get from the expression tree. Just set the
|
||||
type_alignment value to 0 when the type information is to be ignored. */
|
||||
type_alignment
|
||||
= ((POINTER_TYPE_P (TREE_TYPE (exp))
|
||||
type_alignment
|
||||
= ((POINTER_TYPE_P (TREE_TYPE (exp))
|
||||
&& ! TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
|
||||
? TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))) : 0);
|
||||
|
||||
@ -165,7 +165,7 @@ known_alignment (tree exp)
|
||||
case NON_LVALUE_EXPR:
|
||||
/* Conversions between pointers and integers don't change the alignment
|
||||
of the underlying object. */
|
||||
this_alignment = known_alignment (TREE_OPERAND (exp, 0));
|
||||
this_alignment = known_alignment (TREE_OPERAND (exp, 0));
|
||||
break;
|
||||
|
||||
case PLUS_EXPR:
|
||||
@ -357,7 +357,7 @@ compare_arrays (tree result_type, tree a1, tree a2)
|
||||
tree comparison, this_a1_is_null, this_a2_is_null;
|
||||
|
||||
/* If the length of the first array is a constant, swap our operands
|
||||
unless the length of the second array is the constant zero.
|
||||
unless the length of the second array is the constant zero.
|
||||
Note that we have set the `length' values to the length - 1. */
|
||||
if (TREE_CODE (length1) == INTEGER_CST
|
||||
&& ! integer_zerop (fold (build (PLUS_EXPR, bt, length2,
|
||||
@ -406,7 +406,7 @@ compare_arrays (tree result_type, tree a1, tree a2)
|
||||
nbt = get_base_type (TREE_TYPE (ub1));
|
||||
|
||||
comparison
|
||||
= build_binary_op (EQ_EXPR, result_type,
|
||||
= build_binary_op (EQ_EXPR, result_type,
|
||||
build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
|
||||
build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
|
||||
|
||||
@ -491,7 +491,7 @@ compare_arrays (tree result_type, tree a1, tree a2)
|
||||
modulus. */
|
||||
|
||||
static tree
|
||||
nonbinary_modular_operation (enum tree_code op_code,
|
||||
nonbinary_modular_operation (enum tree_code op_code,
|
||||
tree type,
|
||||
tree lhs,
|
||||
tree rhs)
|
||||
@ -591,8 +591,8 @@ nonbinary_modular_operation (enum tree_code op_code,
|
||||
have to do here is validate the work done by SEM and handle subtypes. */
|
||||
|
||||
tree
|
||||
build_binary_op (enum tree_code op_code,
|
||||
tree result_type,
|
||||
build_binary_op (enum tree_code op_code,
|
||||
tree result_type,
|
||||
tree left_operand,
|
||||
tree right_operand)
|
||||
{
|
||||
@ -937,7 +937,7 @@ build_binary_op (enum tree_code op_code,
|
||||
gigi_abort (505);
|
||||
}
|
||||
|
||||
/* If we are comparing a fat pointer against zero, we need to
|
||||
/* If we are comparing a fat pointer against zero, we need to
|
||||
just compare the data pointer. */
|
||||
else if (TYPE_FAT_POINTER_P (left_base_type)
|
||||
&& TREE_CODE (right_operand) == CONSTRUCTOR
|
||||
@ -1651,7 +1651,7 @@ build_simple_component_ref (tree record_variable,
|
||||
if (DECL_INTERNAL_P (new_field))
|
||||
{
|
||||
tree field_ref
|
||||
= build_simple_component_ref (record_variable,
|
||||
= build_simple_component_ref (record_variable,
|
||||
NULL_TREE, new_field, no_fold_p);
|
||||
ref = build_simple_component_ref (field_ref, NULL_TREE, field,
|
||||
no_fold_p);
|
||||
@ -1731,7 +1731,7 @@ build_call_alloc_dealloc (tree gnu_obj,
|
||||
|
||||
if (Present (gnat_proc))
|
||||
{
|
||||
/* The storage pools are obviously always tagged types, but the
|
||||
/* The storage pools are obviously always tagged types, but the
|
||||
secondary stack uses the same mechanism and is not tagged */
|
||||
if (Is_Tagged_Type (Etype (gnat_pool)))
|
||||
{
|
||||
@ -1763,7 +1763,7 @@ build_call_alloc_dealloc (tree gnu_obj,
|
||||
convert (gnu_size_type, gnu_size)));
|
||||
gnu_args
|
||||
= chainon (gnu_args,
|
||||
build_tree_list (NULL_TREE,
|
||||
build_tree_list (NULL_TREE,
|
||||
convert (gnu_size_type, gnu_align)));
|
||||
|
||||
gnu_call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
|
||||
@ -1776,7 +1776,7 @@ build_call_alloc_dealloc (tree gnu_obj,
|
||||
else
|
||||
{
|
||||
/* The size is the second parameter */
|
||||
Entity_Id gnat_size_type
|
||||
Entity_Id gnat_size_type
|
||||
= Etype (Next_Formal (First_Formal (gnat_proc)));
|
||||
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
|
||||
tree gnu_proc = gnat_to_gnu (gnat_proc);
|
||||
@ -1998,7 +1998,7 @@ build_allocator (tree type,
|
||||
return convert (result_type, result);
|
||||
}
|
||||
|
||||
/* Fill in a VMS descriptor for EXPR and return a constructor for it.
|
||||
/* Fill in a VMS descriptor for EXPR and return a constructor for it.
|
||||
GNAT_FORMAL is how we find the descriptor record. */
|
||||
|
||||
tree
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user