Skip to content

R
riscv-gcc-1
Commit 68c989b0 by Arnaud Charlet
Options

Moved to gcc-interface. 

From-SVN: r138260
parent 54dfd46b
Showing with 0 additions and 5044 deletions
gcc/ada/ada-tree.def deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* GNAT-SPECIFIC GCC TREE CODES *
* *
* Specification *
* *
* Copyright (C) 1992-2007, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* ware Foundation; either version 3, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License along with GCC; see the file COPYING3. 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. *
* *
****************************************************************************/
/* A type that is an unconstrained array itself. This node is never passed
to GCC. TREE_TYPE is the type of the fat pointer and TYPE_OBJECT_RECORD_TYPE
is the type of a record containing the template and data. */
DEFTREECODE (UNCONSTRAINED_ARRAY_TYPE, "unconstrained_array_type", tcc_type, 0)
/* A reference to an unconstrained array. This node only exists as an
intermediate node during the translation of a GNAT tree to a GCC tree;
it is never passed to GCC. The only field used is operand 0, which
is the fat pointer object. */
DEFTREECODE (UNCONSTRAINED_ARRAY_REF, "unconstrained_array_ref",
tcc_reference, 1)
/* An expression that returns an RTL suitable for its type. Operand 0
is an expression to be evaluated for side effects only. */
DEFTREECODE (NULL_EXPR, "null_expr", tcc_expression, 1)
/* Same as ADDR_EXPR, except that if the operand represents a bit field,
return the address of the byte containing the bit. This is used
for the 'Address attribute and never shows up in the tree. */
DEFTREECODE (ATTR_ADDR_EXPR, "attr_addr_expr", tcc_reference, 1)
/* Here are the tree codes for the statement types known to Ada. These
must be at the end of this file to allow IS_ADA_STMT to work. */
/* This is how record_code_position and insert_code_for work. The former
makes this tree node, whose operand is a statement. The latter inserts
the actual statements into this node. Gimplification consists of
just returning the inner statement. */
DEFTREECODE (STMT_STMT, "stmt_stmt", tcc_statement, 1)
/* A loop. LOOP_STMT_TOP_COND and LOOP_STMT_BOT_COND are the tests to exit a
loop at the top and bottom, respectively. LOOP_STMT_UPDATE is the statement
to update the loop iterator at the continue point. LOOP_STMT_BODY are the
statements in the body of the loop. LOOP_STMT_LABEL points to the LABEL_DECL
of the end label of the loop. */
DEFTREECODE (LOOP_STMT, "loop_stmt", tcc_statement, 5)
/* Conditionally exit a loop. EXIT_STMT_COND is the condition, which, if
true, will cause the loop to be exited. If no condition is specified,
the loop is unconditionally exited. EXIT_STMT_LABEL is the end label
corresponding to the loop to exit. */
DEFTREECODE (EXIT_STMT, "exit_stmt", tcc_statement, 2)
/* A exception region. REGION_STMT_BODY is the statement to be executed
inside the region. REGION_STMT_HANDLE is a statement that represents
the exception handlers (usually a BLOCK_STMT of HANDLE_STMTs).
REGION_STMT_BLOCK is the BLOCK node for the declarative region, if any. */
DEFTREECODE (REGION_STMT, "region_stmt", tcc_statement, 3)
/* An exception handler. HANDLER_STMT_ARG is the value to pass to
expand_start_catch, HANDLER_STMT_LIST is the list of statements for the
handler itself, and HANDLER_STMT_BLOCK is the BLOCK node for this
binding. */
DEFTREECODE (HANDLER_STMT, "handler_stmt", tcc_statement, 3)
gcc/ada/ada-tree.h deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* A D A - T R E E *
* *
* C Header File *
* *
* Copyright (C) 1992-2008, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* ware Foundation; either version 3, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License along with GCC; see the file COPYING3. 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. *
* *
****************************************************************************/
/* Ada uses the lang_decl and lang_type fields to hold a tree. */
union lang_tree_node
GTY((desc ("0"),
chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.t)")))
{
union tree_node GTY((tag ("0"))) t;
};
struct lang_decl GTY(()) {tree t; };
struct lang_type GTY(()) {tree t; };
/* Define macros to get and set the tree in TYPE_ and DECL_LANG_SPECIFIC. */
#define GET_TYPE_LANG_SPECIFIC(NODE) \
(TYPE_LANG_SPECIFIC (NODE) ? TYPE_LANG_SPECIFIC (NODE)->t : NULL_TREE)
#define SET_TYPE_LANG_SPECIFIC(NODE, X) \
(TYPE_LANG_SPECIFIC (NODE) \
= (TYPE_LANG_SPECIFIC (NODE) \
? TYPE_LANG_SPECIFIC (NODE) : GGC_NEW (struct lang_type))) \
->t = X;
#define GET_DECL_LANG_SPECIFIC(NODE) \
(DECL_LANG_SPECIFIC (NODE) ? DECL_LANG_SPECIFIC (NODE)->t : NULL_TREE)
#define SET_DECL_LANG_SPECIFIC(NODE, VALUE) \
(DECL_LANG_SPECIFIC (NODE) \
= (DECL_LANG_SPECIFIC (NODE) \
? DECL_LANG_SPECIFIC (NODE) : GGC_NEW (struct lang_decl))) \
->t = VALUE;
/* Flags added to GCC type nodes. */
/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is a
record being used as a fat pointer (only true for RECORD_TYPE). */
#define TYPE_IS_FAT_POINTER_P(NODE) \
TYPE_LANG_FLAG_0 (RECORD_OR_UNION_CHECK (NODE))
#define TYPE_FAT_POINTER_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_IS_FAT_POINTER_P (NODE))
/* For integral types and array types, nonzero if this is a packed array type
used for bit-packed types. Such types should not be extended to a larger
size or validated against a specified size. */
#define TYPE_PACKED_ARRAY_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE)
#define TYPE_IS_PACKED_ARRAY_TYPE_P(NODE) \
((TREE_CODE (NODE) == INTEGER_TYPE || TREE_CODE (NODE) == ARRAY_TYPE) \
&& TYPE_PACKED_ARRAY_TYPE_P (NODE))
/* For INTEGER_TYPE, nonzero if this is a modular type with a modulus that
is not equal to two to the power of its mode's size. */
#define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (INTEGER_TYPE_CHECK (NODE))
/* For ARRAY_TYPE, nonzero if this type corresponds to a dimension of
an Ada array other than the first. */
#define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE))
/* For FUNCTION_TYPE, nonzero if this denotes a function returning an
unconstrained array or record. */
#define TYPE_RETURNS_UNCONSTRAINED_P(NODE) \
TYPE_LANG_FLAG_1 (FUNCTION_TYPE_CHECK (NODE))
/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes
a justified modular type (will only be true for RECORD_TYPE). */
#define TYPE_JUSTIFIED_MODULAR_P(NODE) \
TYPE_LANG_FLAG_1 (RECORD_OR_UNION_CHECK (NODE))
/* Nonzero in an arithmetic subtype if this is a subtype not known to the
front-end. */
#define TYPE_EXTRA_SUBTYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE)
/* Nonzero for composite types if this is a by-reference type. */
#define TYPE_BY_REFERENCE_P(NODE) TYPE_LANG_FLAG_2 (NODE)
/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the
type for an object whose type includes its template in addition to
its value (only true for RECORD_TYPE). */
#define TYPE_CONTAINS_TEMPLATE_P(NODE) \
TYPE_LANG_FLAG_3 (RECORD_OR_UNION_CHECK (NODE))
/* For INTEGER_TYPE, nonzero if this really represents a VAX
floating-point type. */
#define TYPE_VAX_FLOATING_POINT_P(NODE) \
TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE))
/* True if NODE is a thin pointer. */
#define TYPE_THIN_POINTER_P(NODE) \
(POINTER_TYPE_P (NODE) \
&& TREE_CODE (TREE_TYPE (NODE)) == RECORD_TYPE \
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (NODE)))
/* True if TYPE is either a fat or thin pointer to an unconstrained
array. */
#define TYPE_FAT_OR_THIN_POINTER_P(NODE) \
(TYPE_FAT_POINTER_P (NODE) || TYPE_THIN_POINTER_P (NODE))
/* For INTEGER_TYPEs, nonzero if the type has a biased representation. */
#define TYPE_BIASED_REPRESENTATION_P(NODE) \
TYPE_LANG_FLAG_4 (INTEGER_TYPE_CHECK (NODE))
/* For ARRAY_TYPEs, nonzero if the array type has Convention_Fortran. */
#define TYPE_CONVENTION_FORTRAN_P(NODE) \
TYPE_LANG_FLAG_4 (ARRAY_TYPE_CHECK (NODE))
/* For FUNCTION_TYPEs, nonzero if the function returns by reference. */
#define TYPE_RETURNS_BY_REF_P(NODE) \
TYPE_LANG_FLAG_4 (FUNCTION_TYPE_CHECK (NODE))
/* For VOID_TYPE, ENUMERAL_TYPE, UNION_TYPE, and RECORD_TYPE, nonzero if this
is a dummy type, made to correspond to a private or incomplete type. */
#define TYPE_DUMMY_P(NODE) TYPE_LANG_FLAG_4 (NODE)
/* True if TYPE is such a dummy type. */
#define TYPE_IS_DUMMY_P(NODE) \
((TREE_CODE (NODE) == VOID_TYPE || TREE_CODE (NODE) == RECORD_TYPE \
|| TREE_CODE (NODE) == UNION_TYPE || TREE_CODE (NODE) == ENUMERAL_TYPE) \
&& TYPE_DUMMY_P (NODE))
/* For FUNCTION_TYPEs, nonzero if function returns by being passed a pointer
to a place to store its result. */
#define TYPE_RETURNS_BY_TARGET_PTR_P(NODE) \
TYPE_LANG_FLAG_5 (FUNCTION_TYPE_CHECK (NODE))
/* For an INTEGER_TYPE, nonzero if TYPE_ACTUAL_BOUNDS is present. */
#define TYPE_HAS_ACTUAL_BOUNDS_P(NODE) \
TYPE_LANG_FLAG_5 (INTEGER_TYPE_CHECK (NODE))
/* For a RECORD_TYPE, nonzero if this was made just to supply needed
padding or alignment. */
#define TYPE_IS_PADDING_P(NODE) TYPE_LANG_FLAG_5 (RECORD_TYPE_CHECK (NODE))
/* True if TYPE can alias any other types. */
#define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE)
/* This field is only defined for FUNCTION_TYPE nodes. If the Ada
subprogram contains no parameters passed by copy in/copy out then this
field is 0. Otherwise it points to a list of nodes used to specify the
return values of the out (or in out) parameters that qualify to be passed
by copy in copy out. It is a CONSTRUCTOR. For a full description of the
cico parameter passing mechanism refer to the routine gnat_to_gnu_entity. */
#define TYPE_CI_CO_LIST(NODE) TYPE_LANG_SLOT_1 (FUNCTION_TYPE_CHECK (NODE))
/* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the
modulus. */
#define TYPE_MODULUS(NODE) GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
#define SET_TYPE_MODULUS(NODE, X) \
SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X)
/* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, points to
the type corresponding to the Ada index type. */
#define TYPE_INDEX_TYPE(NODE) \
GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
#define SET_TYPE_INDEX_TYPE(NODE, X) \
SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X)
/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, stores the
Digits_Value. */
#define TYPE_DIGITS_VALUE(NODE) \
GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
#define SET_TYPE_DIGITS_VALUE(NODE, X) \
SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X)
/* For numeric types, stores the RM_Size of the type. */
#define TYPE_RM_SIZE_NUM(NODE) TYPE_LANG_SLOT_1 (NUMERICAL_TYPE_CHECK (NODE))
#define TYPE_RM_SIZE(NODE) \
(INTEGRAL_TYPE_P (NODE) || TREE_CODE (NODE) == REAL_TYPE \
? TYPE_RM_SIZE_NUM (NODE) : 0)
/* For a RECORD_TYPE that is a fat pointer, point to the type for the
unconstrained object. Likewise for a RECORD_TYPE that is pointed
to by a thin pointer. */
#define TYPE_UNCONSTRAINED_ARRAY(NODE) \
GET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE))
#define SET_TYPE_UNCONSTRAINED_ARRAY(NODE, X) \
SET_TYPE_LANG_SPECIFIC (RECORD_TYPE_CHECK (NODE), X)
/* For other RECORD_TYPEs and all UNION_TYPEs and QUAL_UNION_TYPEs, the Ada
size of the object. This differs from the GCC size in that it does not
include any rounding up to the alignment of the type. */
#define TYPE_ADA_SIZE(NODE) \
GET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE))
#define SET_TYPE_ADA_SIZE(NODE, X) \
SET_TYPE_LANG_SPECIFIC (RECORD_OR_UNION_CHECK (NODE), X)
/* For an INTEGER_TYPE with TYPE_HAS_ACTUAL_BOUNDS_P or an ARRAY_TYPE, this is
the index type that should be used when the actual bounds are required for
a template. This is used in the case of packed arrays. */
#define TYPE_ACTUAL_BOUNDS(NODE) \
GET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE))
#define SET_TYPE_ACTUAL_BOUNDS(NODE, X) \
SET_TYPE_LANG_SPECIFIC (TREE_CHECK2 (NODE, INTEGER_TYPE, ARRAY_TYPE), X)
/* In an UNCONSTRAINED_ARRAY_TYPE, points to the record containing both
the template and object.
??? We also put this on an ENUMERAL_TYPE that's dummy. Technically,
this is a conflict on the minval field, but there doesn't seem to be
simple fix, so we'll live with this kludge for now. */
#define TYPE_OBJECT_RECORD_TYPE(NODE) \
(TREE_CHECK2 ((NODE), UNCONSTRAINED_ARRAY_TYPE, ENUMERAL_TYPE)->type.minval)
/* Nonzero in a FUNCTION_DECL that represents a stubbed function
discriminant. */
#define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE))
/* Nonzero in a VAR_DECL if it is guaranteed to be constant after having
been elaborated and TREE_READONLY is not set on it. */
#define DECL_READONLY_ONCE_ELAB(NODE) DECL_LANG_FLAG_0 (VAR_DECL_CHECK (NODE))
/* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF
is needed to access the object. */
#define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE)
/* Nonzero in a FIELD_DECL that is a dummy built for some internal reason. */
#define DECL_INTERNAL_P(NODE) DECL_LANG_FLAG_3 (FIELD_DECL_CHECK (NODE))
/* Nonzero if this decl is a PARM_DECL for an Ada array being passed to a
foreign convention subprogram. */
#define DECL_BY_COMPONENT_PTR_P(NODE) DECL_LANG_FLAG_3 (PARM_DECL_CHECK (NODE))
/* Nonzero in a FUNCTION_DECL that corresponds to an elaboration procedure. */
#define DECL_ELABORATION_PROC_P(NODE) \
DECL_LANG_FLAG_3 (FUNCTION_DECL_CHECK (NODE))
/* Nonzero if this is a decl for a pointer that points to something which
is readonly. Used mostly for fat pointers. */
#define DECL_POINTS_TO_READONLY_P(NODE) DECL_LANG_FLAG_4 (NODE)
/* Nonzero in a FIELD_DECL if there was a record rep clause. */
#define DECL_HAS_REP_P(NODE) DECL_LANG_FLAG_5 (FIELD_DECL_CHECK (NODE))
/* Nonzero in a PARM_DECL if we are to pass by descriptor. */
#define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE))
/* Nonzero in a VAR_DECL if it is a pointer renaming a global object. */
#define DECL_RENAMING_GLOBAL_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE))
/* In a CONST_DECL, points to a VAR_DECL that is allocatable to
memory. Used when a scalar constant is aliased or has its
address taken. */
#define DECL_CONST_CORRESPONDING_VAR(NODE) \
GET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE))
#define SET_DECL_CONST_CORRESPONDING_VAR(NODE, X) \
SET_DECL_LANG_SPECIFIC (CONST_DECL_CHECK (NODE), X)
/* In a FIELD_DECL, points to the FIELD_DECL that was the ultimate
source of the decl. */
#define DECL_ORIGINAL_FIELD(NODE) \
GET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE))
#define SET_DECL_ORIGINAL_FIELD(NODE, X) \
SET_DECL_LANG_SPECIFIC (FIELD_DECL_CHECK (NODE), X)
/* In a VAR_DECL, points to the object being renamed if the VAR_DECL is a
renaming pointer, otherwise 0. Note that this object is guaranteed to
be protected against multiple evaluations. */
#define DECL_RENAMED_OBJECT(NODE) \
GET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE))
#define SET_DECL_RENAMED_OBJECT(NODE, X) \
SET_DECL_LANG_SPECIFIC (VAR_DECL_CHECK (NODE), X)
/* In a TYPE_DECL, points to the parallel type if any, otherwise 0. */
#define DECL_PARALLEL_TYPE(NODE) \
GET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE))
#define SET_DECL_PARALLEL_TYPE(NODE, X) \
SET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE), X)
/* In a FUNCTION_DECL, points to the stub associated with the function
if any, otherwise 0. */
#define DECL_FUNCTION_STUB(NODE) \
GET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE))
#define SET_DECL_FUNCTION_STUB(NODE, X) \
SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X)
/* In a FIELD_DECL corresponding to a discriminant, contains the
discriminant number. */
#define DECL_DISCRIMINANT_NUMBER(NODE) DECL_INITIAL (FIELD_DECL_CHECK (NODE))
/* Define fields and macros for statements.
Start by defining which tree codes are used for statements. */
#define IS_STMT(NODE) (STATEMENT_CLASS_P (NODE))
#define IS_ADA_STMT(NODE) (IS_STMT (NODE) \
&& TREE_CODE (NODE) >= STMT_STMT)
#define STMT_STMT_STMT(NODE) TREE_OPERAND_CHECK_CODE (NODE, STMT_STMT, 0)
#define LOOP_STMT_TOP_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 0)
#define LOOP_STMT_BOT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 1)
#define LOOP_STMT_UPDATE(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 2)
#define LOOP_STMT_BODY(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 3)
#define LOOP_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, LOOP_STMT, 4)
#define EXIT_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 0)
#define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1)
#define REGION_STMT_BODY(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 0)
#define REGION_STMT_HANDLE(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 1)
#define REGION_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE (NODE, REGION_STMT, 2)
#define HANDLER_STMT_ARG(NODE) TREE_OPERAND_CHECK_CODE (NODE, HANDLER_STMT, 0)
#define HANDLER_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, HANDLER_STMT, 1)
#define HANDLER_STMT_BLOCK(NODE) TREE_OPERAND_CHECK_CODE(NODE, HANDLER_STMT, 2)
gcc/ada/ada.h deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* A D A *
* *
* C Header File *
* *
* Copyright (C) 1992-2008, 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 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
* Boston, MA 02110-1301, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* This file contains some standard macros for performing Ada-like
operations. These are used to aid in the translation of other headers. */
#ifndef GCC_ADA_H
#define GCC_ADA_H
/* Inlined functions in header are preceded by INLINE, which is normally set
to extern inline for GCC, but may be set to static for use in standard
ANSI-C. */
#ifndef INLINE
#ifdef __GNUC__
#define INLINE static inline
#else
#define INLINE static
#endif
#endif
/* Define a macro to concatenate two strings. Write it for ANSI C and
for traditional C. */
#ifdef __STDC__
#define CAT(A,B) A##B
#else
#define _ECHO(A) A
#define CAT(A,B) ECHO(A)B
#endif
/* The following macro definition simulates the effect of a declaration of
a subtype, where the first two parameters give the name of the type and
subtype, and the third and fourth parameters give the subtype range. The
effect is to compile a typedef defining the subtype as a synonym for the
type, together with two constants defining the end points. */
#define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \
typedef TYPE SUBTYPE; \
enum { CAT (SUBTYPE,__First) = FIRST, \
CAT (SUBTYPE,__Last) = LAST };
/* The following definitions provide the equivalent of the Ada IN and NOT IN
operators, assuming that the subtype involved has been defined using the
SUBTYPE macro defined above. */
#define IN(VALUE,SUBTYPE) \
(((VALUE) >= (SUBTYPE) CAT (SUBTYPE,__First)) \
&& ((VALUE) <= (SUBTYPE) CAT (SUBTYPE,__Last)))
#endif
gcc/ada/cuintp.c deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* C U I N T P *
* *
* C Implementation File *
* *
* Copyright (C) 1992-2008, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* ware Foundation; either version 3, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License along with GCC; see the file COPYING3. If not see *
* <http://www.gnu.org/licenses/>. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* This file corresponds to the Ada package body Uintp. It was created
manually from the files uintp.ads and uintp.adb. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "ada.h"
#include "types.h"
#include "uintp.h"
#include "atree.h"
#include "elists.h"
#include "nlists.h"
#include "stringt.h"
#include "fe.h"
#include "gigi.h"
#include "ada-tree.h"
/* Universal integers are represented by the Uint type which is an index into
the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an
index and length for getting the "digits" of the universal integer from the
Udigits_Ptr table.
For efficiency, this method is used only for integer values larger than the
constant Uint_Bias. If a Uint is less than this constant, then it contains
the integer value itself. The origin of the Uints_Ptr table is adjusted so
that a Uint value of Uint_Bias indexes the first element.
First define a utility function that operates like build_int_cst for
integral types and does a conversion to floating-point for real types. */
static tree
build_cst_from_int (tree type, HOST_WIDE_INT low)
{
if (TREE_CODE (type) == REAL_TYPE)
return convert (type, build_int_cst (NULL_TREE, low));
else
return build_int_cst_type (type, low);
}
/* Similar to UI_To_Int, but return a GCC INTEGER_CST or REAL_CST node,
depending on whether TYPE is an integral or real type. Overflow is tested
by the constant-folding used to build the node. TYPE is the GCC type of
the resulting node. */
tree
UI_To_gnu (Uint Input, tree type)
{
tree gnu_ret;
/* We might have a TYPE with biased representation and be passed an
unbiased value that doesn't fit. We always use an unbiased type able
to hold any such possible value for intermediate computations, and
then rely on a conversion back to TYPE to perform the bias adjustment
when need be. */
int biased_type_p
= (TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type));
tree comp_type = biased_type_p ? get_base_type (type) : type;
if (Input <= Uint_Direct_Last)
gnu_ret = build_cst_from_int (comp_type, Input - Uint_Direct_Bias);
else
{
Int Idx = Uints_Ptr[Input].Loc;
Pos Length = Uints_Ptr[Input].Length;
Int First = Udigits_Ptr[Idx];
tree gnu_base;
gcc_assert (Length > 0);
/* The computations we perform below always require a type at least as
large as an integer not to overflow. REAL types are always fine, but
INTEGER or ENUMERAL types we are handed may be too short. We use a
base integer type node for the computations in this case and will
convert the final result back to the incoming type later on.
The base integer precision must be superior than 16. */
if (TREE_CODE (comp_type) != REAL_TYPE
&& TYPE_PRECISION (comp_type) < TYPE_PRECISION (long_integer_type_node))
{
comp_type = long_integer_type_node;
gcc_assert (TYPE_PRECISION (comp_type) > 16);
}
gnu_base = build_cst_from_int (comp_type, Base);
gnu_ret = build_cst_from_int (comp_type, First);
if (First < 0)
for (Idx++, Length--; Length; Idx++, Length--)
gnu_ret = fold_build2 (MINUS_EXPR, comp_type,
fold_build2 (MULT_EXPR, comp_type,
gnu_ret, gnu_base),
build_cst_from_int (comp_type,
Udigits_Ptr[Idx]));
else
for (Idx++, Length--; Length; Idx++, Length--)
gnu_ret = fold_build2 (PLUS_EXPR, comp_type,
fold_build2 (MULT_EXPR, comp_type,
gnu_ret, gnu_base),
build_cst_from_int (comp_type,
Udigits_Ptr[Idx]));
}
gnu_ret = convert (type, gnu_ret);
/* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RET. */
while ((TREE_CODE (gnu_ret) == NOP_EXPR
|| TREE_CODE (gnu_ret) == NON_LVALUE_EXPR)
&& TREE_TYPE (TREE_OPERAND (gnu_ret, 0)) == TREE_TYPE (gnu_ret))
gnu_ret = TREE_OPERAND (gnu_ret, 0);
return gnu_ret;
}
gcc/ada/decl.c deleted 100644 → 0
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/deftarg.c deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* D E F T A R G *
* *
* Body *
* *
* 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- *
* ware Foundation; either version 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
* Boston, MA 02110-1301, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* Include a default definition for TARGET_FLAGS for gnatpsta. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
int target_flags = TARGET_DEFAULT;
gcc/ada/gigi.h deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* G I G I *
* *
* C Header File *
* *
* Copyright (C) 1992-2008, 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 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
* Boston, MA 02110-1301, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* Declare all functions and types used by gigi. */
/* The largest alignment, in bits, that is needed for using the widest
move instruction. */
extern unsigned int largest_move_alignment;
/* Compute the alignment of the largest mode that can be used for copying
objects. */
extern void gnat_compute_largest_alignment (void);
/* GNU_TYPE is a type. Determine if it should be passed by reference by
default. */
extern bool default_pass_by_ref (tree gnu_type);
/* GNU_TYPE is the type of a subprogram parameter. Determine from the type
if it should be passed by reference. */
extern bool must_pass_by_ref (tree gnu_type);
/* Initialize DUMMY_NODE_TABLE. */
extern void init_dummy_type (void);
/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
GCC type corresponding to that entity. GNAT_ENTITY is assumed to
refer to an Ada type. */
extern tree gnat_to_gnu_type (Entity_Id gnat_entity);
/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
entity, this routine returns the equivalent GCC tree for that entity
(an ..._DECL node) and associates the ..._DECL node with the input GNAT
defining identifier.
If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its
initial value (in GCC tree form). This is optional for variables.
For renamed entities, GNU_EXPR gives the object being renamed.
DEFINITION is nonzero if this call is intended for a definition. This is
used for separate compilation where it necessary to know whether an
external declaration or a definition should be created if the GCC equivalent
was not created previously. The value of 1 is normally used for a nonzero
DEFINITION, but a value of 2 is used in special circumstances, defined in
the code. */
extern tree gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
int definition);
/* Similar, but if the returned value is a COMPONENT_REF, return the
FIELD_DECL. */
extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity);
/* Wrap up compilation of T, a TYPE_DECL, possibly deferring it. */
extern void rest_of_type_decl_compilation (tree t);
/* Start a new statement group chained to the previous group. */
extern void start_stmt_group (void);
/* Add GNU_STMT to the current BLOCK_STMT node. */
extern void add_stmt (tree gnu_stmt);
/* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
extern void add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node);
/* Return code corresponding to the current code group. It is normally
a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
BLOCK or cleanups were set. */
extern tree end_stmt_group (void);
/* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
extern void set_block_for_group (tree);
/* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node.
Get SLOC from GNAT_ENTITY. */
extern void add_decl_expr (tree gnu_decl, Entity_Id gnat_entity);
/* Mark nodes rooted at *TP with TREE_VISITED and types as having their
sized gimplified. We use this to indicate all variable sizes and
positions in global types may not be shared by any subprogram. */
extern void mark_visited (tree *);
/* Finalize any From_With_Type incomplete types. We do this after processing
our compilation unit and after processing its spec, if this is a body. */
extern void finalize_from_with_types (void);
/* Return the equivalent type to be used for GNAT_ENTITY, if it's a
kind of type (such E_Task_Type) that has a different type which Gigi
uses for its representation. If the type does not have a special type
for its representation, return GNAT_ENTITY. If a type is supposed to
exist, but does not, abort unless annotating types, in which case
return Empty. If GNAT_ENTITY is Empty, return Empty. */
extern Entity_Id Gigi_Equivalent_Type (Entity_Id);
/* Given GNAT_ENTITY, elaborate all expressions that are required to
be elaborated at the point of its definition, but do nothing else. */
extern void elaborate_entity (Entity_Id gnat_entity);
/* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
any entities on its entity chain similarly. */
extern void mark_out_of_scope (Entity_Id gnat_entity);
/* Make a dummy type corresponding to GNAT_TYPE. */
extern tree make_dummy_type (Entity_Id gnat_type);
/* Get the unpadded version of a GNAT type. */
extern tree get_unpadded_type (Entity_Id gnat_entity);
/* Called when we need to protect a variable object using a save_expr. */
extern tree maybe_variable (tree gnu_operand);
/* Create a record type that contains a SIZE bytes long field of TYPE with a
starting bit position so that it is aligned to ALIGN bits, and leaving at
least ROOM bytes free before the field. BASE_ALIGN is the alignment the
record is guaranteed to get. */
extern tree make_aligning_type (tree type, unsigned int align, tree size,
unsigned int base_align, int room);
/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
if needed. We have already verified that SIZE and TYPE are large enough.
GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
to issue a warning.
IS_USER_TYPE is true if we must be sure we complete the original type.
DEFINITION is true if this type is being defined.
SAME_RM_SIZE is true if the RM_Size of the resulting type is to be
set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original
type. */
extern tree maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, const char *name_trailer,
bool is_user_type, bool definition,
bool same_rm_size);
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
the value passed against the list of choices. */
extern tree choices_to_gnu (tree operand, Node_Id choices);
/* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
type with all size expressions that contain F updated by replacing F
with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
nothing has changed. */
extern tree substitute_in_type (tree t, tree f, tree r);
/* Return the "RM size" of GNU_TYPE. This is the actual number of bits
needed to represent the object. */
extern tree rm_size (tree gnu_type);
/* Given GNU_ID, an IDENTIFIER_NODE containing a name, and SUFFIX, a
string, return a new IDENTIFIER_NODE that is the concatenation of
the name in GNU_ID and SUFFIX. */
extern tree concat_id_with_name (tree gnu_id, const char *suffix);
/* Return the name to be used for GNAT_ENTITY. If a type, create a
fully-qualified name, possibly with type information encoding.
Otherwise, return the name. */
extern tree get_entity_name (Entity_Id gnat_entity);
/* Return a name for GNAT_ENTITY concatenated with two underscores and
SUFFIX. */
extern tree create_concat_name (Entity_Id gnat_entity, const char *suffix);
/* If true, then gigi is being called on an analyzed but unexpanded tree, and
the only purpose of the call is to properly annotate types with
representation information. */
extern bool type_annotate_only;
/* Current file name without path */
extern const char *ref_filename;
/* This structure must be kept synchronized with Call_Back_End. */
struct File_Info_Type
{
File_Name_Type File_Name;
Nat Num_Source_Lines;
};
/* This is the main program of the back-end. It sets up all the table
structures and then generates code.
??? Needs parameter descriptions */
extern void gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
struct Node *nodes_ptr, Node_Id *next_node_ptr,
Node_Id *prev_node_ptr, struct Elist_Header *elists_ptr,
struct Elmt_Item *elmts_ptr,
struct String_Entry *strings_ptr,
Char_Code *strings_chars_ptr,
struct List_Header *list_headers_ptr,
Nat number_file,
struct File_Info_Type *file_info_ptr,
Entity_Id standard_integer,
Entity_Id standard_long_long_float,
Entity_Id standard_exception_type,
Int gigi_operating_mode);
/* GNAT_NODE is the root of some GNAT tree. Return the root of the
GCC tree corresponding to that GNAT tree. Normally, no code is generated;
we just return an equivalent tree which is used elsewhere to generate
code. */
extern tree gnat_to_gnu (Node_Id gnat_node);
/* GNU_STMT is a statement. We generate code for that statement. */
extern void gnat_expand_stmt (tree gnu_stmt);
/* ??? missing documentation */
extern int gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
gimple_seq *post_p ATTRIBUTE_UNUSED);
/* Do the processing for the declaration of a GNAT_ENTITY, a type. If
a separate Freeze node exists, delay the bulk of the processing. Otherwise
make a GCC type for GNAT_ENTITY and set up the correspondence. */
extern void process_type (Entity_Id gnat_entity);
/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
location and false if it doesn't. In the former case, set the Gigi global
variable REF_FILENAME to the simple debug file name as given by sinput. */
extern bool Sloc_to_locus (Source_Ptr Sloc, location_t *locus);
/* Post an error message. MSG is the error message, properly annotated.
NODE is the node at which to post the error and the node to use for the
"&" substitution. */
extern void post_error (const char *, Node_Id);
/* Similar, but NODE is the node at which to post the error and ENT
is the node to use for the "&" substitution. */
extern void post_error_ne (const char *msg, Node_Id node, Entity_Id ent);
/* Similar, but NODE is the node at which to post the error, ENT is the node
to use for the "&" substitution, and N is the number to use for the ^. */
extern void post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent,
int n);
/* Similar to post_error_ne_num, but T is a GCC tree representing the number
to write. If the tree represents a constant that fits within a
host integer, the text inside curly brackets in MSG will be output
(presumably including a '^'). Otherwise that text will not be output
and the text inside square brackets will be output instead. */
extern void post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent,
tree t);
/* Similar to post_error_ne_tree, except that NUM is a second
integer to write in the message. */
extern void post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent,
tree t, int num);
/* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
extern tree protect_multiple_eval (tree exp);
/* Return a label to branch to for the exception type in KIND or NULL_TREE
if none. */
extern tree get_exception_label (char);
/* Current node being treated, in case gigi_abort or Check_Elaboration_Code
called. */
extern Node_Id error_gnat_node;
/* This is equivalent to stabilize_reference in tree.c, but we know how to
handle our own nodes and we take extra arguments. FORCE says whether to
force evaluation of everything. We set SUCCESS to true unless we walk
through something we don't know how to stabilize. */
extern tree maybe_stabilize_reference (tree ref, bool force, bool *success);
/* Highest number in the front-end node table. */
extern int max_gnat_nodes;
/* If nonzero, pretend we are allocating at global level. */
extern int force_global;
/* Standard data type sizes. Most of these are not used. */
#ifndef CHAR_TYPE_SIZE
#define CHAR_TYPE_SIZE BITS_PER_UNIT
#endif
#ifndef SHORT_TYPE_SIZE
#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2))
#endif
#ifndef INT_TYPE_SIZE
#define INT_TYPE_SIZE BITS_PER_WORD
#endif
#ifndef LONG_TYPE_SIZE
#define LONG_TYPE_SIZE BITS_PER_WORD
#endif
#ifndef LONG_LONG_TYPE_SIZE
#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
#ifndef FLOAT_TYPE_SIZE
#define FLOAT_TYPE_SIZE BITS_PER_WORD
#endif
#ifndef DOUBLE_TYPE_SIZE
#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
#ifndef LONG_DOUBLE_TYPE_SIZE
#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif
/* The choice of SIZE_TYPE here is very problematic. We need a signed
type whose bit width is Pmode. Assume "long" is such a type here. */
#undef SIZE_TYPE
#define SIZE_TYPE "long int"
/* Data structures used to represent attributes. */
enum attr_type
{
ATTR_MACHINE_ATTRIBUTE,
ATTR_LINK_ALIAS,
ATTR_LINK_SECTION,
ATTR_LINK_CONSTRUCTOR,
ATTR_LINK_DESTRUCTOR,
ATTR_WEAK_EXTERNAL
};
struct attrib
{
struct attrib *next;
enum attr_type type;
tree name;
tree args;
Node_Id error_point;
};
/* Table of machine-independent internal attributes. */
extern const struct attribute_spec gnat_internal_attribute_table[];
/* Define the entries in the standard data array. */
enum standard_datatypes
{
/* Various standard data types and nodes. */
ADT_longest_float_type,
ADT_void_type_decl,
/* The type of an exception. */
ADT_except_type,
/* Type declaration node <==> typedef void *T */
ADT_ptr_void_type,
/* Function type declaration -- void T() */
ADT_void_ftype,
/* Type declaration node <==> typedef void *T() */
ADT_ptr_void_ftype,
/* Type declaration node <==> typedef virtual void *T() */
ADT_fdesc_type,
/* Null pointer for above type */
ADT_null_fdesc,
/* Function declaration nodes for run-time functions for allocating memory.
Ada allocators cause calls to these functions to be generated. Malloc32
is used only on 64bit systems needing to allocate 32bit memory. */
ADT_malloc_decl,
ADT_malloc32_decl,
/* Likewise for freeing memory. */
ADT_free_decl,
/* Types and decls used by our temporary exception mechanism. See
init_gigi_decls for details. */
ADT_jmpbuf_type,
ADT_jmpbuf_ptr_type,
ADT_get_jmpbuf_decl,
ADT_set_jmpbuf_decl,
ADT_get_excptr_decl,
ADT_setjmp_decl,
ADT_longjmp_decl,
ADT_update_setjmp_buf_decl,
ADT_raise_nodefer_decl,
ADT_begin_handler_decl,
ADT_end_handler_decl,
ADT_others_decl,
ADT_all_others_decl,
ADT_LAST};
extern GTY(()) tree gnat_std_decls[(int) ADT_LAST];
extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
#define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type]
#define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl]
#define except_type_node gnat_std_decls[(int) ADT_except_type]
#define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type]
#define void_ftype gnat_std_decls[(int) ADT_void_ftype]
#define ptr_void_ftype gnat_std_decls[(int) ADT_ptr_void_ftype]
#define fdesc_type_node gnat_std_decls[(int) ADT_fdesc_type]
#define null_fdesc_node gnat_std_decls[(int) ADT_null_fdesc]
#define malloc_decl gnat_std_decls[(int) ADT_malloc_decl]
#define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl]
#define free_decl gnat_std_decls[(int) ADT_free_decl]
#define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type]
#define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type]
#define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl]
#define set_jmpbuf_decl gnat_std_decls[(int) ADT_set_jmpbuf_decl]
#define get_excptr_decl gnat_std_decls[(int) ADT_get_excptr_decl]
#define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl]
#define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl]
#define update_setjmp_buf_decl gnat_std_decls[(int) ADT_update_setjmp_buf_decl]
#define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl]
#define begin_handler_decl gnat_std_decls[(int) ADT_begin_handler_decl]
#define others_decl gnat_std_decls[(int) ADT_others_decl]
#define all_others_decl gnat_std_decls[(int) ADT_all_others_decl]
#define end_handler_decl gnat_std_decls[(int) ADT_end_handler_decl]
/* Routines expected by the gcc back-end. They must have exactly the same
prototype and names as below. */
/* Returns nonzero if we are currently in the global binding level. */
extern int global_bindings_p (void);
/* Enter and exit a new binding level. */
extern void gnat_pushlevel (void);
extern void gnat_poplevel (void);
/* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
and point FNDECL to this BLOCK. */
extern void set_current_block_context (tree fndecl);
/* Set the jmpbuf_decl for the current binding level to DECL. */
extern void set_block_jmpbuf_decl (tree decl);
/* Get the setjmp_decl, if any, for the current binding level. */
extern tree get_block_jmpbuf_decl (void);
/* Records a ..._DECL node DECL as belonging to the current lexical scope
and uses GNAT_NODE for location information. */
extern void gnat_pushdecl (tree decl, Node_Id gnat_node);
extern void gnat_init_decl_processing (void);
extern void init_gigi_decls (tree long_long_float_type, tree exception_type);
extern void gnat_init_gcc_eh (void);
/* Return an integer type with the number of bits of precision given by
PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
it is a signed type. */
extern tree gnat_type_for_size (unsigned precision, int unsignedp);
/* Return a data type that has machine mode MODE. UNSIGNEDP selects
an unsigned type; otherwise a signed type is returned. */
extern tree gnat_type_for_mode (enum machine_mode mode, int unsignedp);
/* Emit debug info for all global variable declarations. */
extern void gnat_write_global_declarations (void);
/* Return the unsigned version of a TYPE_NODE, a scalar type. */
extern tree gnat_unsigned_type (tree type_node);
/* Return the signed version of a TYPE_NODE, a scalar type. */
extern tree gnat_signed_type (tree type_node);
/* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
transparently converted to each other. */
extern int gnat_types_compatible_p (tree t1, tree t2);
/* Create an expression whose value is that of EXPR,
converted to type TYPE. The TREE_TYPE of the value
is always TYPE. This function implements all reasonable
conversions; callers should filter out those that are
not permitted by the language being compiled. */
extern tree convert (tree type, tree expr);
/* Routines created solely for the tree translator's sake. Their prototypes
can be changed as desired. */
/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
GNU_DECL is the GCC tree which is to be associated with
GNAT_ENTITY. Such gnu tree node is always an ..._DECL node.
If NO_CHECK is nonzero, the latter check is suppressed.
If GNU_DECL is zero, a previous association is to be reset. */
extern void save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl,
bool no_check);
/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
Return the ..._DECL node that was associated with it. If there is no tree
node associated with GNAT_ENTITY, abort. */
extern tree get_gnu_tree (Entity_Id gnat_entity);
/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
extern bool present_gnu_tree (Entity_Id gnat_entity);
/* Initialize tables for above routines. */
extern void init_gnat_to_gnu (void);
/* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST,
finish constructing the record or union type. If REP_LEVEL is zero, this
record has no representation clause and so will be entirely laid out here.
If REP_LEVEL is one, this record has a representation clause and has been
laid out already; only set the sizes and alignment. If REP_LEVEL is two,
this record is derived from a parent record and thus inherits its layout;
only make a pass on the fields to finalize them. If DO_NOT_FINALIZE is
true, the record type is expected to be modified afterwards so it will
not be sent to the back-end for finalization. */
extern void finish_record_type (tree record_type, tree fieldlist,
int rep_level, bool do_not_finalize);
/* Wrap up compilation of RECORD_TYPE, i.e. most notably output all
the debug information associated with it. It need not be invoked
directly in most cases since finish_record_type takes care of doing
so, unless explicitly requested not to through DO_NOT_FINALIZE. */
extern void rest_of_record_type_compilation (tree record_type);
/* Append PARALLEL_TYPE on the chain of parallel types for decl. */
extern void add_parallel_type (tree decl, tree parallel_type);
/* Return the parallel type associated to a type, if any. */
extern tree get_parallel_type (tree type);
/* Returns a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
subprogram. If it is void_type_node, then we are dealing with a procedure,
otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
copy-in/copy-out list to be stored into TYPE_CI_CO_LIST.
RETURNS_UNCONSTRAINED is true if the function returns an unconstrained
object. RETURNS_BY_REF is true if the function returns by reference.
RETURNS_BY_TARGET_PTR is true if the function is to be passed (as its
first parameter) the address of the place to copy its result. */
extern tree create_subprog_type (tree return_type, tree param_decl_list,
tree cico_list, bool returns_unconstrained,
bool returns_by_ref,
bool returns_by_target_ptr);
/* Return a copy of TYPE, but safe to modify in any way. */
extern tree copy_type (tree type);
/* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position of
the decl. */
extern tree create_index_type (tree min, tree max, tree index,
Node_Id gnat_node);
/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
string) and TYPE is a ..._TYPE node giving its data type.
ARTIFICIAL_P is true if this is a declaration that was generated
by the compiler. DEBUG_INFO_P is true if we need to write debugging
information about this type. GNAT_NODE is used for the position of
the decl. */
extern tree create_type_decl (tree type_name, tree type,
struct attrib *attr_list,
bool artificial_p, bool debug_info_p,
Node_Id gnat_node);
/* Return a VAR_DECL or CONST_DECL node.
VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
(if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is
the GCC tree for an optional initial expression; NULL_TREE if none.
CONST_FLAG is true if this variable is constant, in which case we might
return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false.
PUBLIC_FLAG is true if this definition is to be made visible outside of
the current compilation unit. This flag should be set when processing the
variable definitions in a package specification.
EXTERN_FLAG is nonzero when processing an external variable declaration (as
opposed to a definition: no storage is to be allocated for the variable).
STATIC_FLAG is only relevant when not at top level. In that case
it indicates whether to always allocate storage to the variable.
GNAT_NODE is used for the position of the decl. */
tree
create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init,
bool const_flag, bool public_flag, bool extern_flag,
bool static_flag, bool const_decl_allowed_p,
struct attrib *attr_list, Node_Id gnat_node);
/* Wrapper around create_var_decl_1 for cases where we don't care whether
a VAR or a CONST decl node is created. */
#define create_var_decl(var_name, asm_name, type, var_init, \
const_flag, public_flag, extern_flag, \
static_flag, attr_list, gnat_node) \
create_var_decl_1 (var_name, asm_name, type, var_init, \
const_flag, public_flag, extern_flag, \
static_flag, true, attr_list, gnat_node)
/* Wrapper around create_var_decl_1 for cases where a VAR_DECL node is
required. The primary intent is for DECL_CONST_CORRESPONDING_VARs, which
must be VAR_DECLs and on which we want TREE_READONLY set to have them
possibly assigned to a readonly data section. */
#define create_true_var_decl(var_name, asm_name, type, var_init, \
const_flag, public_flag, extern_flag, \
static_flag, attr_list, gnat_node) \
create_var_decl_1 (var_name, asm_name, type, var_init, \
const_flag, public_flag, extern_flag, \
static_flag, false, attr_list, gnat_node)
/* Given a DECL and ATTR_LIST, apply the listed attributes. */
extern void process_attributes (tree decl, struct attrib *attr_list);
/* Record a global renaming pointer. */
void record_global_renaming_pointer (tree);
/* Invalidate the global renaming pointers. */
void invalidate_global_renaming_pointers (void);
/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
this field is in a record type with a "pragma pack". If SIZE is nonzero
it is the specified size for this field. If POS is nonzero, it is the bit
position. If ADDRESSABLE is nonzero, it means we are allowed to take
the address of this field for aliasing purposes. */
extern tree create_field_decl (tree field_name, tree field_type,
tree record_type, int packed, tree size,
tree pos, int addressable);
/* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
PARAM_TYPE is its type. READONLY is true if the parameter is
readonly (either an In parameter or an address of a pass-by-ref
parameter). */
extern tree create_param_decl (tree param_name, tree param_type,
bool readonly);
/* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram,
ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
PARM_DECL nodes chained through the TREE_CHAIN field).
INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and ATTR_LIST are used to set the
appropriate fields in the FUNCTION_DECL. GNAT_NODE gives the location. */
extern tree create_subprog_decl (tree subprog_name, tree asm_name,
tree subprog_type, tree param_decl_list,
bool inlinee_flag, bool public_flag,
bool extern_flag,
struct attrib *attr_list, Node_Id gnat_node);
/* Returns a LABEL_DECL node for LABEL_NAME. */
extern tree create_label_decl (tree label_name);
/* Set up the framework for generating code for SUBPROG_DECL, a subprogram
body. This routine needs to be invoked before processing the declarations
appearing in the subprogram. */
extern void begin_subprog_body (tree subprog_decl);
/* Finish the definition of the current subprogram BODY and compile it all the
way to assembler language output. ELAB_P tells if this is called for an
elaboration routine, to be entirely discarded if empty. */
extern void end_subprog_body (tree body, bool elab_p);
/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
Return a constructor for the template. */
extern tree build_template (tree template_type, tree array_type, tree expr);
/* Build a VMS descriptor from a Mechanism_Type, which must specify
a descriptor type, and the GCC type of an object. Each FIELD_DECL
in the type contains in its DECL_INITIAL the expression to use when
a constructor is made for the type. GNAT_ENTITY is a gnat node used
to print out an error message if the mechanism cannot be applied to
an object of that type and also for the name. */
extern tree build_vms_descriptor (tree type, Mechanism_Type mech,
Entity_Id gnat_entity);
/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
and the GNAT node GNAT_SUBPROG. */
extern void build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog);
/* Build a type to be used to represent an aliased object whose nominal
type is an unconstrained array. This consists of a RECORD_TYPE containing
a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
is used to represent an arbitrary unconstrained object. Use NAME
as the name of the record. */
extern tree build_unc_object_type (tree template_type, tree object_type,
tree name);
/* Same as build_unc_object_type, but taking a thin or fat pointer type
instead of the template type. */
extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type,
tree object_type, tree name);
/* Shift the component offsets within an unconstrained object TYPE to make it
suitable for use as a designated type for thin pointers. */
extern void shift_unc_components_for_thin_pointers (tree type);
/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
the normal case this is just two adjustments, but we have more to do
if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
extern void update_pointer_to (tree old_type, tree new_type);
/* EXP is an expression for the size of an object. If this size contains
discriminant references, replace them with the maximum (if MAX_P) or
minimum (if !MAX_P) possible value of the discriminant. */
extern tree max_size (tree exp, bool max_p);
/* Remove all conversions that are done in EXP. This includes converting
from a padded type or to a left-justified modular type. If TRUE_ADDRESS
is true, always return the address of the containing object even if
the address is not bit-aligned. */
extern tree remove_conversions (tree exp, bool true_address);
/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
likewise return an expression pointing to the underlying array. */
extern tree maybe_unconstrained_array (tree exp);
/* Return an expression that does an unchecked conversion of EXPR to TYPE.
If NOTRUNC_P is true, truncation operations should be suppressed. */
extern tree unchecked_convert (tree type, tree expr, bool notrunc_p);
/* Return the appropriate GCC tree code for the specified GNAT type,
the latter being a record type as predicated by Is_Record_Type. */
extern enum tree_code tree_code_for_record_type (Entity_Id);
/* Return true if GNU_TYPE is suitable as the type of a non-aliased
component of an aggregate type. */
extern bool type_for_nonaliased_component_p (tree);
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
This preparation consists of taking the ordinary
representation of an expression EXPR and producing a valid tree
boolean expression describing whether EXPR is nonzero. We could
simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
but we optimize comparisons, &&, ||, and !.
The resulting type should always be the same as the input type.
This function is simpler than the corresponding C version since
the only possible operands will be things of Boolean type. */
extern tree gnat_truthvalue_conversion (tree expr);
/* Return the base type of TYPE. */
extern tree get_base_type (tree type);
/* EXP is a GCC tree representing an address. See if we can find how
strictly the object at that address is aligned. Return that alignment
strictly the object at that address is aligned. Return that alignment
in bits. If we don't know anything about the alignment, return 0. */
extern unsigned int known_alignment (tree exp);
/* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power
of 2. */
extern bool value_factor_p (tree value, HOST_WIDE_INT factor);
/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
desired for the result. Usually the operation is to be performed
in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
in which case the type to be used will be derived from the operands. */
extern tree build_binary_op (enum tree_code op_code, tree retult_type,
tree left_operand, tree right_operand);
/* Similar, but make unary operation. */
extern tree build_unary_op (enum tree_code op_code, tree result_type,
tree operand);
/* Similar, but for COND_EXPR. */
extern tree build_cond_expr (tree result_type, tree condition_operand,
tree true_operand, tree false_operand);
/* Similar, but for RETURN_EXPR. */
extern tree build_return_expr (tree result_decl, tree ret_val);
/* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return
the CALL_EXPR. */
extern tree build_call_1_expr (tree fundecl, tree arg);
/* Build a CALL_EXPR to call FUNDECL with two argument, ARG1 & ARG2. Return
the CALL_EXPR. */
extern tree build_call_2_expr (tree fundecl, tree arg1, tree arg2);
/* Likewise to call FUNDECL with no arguments. */
extern tree build_call_0_expr (tree fundecl);
/* Call a function that raises an exception and pass the line number and file
name, if requested. MSG says which exception function to call.
GNAT_NODE is the gnat node conveying the source location for which the
error should be signaled, or Empty in which case the error is signaled on
the current ref_file_name/input_line.
KIND says which kind of exception this is for
(N_Raise_{Constraint,Storage,Program}_Error). */
extern tree build_call_raise (int msg, Node_Id gnat_node, char kind);
/* Return a CONSTRUCTOR of TYPE whose list is LIST. This is not the
same as build_constructor in the language-independent tree.c. */
extern tree gnat_build_constructor (tree type, tree list);
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
for the field, or both. Don't fold the result if NO_FOLD_P. */
extern tree build_component_ref (tree record_variable, tree component,
tree field, bool no_fold_p);
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
generate an allocator.
GNU_SIZE is the size of the object and ALIGN is the alignment.
GNAT_PROC, if present is a procedure to call and GNAT_POOL is the
storage pool to use. If not preset, malloc and free will be used. */
extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size,
unsigned align, Entity_Id gnat_proc,
Entity_Id gnat_pool, Node_Id gnat_node);
/* Build a GCC tree to correspond to allocating an object of TYPE whose
initial value if INIT, if INIT is nonzero. Convert the expression to
RESULT_TYPE, which must be some type of pointer. Return the tree.
GNAT_PROC and GNAT_POOL optionally give the procedure to call and
the storage pool to use. GNAT_NODE is used to provide an error
location for restriction violations messages. If IGNORE_INIT_TYPE is
true, ignore the type of INIT for the purpose of determining the size;
this will cause the maximum size to be allocated if TYPE is of
self-referential size. */
extern tree build_allocator (tree type, tree init, tree result_type,
Entity_Id gnat_proc, Entity_Id gnat_pool,
Node_Id gnat_node, bool);
/* Fill in a VMS descriptor for EXPR and return a constructor for it.
GNAT_FORMAL is how we find the descriptor record. */
extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal);
/* Indicate that we need to make the address of EXPR_NODE and it therefore
should not be allocated in a register. Return true if successful. */
extern bool gnat_mark_addressable (tree expr_node);
/* Implementation of the builtin_function langhook. */
extern tree gnat_builtin_function (tree decl);
/* Search the chain of currently reachable declarations for a builtin
FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE).
Return the first node found, if any, or NULL_TREE otherwise. */
extern tree builtin_decl_for (tree name);
/* 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 prec);
extern int fp_size_to_prec (int size);
/* These functions return the basic data type sizes and related parameters
about the target machine. */
extern Pos get_target_bits_per_unit (void);
extern Pos get_target_bits_per_word (void);
extern Pos get_target_char_size (void);
extern Pos get_target_wchar_t_size (void);
extern Pos get_target_short_size (void);
extern Pos get_target_int_size (void);
extern Pos get_target_long_size (void);
extern Pos get_target_long_long_size (void);
extern Pos get_target_float_size (void);
extern Pos get_target_double_size (void);
extern Pos get_target_long_double_size (void);
extern Pos get_target_pointer_size (void);
extern Pos get_target_maximum_alignment (void);
extern Pos get_target_default_allocator_alignment (void);
extern Pos get_target_maximum_default_alignment (void);
extern Pos get_target_maximum_allowed_alignment (void);
extern Nat get_float_words_be (void);
extern Nat get_words_be (void);
extern Nat get_bytes_be (void);
extern Nat get_bits_be (void);
extern Nat get_strict_alignment (void);
gcc/ada/lang-specs.h deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* L A N G - S P E C S *
* *
* C Header File *
* *
* Copyright (C) 1992-2008, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* ware Foundation; either version 3, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License along with GCC; see the file COPYING3. If not see *
* <http://www.gnu.org/licenses/>. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* This is the contribution to the `default_compilers' array in gcc.c for
GNAT. */
{".ads", "@ada", 0, 0, 0},
{".adb", "@ada", 0, 0, 0},
{"@ada",
"\
%{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\
%{!S:%{!c:%e-c or -S required for Ada}}\
gnat1 %{I*} %{k8:-gnatk8} %{Wall:-gnatwa} %{w:-gnatws} %{!Q:-quiet}\
%{nostdinc*} %{nostdlib*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{O*} %{W*} %{w} %{p} %{pg:-p} %{a} %{f*} %{d*} %{g*&m*} "
#if defined(TARGET_VXWORKS_RTP)
"%{fRTS=rtp:-mrtp} "
#endif
#if CONFIG_DUAL_EXCEPTIONS
"%{fRTS=sjlj:-fsjlj} "
#endif
"%1 %{!S:%{o*:%w%*-gnatO}} \
%i %{S:%W{o*}%{!o*:-o %b.s}} \
%{gnatc*|gnats*: -o %j} %{-param*} \
%{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0},
gcc/ada/lang.opt deleted 100644 → 0
; Options for the Ada front end.
; Copyright (C) 2003, 2007 Free Software Foundation, Inc.
;
; This file is part of GCC.
;
; GCC is free software; you can redistribute it and/or modify it under
; the terms of the GNU General Public License as published by the Free
; Software Foundation; either version 3, or (at your option) any later
; version.
;
; GCC is distributed in the hope that it will be useful, but WITHOUT ANY
; WARRANTY; without even the implied warranty of MERCHANTABILITY or
; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
; for more details.
;
; You should have received a copy of the GNU General Public License
; along with GCC; see the file COPYING3. If not see
; <http://www.gnu.org/licenses/>.
; See the GCC internals manual for a description of this file's format.
; Please try to keep this file in ASCII collating order.
Language
Ada
I
Ada Joined Separate
; Documented for C
Wall
Ada
; Documented for C
Wmissing-prototypes
Ada
; Documented for C
Wstrict-prototypes
Ada
; Documented for C
Wwrite-strings
Ada
; Documented for C
Wlong-long
Ada
; Documented for C
Wvariadic-macros
Ada
; Documented for C
Wold-style-definition
Ada
; Documented for C
Wmissing-format-attribute
Ada
; Documented for C
Woverlength-strings
Ada
; Documented for C
nostdinc
Ada RejectNegative
; Don't look for source files
nostdlib
Ada
; Don't look for object files
feliminate-unused-debug-types
Ada
; Effect documented for C - intercepted for Ada to force the associated flag
; not to be set by default, as it currently eliminates unreferenced parallel
; types we need for encoding descriptions to the debugger.
fRTS=
Ada Joined RejectNegative
; Selects the runtime
gdwarf+
Ada
; Explicit request for dwarf debug info with GNAT specific extensions.
gant
Ada Joined Undocumented
; Catches typos
gnatO
Ada Separate
; Sets name of output ALI file (internal switch)
gnat
Ada Joined
-gnat<options> Specify options to GNAT
; This comment is to ensure we retain the blank line above.
gcc/ada/misc.c deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* M I S C *
* *
* C Implementation File *
* *
* Copyright (C) 1992-2008, 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 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
* Boston, MA 02110-1301, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* This file contains parts of the compiler that are required for interfacing
with GCC but otherwise do nothing and parts of Gigi that need to know
about RTL. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "real.h"
#include "rtl.h"
#include "diagnostic.h"
#include "expr.h"
#include "libfuncs.h"
#include "ggc.h"
#include "flags.h"
#include "debug.h"
#include "cgraph.h"
#include "tree-inline.h"
#include "insn-codes.h"
#include "insn-flags.h"
#include "insn-config.h"
#include "optabs.h"
#include "recog.h"
#include "toplev.h"
#include "output.h"
#include "except.h"
#include "tm_p.h"
#include "langhooks.h"
#include "langhooks-def.h"
#include "target.h"
#include "ada.h"
#include "types.h"
#include "atree.h"
#include "elists.h"
#include "namet.h"
#include "nlists.h"
#include "stringt.h"
#include "uintp.h"
#include "fe.h"
#include "sinfo.h"
#include "einfo.h"
#include "ada-tree.h"
#include "gigi.h"
#include "adadecode.h"
#include "opts.h"
#include "options.h"
extern FILE *asm_out_file;
/* The largest alignment, in bits, that is needed for using the widest
move instruction. */
unsigned int largest_move_alignment;
static bool gnat_init (void);
static void gnat_finish_incomplete_decl (tree);
static unsigned int gnat_init_options (unsigned int, const char **);
static int gnat_handle_option (size_t, const char *, int);
static bool gnat_post_options (const char **);
static alias_set_type gnat_get_alias_set (tree);
static void gnat_print_decl (FILE *, tree, int);
static void gnat_print_type (FILE *, tree, int);
static const char *gnat_printable_name (tree, int);
static const char *gnat_dwarf_name (tree, int);
static tree gnat_return_tree (tree);
static int gnat_eh_type_covers (tree, tree);
static void gnat_parse_file (int);
static rtx gnat_expand_expr (tree, rtx, enum machine_mode, int,
rtx *);
static void internal_error_function (const char *, va_list *);
static tree gnat_type_max_size (const_tree);
/* Definitions for our language-specific hooks. */
#undef LANG_HOOKS_NAME
#define LANG_HOOKS_NAME "GNU Ada"
#undef LANG_HOOKS_IDENTIFIER_SIZE
#define LANG_HOOKS_IDENTIFIER_SIZE sizeof (struct tree_identifier)
#undef LANG_HOOKS_INIT
#define LANG_HOOKS_INIT gnat_init
#undef LANG_HOOKS_INIT_OPTIONS
#define LANG_HOOKS_INIT_OPTIONS gnat_init_options
#undef LANG_HOOKS_HANDLE_OPTION
#define LANG_HOOKS_HANDLE_OPTION gnat_handle_option
#undef LANG_HOOKS_POST_OPTIONS
#define LANG_HOOKS_POST_OPTIONS gnat_post_options
#undef LANG_HOOKS_PARSE_FILE
#define LANG_HOOKS_PARSE_FILE gnat_parse_file
#undef LANG_HOOKS_HASH_TYPES
#define LANG_HOOKS_HASH_TYPES false
#undef LANG_HOOKS_GETDECLS
#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
#undef LANG_HOOKS_PUSHDECL
#define LANG_HOOKS_PUSHDECL gnat_return_tree
#undef LANG_HOOKS_WRITE_GLOBALS
#define LANG_HOOKS_WRITE_GLOBALS gnat_write_global_declarations
#undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
#define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
#undef LANG_HOOKS_GET_ALIAS_SET
#define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
#undef LANG_HOOKS_EXPAND_EXPR
#define LANG_HOOKS_EXPAND_EXPR gnat_expand_expr
#undef LANG_HOOKS_MARK_ADDRESSABLE
#define LANG_HOOKS_MARK_ADDRESSABLE gnat_mark_addressable
#undef LANG_HOOKS_PRINT_DECL
#define LANG_HOOKS_PRINT_DECL gnat_print_decl
#undef LANG_HOOKS_PRINT_TYPE
#define LANG_HOOKS_PRINT_TYPE gnat_print_type
#undef LANG_HOOKS_TYPE_MAX_SIZE
#define LANG_HOOKS_TYPE_MAX_SIZE gnat_type_max_size
#undef LANG_HOOKS_DECL_PRINTABLE_NAME
#define LANG_HOOKS_DECL_PRINTABLE_NAME gnat_printable_name
#undef LANG_HOOKS_DWARF_NAME
#define LANG_HOOKS_DWARF_NAME gnat_dwarf_name
#undef LANG_HOOKS_GIMPLIFY_EXPR
#define LANG_HOOKS_GIMPLIFY_EXPR gnat_gimplify_expr
#undef LANG_HOOKS_TYPE_FOR_MODE
#define LANG_HOOKS_TYPE_FOR_MODE gnat_type_for_mode
#undef LANG_HOOKS_TYPE_FOR_SIZE
#define LANG_HOOKS_TYPE_FOR_SIZE gnat_type_for_size
#undef LANG_HOOKS_TYPES_COMPATIBLE_P
#define LANG_HOOKS_TYPES_COMPATIBLE_P gnat_types_compatible_p
#undef LANG_HOOKS_ATTRIBUTE_TABLE
#define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table
#undef LANG_HOOKS_BUILTIN_FUNCTION
#define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function
const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
/* How much we want of our DWARF extensions. Some of our dwarf+ extensions
are incompatible with regular GDB versions, so we must make sure to only
produce them on explicit request. This is eventually reflected into the
use_gnu_debug_info_extensions common flag for later processing. */
static int gnat_dwarf_extensions = 0;
/* Command-line argc and argv.
These variables are global, since they are imported and used in
back_end.adb */
unsigned int save_argc;
const char **save_argv;
/* gnat standard argc argv */
extern int gnat_argc;
extern char **gnat_argv;
/* Declare functions we use as part of startup. */
extern void __gnat_initialize (void *);
extern void __gnat_install_SEH_handler (void *);
extern void adainit (void);
extern void _ada_gnat1drv (void);
/* The parser for the language. For us, we process the GNAT tree. */
static void
gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
{
int seh[2];
/* Call the target specific initializations. */
__gnat_initialize (NULL);
/* ??? Call the SEH initialization routine. This is to workaround
a bootstrap path problem. The call below should be removed at some
point and the SEH pointer passed to __gnat_initialize() above. */
__gnat_install_SEH_handler((void *)seh);
/* Call the front-end elaboration procedures. */
adainit ();
/* Call the front end. */
_ada_gnat1drv ();
/* We always have a single compilation unit in Ada. */
cgraph_finalize_compilation_unit ();
}
/* Decode all the language specific options that cannot be decoded by GCC.
The option decoding phase of GCC calls this routine on the flags that
it cannot decode. This routine returns the number of consecutive arguments
from ARGV that it successfully decoded; 0 indicates failure. */
static int
gnat_handle_option (size_t scode, const char *arg, int value)
{
const struct cl_option *option = &cl_options[scode];
enum opt_code code = (enum opt_code) scode;
char *q;
if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
{
error ("missing argument to \"-%s\"", option->opt_text);
return 1;
}
switch (code)
{
case OPT_I:
q = XNEWVEC (char, sizeof("-I") + strlen (arg));
strcpy (q, "-I");
strcat (q, arg);
gnat_argv[gnat_argc] = q;
gnat_argc++;
break;
case OPT_Wall:
set_Wunused (value);
/* We save the value of warn_uninitialized, since if they put
-Wuninitialized on the command line, we need to generate a
warning about not using it without also specifying -O. */
if (warn_uninitialized != 1)
warn_uninitialized = (value ? 2 : 0);
break;
/* These are used in the GCC Makefile. */
case OPT_Wmissing_prototypes:
case OPT_Wstrict_prototypes:
case OPT_Wwrite_strings:
case OPT_Wlong_long:
case OPT_Wvariadic_macros:
case OPT_Wold_style_definition:
case OPT_Wmissing_format_attribute:
case OPT_Woverlength_strings:
break;
/* This is handled by the front-end. */
case OPT_nostdinc:
break;
case OPT_nostdlib:
gnat_argv[gnat_argc] = xstrdup ("-nostdlib");
gnat_argc++;
break;
case OPT_feliminate_unused_debug_types:
/* We arrange for post_option to be able to only set the corresponding
flag to 1 when explicitly requested by the user. We expect the
default flag value to be either 0 or positive, and expose a positive
-f as a negative value to post_option. */
flag_eliminate_unused_debug_types = -value;
break;
case OPT_fRTS_:
gnat_argv[gnat_argc] = xstrdup ("-fRTS");
gnat_argc++;
break;
case OPT_gant:
warning (0, "%<-gnat%> misspelled as %<-gant%>");
/* ... fall through ... */
case OPT_gnat:
/* Recopy the switches without the 'gnat' prefix. */
gnat_argv[gnat_argc] = XNEWVEC (char, strlen (arg) + 2);
gnat_argv[gnat_argc][0] = '-';
strcpy (gnat_argv[gnat_argc] + 1, arg);
gnat_argc++;
break;
case OPT_gnatO:
gnat_argv[gnat_argc] = xstrdup ("-O");
gnat_argc++;
gnat_argv[gnat_argc] = xstrdup (arg);
gnat_argc++;
break;
case OPT_gdwarf_:
gnat_dwarf_extensions ++;
break;
default:
gcc_unreachable ();
}
return 1;
}
/* Initialize for option processing. */
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_argc = 1;
save_argc = argc;
save_argv = argv;
/* Uninitialized really means uninitialized in Ada. */
flag_zero_initialized_in_bss = 0;
return CL_Ada;
}
/* Post-switch processing. */
bool
gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
{
/* ??? The warning machinery is outsmarted by Ada. */
warn_unused_parameter = 0;
/* Force eliminate_unused_debug_types to 0 unless an explicit positive
-f has been passed. This forces the default to 0 for Ada, which might
differ from the common default. */
if (flag_eliminate_unused_debug_types < 0)
flag_eliminate_unused_debug_types = 1;
else
flag_eliminate_unused_debug_types = 0;
/* Reflect the explicit request of DWARF extensions into the common
flag for use by later passes. */
if (write_symbols == DWARF2_DEBUG)
use_gnu_debug_info_extensions = gnat_dwarf_extensions > 0;
return false;
}
/* Here is the function to handle the compiler error processing in GCC. */
static void
internal_error_function (const char *msgid, va_list *ap)
{
text_info tinfo;
char *buffer, *p, *loc;
String_Template temp, temp_loc;
Fat_Pointer fp, fp_loc;
expanded_location s;
/* Reset the pretty-printer. */
pp_clear_output_area (global_dc->printer);
/* Format the message into the pretty-printer. */
tinfo.format_spec = msgid;
tinfo.args_ptr = ap;
tinfo.err_no = errno;
pp_format_verbatim (global_dc->printer, &tinfo);
/* Extract a (writable) pointer to the formatted text. */
buffer = (char*) pp_formatted_text (global_dc->printer);
/* Go up to the first newline. */
for (p = buffer; *p; p++)
if (*p == '\n')
{
*p = '\0';
break;
}
temp.Low_Bound = 1;
temp.High_Bound = p - buffer;
fp.Bounds = &temp;
fp.Array = buffer;
s = expand_location (input_location);
if (flag_show_column && s.column != 0)
asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
else
asprintf (&loc, "%s:%d", s.file, s.line);
temp_loc.Low_Bound = 1;
temp_loc.High_Bound = strlen (loc);
fp_loc.Bounds = &temp_loc;
fp_loc.Array = loc;
Current_Error_Node = error_gnat_node;
Compiler_Abort (fp, -1, fp_loc);
}
/* Perform all the initialization steps that are language-specific. */
static bool
gnat_init (void)
{
/* Performs whatever initialization steps needed by the language-dependent
lexical analyzer. */
gnat_init_decl_processing ();
/* Add the input filename as the last argument. */
gnat_argv[gnat_argc] = (char *) main_input_filename;
gnat_argc++;
gnat_argv[gnat_argc] = 0;
global_dc->internal_error = &internal_error_function;
/* Show that REFERENCE_TYPEs are internal and should be Pmode. */
internal_reference_types ();
return true;
}
/* This function is called indirectly from toplev.c to handle incomplete
declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise,
compile_file in toplev.c makes an indirect call through the function pointer
incomplete_decl_finalize_hook which is initialized to this routine in
init_decl_processing. */
static void
gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED)
{
gcc_unreachable ();
}
/* Compute the alignment of the largest mode that can be used for copying
objects. */
void
gnat_compute_largest_alignment (void)
{
enum machine_mode mode;
for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode;
mode = GET_MODE_WIDER_MODE (mode))
if (optab_handler (mov_optab, mode)->insn_code != CODE_FOR_nothing)
largest_move_alignment = MIN (BIGGEST_ALIGNMENT,
MAX (largest_move_alignment,
GET_MODE_ALIGNMENT (mode)));
}
/* If we are using the GCC mechanism to process exception handling, we
have to register the personality routine for Ada and to initialize
various language dependent hooks. */
void
gnat_init_gcc_eh (void)
{
#ifdef DWARF2_UNWIND_INFO
/* lang_dependent_init already called dwarf2out_frame_init if true. */
int dwarf2out_frame_initialized = dwarf2out_do_frame ();
#endif
/* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
though. This could for instance lead to the emission of tables with
references to symbols (such as the Ada eh personality routine) within
libraries we won't link against. */
if (No_Exception_Handlers_Set ())
return;
/* Tell GCC we are handling cleanup actions through exception propagation.
This opens possibilities that we don't take advantage of yet, but is
nonetheless necessary to ensure that fixup code gets assigned to the
right exception regions. */
using_eh_for_cleanups ();
eh_personality_libfunc = init_one_libfunc (USING_SJLJ_EXCEPTIONS
? "__gnat_eh_personality_sj"
: "__gnat_eh_personality");
lang_eh_type_covers = gnat_eh_type_covers;
lang_eh_runtime_type = gnat_return_tree;
default_init_unwind_resume_libfunc ();
/* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
the generation of the necessary exception runtime tables. The second one
is useful for two reasons: 1/ we map some asynchronous signals like SEGV
to exceptions, so we need to ensure that the insns which can lead to such
signals are correctly attached to the exception region they pertain to,
2/ Some calls to pure subprograms are handled as libcall blocks and then
marked as "cannot trap" if the flag is not set (see emit_libcall_block).
We should not let this be since it is possible for such calls to actually
raise in Ada. */
flag_exceptions = 1;
flag_non_call_exceptions = 1;
init_eh ();
#ifdef DWARF2_UNWIND_INFO
if (!dwarf2out_frame_initialized && dwarf2out_do_frame ())
dwarf2out_frame_init ();
#endif
}
/* Language hooks, first one to print language-specific items in a DECL. */
static void
gnat_print_decl (FILE *file, tree node, int indent)
{
switch (TREE_CODE (node))
{
case CONST_DECL:
print_node (file, "const_corresponding_var",
DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
break;
case FIELD_DECL:
print_node (file, "original_field", DECL_ORIGINAL_FIELD (node),
indent + 4);
break;
case VAR_DECL:
print_node (file, "renamed_object", DECL_RENAMED_OBJECT (node),
indent + 4);
break;
default:
break;
}
}
static void
gnat_print_type (FILE *file, tree node, int indent)
{
switch (TREE_CODE (node))
{
case FUNCTION_TYPE:
print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
break;
case ENUMERAL_TYPE:
print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
break;
case INTEGER_TYPE:
if (TYPE_MODULAR_P (node))
print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
indent + 4);
else if (TYPE_VAX_FLOATING_POINT_P (node))
;
else
print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
break;
case ARRAY_TYPE:
print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
break;
case RECORD_TYPE:
if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
print_node (file, "unconstrained array",
TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
else
print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
break;
case UNION_TYPE:
case QUAL_UNION_TYPE:
print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
break;
default:
break;
}
}
static const char *
gnat_dwarf_name (tree t, int verbosity ATTRIBUTE_UNUSED)
{
gcc_assert (DECL_P (t));
return (const char *) IDENTIFIER_POINTER (DECL_NAME (t));
}
static const char *
gnat_printable_name (tree decl, int verbosity)
{
const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
__gnat_decode (coded_name, ada_name, 0);
if (verbosity == 2)
{
Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
ada_name = Name_Buffer;
}
return (const char *) ada_name;
}
/* Expands GNAT-specific GCC tree nodes. The only ones we support
here are and NULL_EXPR. */
static rtx
gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode,
int modifier, rtx *alt_rtl)
{
tree type = TREE_TYPE (exp);
tree new;
/* Update EXP to be the new expression to expand. */
switch (TREE_CODE (exp))
{
#if 0
case ALLOCATE_EXPR:
return
allocate_dynamic_stack_space
(expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
EXPAND_NORMAL),
NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
#endif
case UNCONSTRAINED_ARRAY_REF:
/* If we are evaluating just for side-effects, just evaluate our
operand. Otherwise, abort since this code should never appear
in a tree to be evaluated (objects aren't unconstrained). */
if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
VOIDmode, modifier);
/* ... fall through ... */
default:
gcc_unreachable ();
}
return expand_expr_real (new, target, tmode, modifier, alt_rtl);
}
/* Do nothing (return the tree node passed). */
static tree
gnat_return_tree (tree t)
{
return t;
}
/* Return true if type A catches type B. Callback for flow analysis from
the exception handling part of the back-end. */
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".
??? integer_zero_node for "others" is hardwired in too many places
currently. */
return (a == b || a == integer_zero_node);
}
/* Get the alias set corresponding to a type or expression. */
static alias_set_type
gnat_get_alias_set (tree type)
{
/* If this is a padding type, use the type of the first field. */
if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type))
return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
/* If the type is an unconstrained array, use the type of the
self-referential array we make. */
else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
return
get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
/* If the type can alias any other types, return the alias set 0. */
else if (TYPE_P (type)
&& TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
return 0;
return -1;
}
/* GNU_TYPE is a type. Return its maximum size in bytes, if known,
as a constant when possible. */
static tree
gnat_type_max_size (const_tree gnu_type)
{
/* First see what we can get from TYPE_SIZE_UNIT, which might not
be constant even for simple expressions if it has already been
elaborated and possibly replaced by a VAR_DECL. */
tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
/* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
which should stay untouched. */
if (!host_integerp (max_unitsize, 1)
&& (TREE_CODE (gnu_type) == RECORD_TYPE
|| TREE_CODE (gnu_type) == UNION_TYPE
|| TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
&& TYPE_ADA_SIZE (gnu_type))
{
tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
/* If we have succeeded in finding a constant, round it up to the
type's alignment and return the result in units. */
if (host_integerp (max_adasize, 1))
max_unitsize
= size_binop (CEIL_DIV_EXPR,
round_up (max_adasize, TYPE_ALIGN (gnu_type)),
bitsize_unit_node);
}
return max_unitsize;
}
/* GNU_TYPE is a type. Determine if it should be passed by reference by
default. */
bool
default_pass_by_ref (tree gnu_type)
{
/* We pass aggregates by reference if they are sufficiently large. The
choice of constant here is somewhat arbitrary. We also pass by
reference if the target machine would either pass or return by
reference. Strictly speaking, we need only check the return if this
is an In Out parameter, but it's probably best to err on the side of
passing more things by reference. */
if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
return true;
if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
return true;
if (AGGREGATE_TYPE_P (gnu_type)
&& (!host_integerp (TYPE_SIZE (gnu_type), 1)
|| 0 < compare_tree_int (TYPE_SIZE (gnu_type),
8 * TYPE_ALIGN (gnu_type))))
return true;
return false;
}
/* GNU_TYPE is the type of a subprogram parameter. Determine from the type if
it should be passed by reference. */
bool
must_pass_by_ref (tree gnu_type)
{
/* We pass only unconstrained objects, those required by the language
to be passed by reference, and objects of variable size. The latter
is more efficient, avoids problems with variable size temporaries,
and does not produce compatibility problems with C, since C does
not have such objects. */
return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
|| (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
|| (TYPE_SIZE (gnu_type)
&& 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 (optab_handler (add_optab, j)->insn_code != CODE_FOR_nothing)
break;
if (float_p)
{
const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
mantissa = fmt->p;
}
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_PRECISION (mode) == prec)
return GET_MODE_BITSIZE (mode);
gcc_unreachable ();
}
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_BITSIZE (mode) == size)
return GET_MODE_PRECISION (mode);
gcc_unreachable ();
}
gcc/ada/targtyps.c deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* T A R G T Y P S *
* *
* Body *
* *
* Copyright (C) 1992-2007, 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 2, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
* to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
* Boston, MA 02110-1301, USA. *
* *
* As a special exception, if you link this file with other files to *
* produce an executable, this file does not by itself cause the resulting *
* executable to be covered by the GNU General Public License. This except- *
* ion does not however invalidate any other reasons why the executable *
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* Functions for retrieving target types. See Ada package Get_Targ */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "real.h"
#include "rtl.h"
#include "ada.h"
#include "types.h"
#include "atree.h"
#include "elists.h"
#include "namet.h"
#include "nlists.h"
#include "snames.h"
#include "stringt.h"
#include "uintp.h"
#include "urealp.h"
#include "fe.h"
#include "sinfo.h"
#include "einfo.h"
#include "ada-tree.h"
#include "gigi.h"
/* If we don't have a specific size for Ada's equivalent of `long', use that
of C. */
#ifndef ADA_LONG_TYPE_SIZE
#define ADA_LONG_TYPE_SIZE LONG_TYPE_SIZE
#endif
#ifndef WIDEST_HARDWARE_FP_SIZE
#define WIDEST_HARDWARE_FP_SIZE LONG_DOUBLE_TYPE_SIZE
#endif
/* The following provide a functional interface for the front end Ada code
to determine the sizes that are used for various C types. */
Pos
get_target_bits_per_unit (void)
{
return BITS_PER_UNIT;
}
Pos
get_target_bits_per_word (void)
{
return BITS_PER_WORD;
}
Pos
get_target_char_size (void)
{
return CHAR_TYPE_SIZE;
}
Pos
get_target_wchar_t_size (void)
{
/* We never want wide characters less than "short" in Ada. */
return MAX (SHORT_TYPE_SIZE, WCHAR_TYPE_SIZE);
}
Pos
get_target_short_size (void)
{
return SHORT_TYPE_SIZE;
}
Pos
get_target_int_size (void)
{
return INT_TYPE_SIZE;
}
Pos
get_target_long_size (void)
{
return ADA_LONG_TYPE_SIZE;
}
Pos
get_target_long_long_size (void)
{
return LONG_LONG_TYPE_SIZE;
}
Pos
get_target_float_size (void)
{
return fp_prec_to_size (FLOAT_TYPE_SIZE);
}
Pos
get_target_double_size (void)
{
return fp_prec_to_size (DOUBLE_TYPE_SIZE);
}
Pos
get_target_long_double_size (void)
{
return fp_prec_to_size (WIDEST_HARDWARE_FP_SIZE);
}
Pos
get_target_pointer_size (void)
{
return POINTER_SIZE;
}
/* Alignment related values, mapped to attributes for functional and
documentation purposes. */
/* Standard'Maximum_Default_Alignment. Maximum alignment that the compiler
might choose by default for a type or object.
Stricter alignment requests trigger gigi's aligning_type circuitry for
stack objects or objects allocated by the default allocator. */
Pos
get_target_maximum_default_alignment (void)
{
return BIGGEST_ALIGNMENT / BITS_PER_UNIT;
}
/* Standard'Default_Allocator_Alignment. Alignment guaranteed to be honored
by the default allocator (System.Memory.Alloc or malloc if we have no
run-time library at hand).
Stricter alignment requests trigger gigi's aligning_type circuitry for
objects allocated by the default allocator. */
Pos
get_target_default_allocator_alignment (void)
{
/* ??? Need a way to get info about __gnat_malloc from here (whether
it is handy and what alignment it honors). */
return MALLOC_ABI_ALIGNMENT / BITS_PER_UNIT;
}
/* Standard'Maximum_Allowed_Alignment. Maximum alignment that we may
accept for any type or object. */
#ifndef MAX_OFILE_ALIGNMENT
#define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT
#endif
Pos
get_target_maximum_allowed_alignment (void)
{
return MAX_OFILE_ALIGNMENT / BITS_PER_UNIT;
}
/* Standard'Maximum_Alignment. The single attribute initially made
available, now a synonym of Standard'Maximum_Default_Alignment. */
Pos
get_target_maximum_alignment (void)
{
return get_target_maximum_default_alignment ();
}
#ifndef FLOAT_WORDS_BIG_ENDIAN
#define FLOAT_WORDS_BIG_ENDIAN WORDS_BIG_ENDIAN
#endif
Nat
get_float_words_be (void)
{
return FLOAT_WORDS_BIG_ENDIAN;
}
Nat
get_words_be (void)
{
return WORDS_BIG_ENDIAN;
}
Nat
get_bytes_be (void)
{
return BYTES_BIG_ENDIAN;
}
Nat
get_bits_be (void)
{
return BITS_BIG_ENDIAN;
}
Nat
get_strict_alignment (void)
{
return STRICT_ALIGNMENT;
}
gcc/ada/trans.c deleted 100644 → 0
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/utils.c deleted 100644 → 0
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/utils2.c deleted 100644 → 0
/****************************************************************************
* *
* GNAT COMPILER COMPONENTS *
* *
* U T I L S 2 *
* *
* C Implementation File *
* *
* Copyright (C) 1992-2008, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* ware Foundation; either version 3, or (at your option) any later ver- *
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License along with GCC; see the file COPYING3. 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. *
* *
****************************************************************************/
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "rtl.h"
#include "ggc.h"
#include "flags.h"
#include "output.h"
#include "ada.h"
#include "types.h"
#include "atree.h"
#include "stringt.h"
#include "namet.h"
#include "uintp.h"
#include "fe.h"
#include "elists.h"
#include "nlists.h"
#include "sinfo.h"
#include "einfo.h"
#include "ada-tree.h"
#include "gigi.h"
static tree find_common_type (tree, tree);
static bool contains_save_expr_p (tree);
static tree contains_null_expr (tree);
static tree compare_arrays (tree, tree, tree);
static tree nonbinary_modular_operation (enum tree_code, tree, tree, tree);
static tree build_simple_component_ref (tree, tree, tree, bool);
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
This preparation consists of taking the ordinary representation of
an expression expr and producing a valid tree boolean expression
describing whether expr is nonzero. We could simply always do
build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
but we optimize comparisons, &&, ||, and !.
The resulting type should always be the same as the input type.
This function is simpler than the corresponding C version since
the only possible operands will be things of Boolean type. */
tree
gnat_truthvalue_conversion (tree expr)
{
tree type = TREE_TYPE (expr);
switch (TREE_CODE (expr))
{
case EQ_EXPR: case NE_EXPR: case LE_EXPR: case GE_EXPR:
case LT_EXPR: case GT_EXPR:
case TRUTH_ANDIF_EXPR:
case TRUTH_ORIF_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_OR_EXPR:
case TRUTH_XOR_EXPR:
case ERROR_MARK:
return expr;
case INTEGER_CST:
return (integer_zerop (expr)
? build_int_cst (type, 0)
: build_int_cst (type, 1));
case REAL_CST:
return (real_zerop (expr)
? fold_convert (type, integer_zero_node)
: fold_convert (type, integer_one_node));
case COND_EXPR:
/* Distribute the conversion into the arms of a COND_EXPR. */
{
tree arg1 = gnat_truthvalue_conversion (TREE_OPERAND (expr, 1));
tree arg2 = gnat_truthvalue_conversion (TREE_OPERAND (expr, 2));
return fold_build3 (COND_EXPR, type, TREE_OPERAND (expr, 0),
arg1, arg2);
}
default:
return build_binary_op (NE_EXPR, type, expr,
fold_convert (type, integer_zero_node));
}
}
/* Return the base type of TYPE. */
tree
get_base_type (tree type)
{
if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (type))
type = TREE_TYPE (TYPE_FIELDS (type));
while (TREE_TYPE (type)
&& (TREE_CODE (type) == INTEGER_TYPE
|| TREE_CODE (type) == REAL_TYPE))
type = TREE_TYPE (type);
return type;
}
/* EXP is a GCC tree representing an address. See if we can find how
strictly the object at that address is aligned. Return that alignment
in bits. If we don't know anything about the alignment, return 0. */
unsigned int
known_alignment (tree exp)
{
unsigned int this_alignment;
unsigned int lhs, rhs;
switch (TREE_CODE (exp))
{
CASE_CONVERT:
case VIEW_CONVERT_EXPR:
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));
break;
case COMPOUND_EXPR:
/* The value of a COMPOUND_EXPR is that of it's second operand. */
this_alignment = known_alignment (TREE_OPERAND (exp, 1));
break;
case PLUS_EXPR:
case MINUS_EXPR:
/* If two address are added, the alignment of the result is the
minimum of the two alignments. */
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
this_alignment = MIN (lhs, rhs);
break;
case POINTER_PLUS_EXPR:
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
/* If we don't know the alignment of the offset, we assume that
of the base. */
if (rhs == 0)
this_alignment = lhs;
else
this_alignment = MIN (lhs, rhs);
break;
case COND_EXPR:
/* If there is a choice between two values, use the smallest one. */
lhs = known_alignment (TREE_OPERAND (exp, 1));
rhs = known_alignment (TREE_OPERAND (exp, 2));
this_alignment = MIN (lhs, rhs);
break;
case INTEGER_CST:
{
unsigned HOST_WIDE_INT c = TREE_INT_CST_LOW (exp);
/* The first part of this represents the lowest bit in the constant,
but it is originally in bytes, not bits. */
this_alignment = MIN (BITS_PER_UNIT * (c & -c), BIGGEST_ALIGNMENT);
}
break;
case MULT_EXPR:
/* If we know the alignment of just one side, use it. Otherwise,
use the product of the alignments. */
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
if (lhs == 0)
this_alignment = rhs;
else if (rhs == 0)
this_alignment = lhs;
else
this_alignment = MIN (lhs * rhs, BIGGEST_ALIGNMENT);
break;
case BIT_AND_EXPR:
/* A bit-and expression is as aligned as the maximum alignment of the
operands. We typically get here for a complex lhs and a constant
negative power of two on the rhs to force an explicit alignment, so
don't bother looking at the lhs. */
this_alignment = known_alignment (TREE_OPERAND (exp, 1));
break;
case ADDR_EXPR:
this_alignment = expr_align (TREE_OPERAND (exp, 0));
break;
default:
/* For other pointer expressions, we assume that the pointed-to object
is at least as aligned as the pointed-to type. Beware that we can
have a dummy type here (e.g. a Taft Amendment type), for which the
alignment is meaningless and should be ignored. */
if (POINTER_TYPE_P (TREE_TYPE (exp))
&& !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
this_alignment = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp)));
else
this_alignment = 0;
break;
}
return this_alignment;
}
/* We have a comparison or assignment operation on two types, T1 and T2, which
are either both array types or both record types. T1 is assumed to be for
the left hand side operand, and T2 for the right hand side. Return the
type that both operands should be converted to for the operation, if any.
Otherwise return zero. */
static tree
find_common_type (tree t1, tree t2)
{
/* ??? As of today, various constructs lead here with types of different
sizes even when both constants (e.g. tagged types, packable vs regular
component types, padded vs unpadded types, ...). While some of these
would better be handled upstream (types should be made consistent before
calling into build_binary_op), some others are really expected and we
have to be careful. */
/* We must prevent writing more than what the target may hold if this is for
an assignment and the case of tagged types is handled in build_binary_op
so use the lhs type if it is known to be smaller, or of constant size and
the rhs type is not, whatever the modes. We also force t1 in case of
constant size equality to minimize occurrences of view conversions on the
lhs of assignments. */
if (TREE_CONSTANT (TYPE_SIZE (t1))
&& (!TREE_CONSTANT (TYPE_SIZE (t2))
|| !tree_int_cst_lt (TYPE_SIZE (t2), TYPE_SIZE (t1))))
return t1;
/* Otherwise, if the lhs type is non-BLKmode, use it. Note that we know
that we will not have any alignment problems since, if we did, the
non-BLKmode type could not have been used. */
if (TYPE_MODE (t1) != BLKmode)
return t1;
/* If the rhs type is of constant size, use it whatever the modes. At
this point it is known to be smaller, or of constant size and the
lhs type is not. */
if (TREE_CONSTANT (TYPE_SIZE (t2)))
return t2;
/* Otherwise, if the rhs type is non-BLKmode, use it. */
if (TYPE_MODE (t2) != BLKmode)
return t2;
/* In this case, both types have variable size and BLKmode. It's
probably best to leave the "type mismatch" because changing it
could cause a bad self-referential reference. */
return NULL_TREE;
}
/* See if EXP contains a SAVE_EXPR in a position where we would
normally put it.
??? This is a real kludge, but is probably the best approach short
of some very general solution. */
static bool
contains_save_expr_p (tree exp)
{
switch (TREE_CODE (exp))
{
case SAVE_EXPR:
return true;
case ADDR_EXPR: case INDIRECT_REF:
case COMPONENT_REF:
CASE_CONVERT: case VIEW_CONVERT_EXPR:
return contains_save_expr_p (TREE_OPERAND (exp, 0));
case CONSTRUCTOR:
{
tree value;
unsigned HOST_WIDE_INT ix;
FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (exp), ix, value)
if (contains_save_expr_p (value))
return true;
return false;
}
default:
return false;
}
}
/* See if EXP contains a NULL_EXPR in an expression we use for sizes. Return
it if so. This is used to detect types whose sizes involve computations
that are known to raise Constraint_Error. */
static tree
contains_null_expr (tree exp)
{
tree tem;
if (TREE_CODE (exp) == NULL_EXPR)
return exp;
switch (TREE_CODE_CLASS (TREE_CODE (exp)))
{
case tcc_unary:
return contains_null_expr (TREE_OPERAND (exp, 0));
case tcc_comparison:
case tcc_binary:
tem = contains_null_expr (TREE_OPERAND (exp, 0));
if (tem)
return tem;
return contains_null_expr (TREE_OPERAND (exp, 1));
case tcc_expression:
switch (TREE_CODE (exp))
{
case SAVE_EXPR:
return contains_null_expr (TREE_OPERAND (exp, 0));
case COND_EXPR:
tem = contains_null_expr (TREE_OPERAND (exp, 0));
if (tem)
return tem;
tem = contains_null_expr (TREE_OPERAND (exp, 1));
if (tem)
return tem;
return contains_null_expr (TREE_OPERAND (exp, 2));
default:
return 0;
}
default:
return 0;
}
}
/* Return an expression tree representing an equality comparison of
A1 and A2, two objects of ARRAY_TYPE. The returned expression should
be of type RESULT_TYPE
Two arrays are equal in one of two ways: (1) if both have zero length
in some dimension (not necessarily the same dimension) or (2) if the
lengths in each dimension are equal and the data is equal. We perform the
length tests in as efficient a manner as possible. */
static tree
compare_arrays (tree result_type, tree a1, tree a2)
{
tree t1 = TREE_TYPE (a1);
tree t2 = TREE_TYPE (a2);
tree result = convert (result_type, integer_one_node);
tree a1_is_null = convert (result_type, integer_zero_node);
tree a2_is_null = convert (result_type, integer_zero_node);
bool length_zero_p = false;
/* Process each dimension separately and compare the lengths. If any
dimension has a size known to be zero, set SIZE_ZERO_P to 1 to
suppress the comparison of the data. */
while (TREE_CODE (t1) == ARRAY_TYPE && TREE_CODE (t2) == ARRAY_TYPE)
{
tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1));
tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1));
tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2));
tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2));
tree bt = get_base_type (TREE_TYPE (lb1));
tree length1 = fold_build2 (MINUS_EXPR, bt, ub1, lb1);
tree length2 = fold_build2 (MINUS_EXPR, bt, ub2, lb2);
tree nbt;
tree tem;
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.
Note that we have set the `length' values to the length - 1. */
if (TREE_CODE (length1) == INTEGER_CST
&& !integer_zerop (fold_build2 (PLUS_EXPR, bt, length2,
convert (bt, integer_one_node))))
{
tem = a1, a1 = a2, a2 = tem;
tem = t1, t1 = t2, t2 = tem;
tem = lb1, lb1 = lb2, lb2 = tem;
tem = ub1, ub1 = ub2, ub2 = tem;
tem = length1, length1 = length2, length2 = tem;
tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem;
}
/* If the length of this dimension in the second array is the constant
zero, we can just go inside the original bounds for the first
array and see if last < first. */
if (integer_zerop (fold_build2 (PLUS_EXPR, bt, length2,
convert (bt, integer_one_node))))
{
tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
comparison = build_binary_op (LT_EXPR, result_type, ub, lb);
comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
length_zero_p = true;
this_a1_is_null = comparison;
this_a2_is_null = convert (result_type, integer_one_node);
}
/* If the length is some other constant value, we know that the
this dimension in the first array cannot be superflat, so we
can just use its length from the actual stored bounds. */
else if (TREE_CODE (length2) == INTEGER_CST)
{
ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
nbt = get_base_type (TREE_TYPE (ub1));
comparison
= build_binary_op (EQ_EXPR, result_type,
build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
/* Note that we know that UB2 and LB2 are constant and hence
cannot contain a PLACEHOLDER_EXPR. */
comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1);
this_a2_is_null = convert (result_type, integer_zero_node);
}
/* Otherwise compare the computed lengths. */
else
{
length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2);
comparison
= build_binary_op (EQ_EXPR, result_type, length1, length2);
this_a1_is_null
= build_binary_op (LT_EXPR, result_type, length1,
convert (bt, integer_zero_node));
this_a2_is_null
= build_binary_op (LT_EXPR, result_type, length2,
convert (bt, integer_zero_node));
}
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type,
result, comparison);
a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
this_a1_is_null, a1_is_null);
a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
this_a2_is_null, a2_is_null);
t1 = TREE_TYPE (t1);
t2 = TREE_TYPE (t2);
}
/* Unless the size of some bound is known to be zero, compare the
data in the array. */
if (!length_zero_p)
{
tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2));
if (type)
a1 = convert (type, a1), a2 = convert (type, a2);
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
fold_build2 (EQ_EXPR, result_type, a1, a2));
}
/* The result is also true if both sizes are zero. */
result = build_binary_op (TRUTH_ORIF_EXPR, result_type,
build_binary_op (TRUTH_ANDIF_EXPR, result_type,
a1_is_null, a2_is_null),
result);
/* If either operand contains SAVE_EXPRs, they have to be evaluated before
starting the comparison above since the place it would be otherwise
evaluated would be wrong. */
if (contains_save_expr_p (a1))
result = build2 (COMPOUND_EXPR, result_type, a1, result);
if (contains_save_expr_p (a2))
result = build2 (COMPOUND_EXPR, result_type, a2, result);
return result;
}
/* Compute the result of applying OP_CODE to LHS and RHS, where both are of
type TYPE. We know that TYPE is a modular type with a nonbinary
modulus. */
static tree
nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
tree rhs)
{
tree modulus = TYPE_MODULUS (type);
unsigned int needed_precision = tree_floor_log2 (modulus) + 1;
unsigned int precision;
bool unsignedp = true;
tree op_type = type;
tree result;
/* If this is an addition of a constant, convert it to a subtraction
of a constant since we can do that faster. */
if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
{
rhs = fold_build2 (MINUS_EXPR, type, modulus, rhs);
op_code = MINUS_EXPR;
}
/* For the logical operations, we only need PRECISION bits. For
addition and subtraction, we need one more and for multiplication we
need twice as many. But we never want to make a size smaller than
our size. */
if (op_code == PLUS_EXPR || op_code == MINUS_EXPR)
needed_precision += 1;
else if (op_code == MULT_EXPR)
needed_precision *= 2;
precision = MAX (needed_precision, TYPE_PRECISION (op_type));
/* Unsigned will do for everything but subtraction. */
if (op_code == MINUS_EXPR)
unsignedp = false;
/* If our type is the wrong signedness or isn't wide enough, make a new
type and convert both our operands to it. */
if (TYPE_PRECISION (op_type) < precision
|| TYPE_UNSIGNED (op_type) != unsignedp)
{
/* Copy the node so we ensure it can be modified to make it modular. */
op_type = copy_node (gnat_type_for_size (precision, unsignedp));
modulus = convert (op_type, modulus);
SET_TYPE_MODULUS (op_type, modulus);
TYPE_MODULAR_P (op_type) = 1;
lhs = convert (op_type, lhs);
rhs = convert (op_type, rhs);
}
/* Do the operation, then we'll fix it up. */
result = fold_build2 (op_code, op_type, lhs, rhs);
/* For multiplication, we have no choice but to do a full modulus
operation. However, we want to do this in the narrowest
possible size. */
if (op_code == MULT_EXPR)
{
tree div_type = copy_node (gnat_type_for_size (needed_precision, 1));
modulus = convert (div_type, modulus);
SET_TYPE_MODULUS (div_type, modulus);
TYPE_MODULAR_P (div_type) = 1;
result = convert (op_type,
fold_build2 (TRUNC_MOD_EXPR, div_type,
convert (div_type, result), modulus));
}
/* For subtraction, add the modulus back if we are negative. */
else if (op_code == MINUS_EXPR)
{
result = save_expr (result);
result = fold_build3 (COND_EXPR, op_type,
fold_build2 (LT_EXPR, integer_type_node, result,
convert (op_type, integer_zero_node)),
fold_build2 (PLUS_EXPR, op_type, result, modulus),
result);
}
/* For the other operations, subtract the modulus if we are >= it. */
else
{
result = save_expr (result);
result = fold_build3 (COND_EXPR, op_type,
fold_build2 (GE_EXPR, integer_type_node,
result, modulus),
fold_build2 (MINUS_EXPR, op_type,
result, modulus),
result);
}
return convert (type, result);
}
/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
desired for the result. Usually the operation is to be performed
in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
in which case the type to be used will be derived from the operands.
This function is very much unlike the ones for C and C++ since we
have already done any type conversion and matching required. All we
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,
tree left_operand, tree right_operand)
{
tree left_type = TREE_TYPE (left_operand);
tree right_type = TREE_TYPE (right_operand);
tree left_base_type = get_base_type (left_type);
tree right_base_type = get_base_type (right_type);
tree operation_type = result_type;
tree best_type = NULL_TREE;
tree modulus, result;
bool has_side_effects = false;
if (operation_type
&& TREE_CODE (operation_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (operation_type))
operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
if (operation_type
&& !AGGREGATE_TYPE_P (operation_type)
&& TYPE_EXTRA_SUBTYPE_P (operation_type))
operation_type = get_base_type (operation_type);
modulus = (operation_type
&& TREE_CODE (operation_type) == INTEGER_TYPE
&& TYPE_MODULAR_P (operation_type)
? TYPE_MODULUS (operation_type) : NULL_TREE);
switch (op_code)
{
case MODIFY_EXPR:
/* If there were integral or pointer conversions on the LHS, remove
them; we'll be putting them back below if needed. Likewise for
conversions between array and record types, except for justified
modular types. But don't do this if the right operand is not
BLKmode (for packed arrays) unless we are not changing the mode. */
while ((CONVERT_EXPR_P (left_operand)
|| TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
&& (((INTEGRAL_TYPE_P (left_type)
|| POINTER_TYPE_P (left_type))
&& (INTEGRAL_TYPE_P (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))
|| POINTER_TYPE_P (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))))
|| (((TREE_CODE (left_type) == RECORD_TYPE
&& !TYPE_JUSTIFIED_MODULAR_P (left_type))
|| TREE_CODE (left_type) == ARRAY_TYPE)
&& ((TREE_CODE (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))
== RECORD_TYPE)
|| (TREE_CODE (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))
== ARRAY_TYPE))
&& (TYPE_MODE (right_type) == BLKmode
|| (TYPE_MODE (left_type)
== TYPE_MODE (TREE_TYPE
(TREE_OPERAND
(left_operand, 0))))))))
{
left_operand = TREE_OPERAND (left_operand, 0);
left_type = TREE_TYPE (left_operand);
}
/* If a class-wide type may be involved, force use of the RHS type. */
if ((TREE_CODE (right_type) == RECORD_TYPE
|| TREE_CODE (right_type) == UNION_TYPE)
&& TYPE_ALIGN_OK (right_type))
operation_type = right_type;
/* If we are copying between padded objects with compatible types, use
the padded view of the objects, this is very likely more efficient.
Likewise for a padded that is assigned a constructor, in order to
avoid putting a VIEW_CONVERT_EXPR on the LHS. But don't do this if
we wouldn't have actually copied anything. */
else if (TREE_CODE (left_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (left_type)
&& TREE_CONSTANT (TYPE_SIZE (left_type))
&& ((TREE_CODE (right_operand) == COMPONENT_REF
&& TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== RECORD_TYPE
&& TYPE_IS_PADDING_P
(TREE_TYPE (TREE_OPERAND (right_operand, 0)))
&& gnat_types_compatible_p
(left_type,
TREE_TYPE (TREE_OPERAND (right_operand, 0))))
|| TREE_CODE (right_operand) == CONSTRUCTOR)
&& !integer_zerop (TYPE_SIZE (right_type)))
operation_type = left_type;
/* Find the best type to use for copying between aggregate types. */
else if (((TREE_CODE (left_type) == ARRAY_TYPE
&& TREE_CODE (right_type) == ARRAY_TYPE)
|| (TREE_CODE (left_type) == RECORD_TYPE
&& TREE_CODE (right_type) == RECORD_TYPE))
&& (best_type = find_common_type (left_type, right_type)))
operation_type = best_type;
/* Otherwise use the LHS type. */
else if (!operation_type)
operation_type = left_type;
/* Ensure everything on the LHS is valid. If we have a field reference,
strip anything that get_inner_reference can handle. Then remove any
conversions between types having the same code and mode. And mark
VIEW_CONVERT_EXPRs with TREE_ADDRESSABLE. When done, we must have
either an INDIRECT_REF, a NULL_EXPR or a DECL node. */
result = left_operand;
while (true)
{
tree restype = TREE_TYPE (result);
if (TREE_CODE (result) == COMPONENT_REF
|| TREE_CODE (result) == ARRAY_REF
|| TREE_CODE (result) == ARRAY_RANGE_REF)
while (handled_component_p (result))
result = TREE_OPERAND (result, 0);
else if (TREE_CODE (result) == REALPART_EXPR
|| TREE_CODE (result) == IMAGPART_EXPR
|| (CONVERT_EXPR_P (result)
&& (((TREE_CODE (restype)
== TREE_CODE (TREE_TYPE
(TREE_OPERAND (result, 0))))
&& (TYPE_MODE (TREE_TYPE
(TREE_OPERAND (result, 0)))
== TYPE_MODE (restype)))
|| TYPE_ALIGN_OK (restype))))
result = TREE_OPERAND (result, 0);
else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
{
TREE_ADDRESSABLE (result) = 1;
result = TREE_OPERAND (result, 0);
}
else
break;
}
gcc_assert (TREE_CODE (result) == INDIRECT_REF
|| TREE_CODE (result) == NULL_EXPR
|| DECL_P (result));
/* Convert the right operand to the operation type unless it is
either already of the correct type or if the type involves a
placeholder, since the RHS may not have the same record type. */
if (operation_type != right_type
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type)))
{
right_operand = convert (operation_type, right_operand);
right_type = operation_type;
}
/* If the left operand is not of the same type as the operation
type, wrap it up in a VIEW_CONVERT_EXPR. */
if (left_type != operation_type)
left_operand = unchecked_convert (operation_type, left_operand, false);
has_side_effects = true;
modulus = NULL_TREE;
break;
case ARRAY_REF:
if (!operation_type)
operation_type = TREE_TYPE (left_type);
/* ... fall through ... */
case ARRAY_RANGE_REF:
/* First look through conversion between type variants. Note that
this changes neither the operation type nor the type domain. */
if (TREE_CODE (left_operand) == VIEW_CONVERT_EXPR
&& TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (left_operand, 0)))
== TYPE_MAIN_VARIANT (left_type))
{
left_operand = TREE_OPERAND (left_operand, 0);
left_type = TREE_TYPE (left_operand);
}
/* Then convert the right operand to its base type. This will
prevent unneeded signedness conversions when sizetype is wider than
integer. */
right_operand = convert (right_base_type, right_operand);
right_operand = convert (TYPE_DOMAIN (left_type), right_operand);
if (!TREE_CONSTANT (right_operand)
|| !TREE_CONSTANT (TYPE_MIN_VALUE (right_type)))
gnat_mark_addressable (left_operand);
modulus = NULL_TREE;
break;
case GE_EXPR:
case LE_EXPR:
case GT_EXPR:
case LT_EXPR:
gcc_assert (!POINTER_TYPE_P (left_type));
/* ... fall through ... */
case EQ_EXPR:
case NE_EXPR:
/* If either operand is a NULL_EXPR, just return a new one. */
if (TREE_CODE (left_operand) == NULL_EXPR)
return build2 (op_code, result_type,
build1 (NULL_EXPR, integer_type_node,
TREE_OPERAND (left_operand, 0)),
integer_zero_node);
else if (TREE_CODE (right_operand) == NULL_EXPR)
return build2 (op_code, result_type,
build1 (NULL_EXPR, integer_type_node,
TREE_OPERAND (right_operand, 0)),
integer_zero_node);
/* If either object is a justified modular types, get the
fields from within. */
if (TREE_CODE (left_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (left_type))
{
left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)),
left_operand);
left_type = TREE_TYPE (left_operand);
left_base_type = get_base_type (left_type);
}
if (TREE_CODE (right_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (right_type))
{
right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)),
right_operand);
right_type = TREE_TYPE (right_operand);
right_base_type = get_base_type (right_type);
}
/* If both objects are arrays, compare them specially. */
if ((TREE_CODE (left_type) == ARRAY_TYPE
|| (TREE_CODE (left_type) == INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (left_type)))
&& (TREE_CODE (right_type) == ARRAY_TYPE
|| (TREE_CODE (right_type) == INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (right_type))))
{
result = compare_arrays (result_type, left_operand, right_operand);
if (op_code == NE_EXPR)
result = invert_truthvalue (result);
else
gcc_assert (op_code == EQ_EXPR);
return result;
}
/* Otherwise, the base types must be the same unless the objects are
fat pointers or records. If we have records, use the best type and
convert both operands to that type. */
if (left_base_type != right_base_type)
{
if (TYPE_FAT_POINTER_P (left_base_type)
&& TYPE_FAT_POINTER_P (right_base_type)
&& TYPE_MAIN_VARIANT (left_base_type)
== TYPE_MAIN_VARIANT (right_base_type))
best_type = left_base_type;
else if (TREE_CODE (left_base_type) == RECORD_TYPE
&& TREE_CODE (right_base_type) == RECORD_TYPE)
{
/* The only way these are permitted to be the same is if both
types have the same name. In that case, one of them must
not be self-referential. Use that one as the best type.
Even better is if one is of fixed size. */
gcc_assert (TYPE_NAME (left_base_type)
&& (TYPE_NAME (left_base_type)
== TYPE_NAME (right_base_type)));
if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
best_type = left_base_type;
else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
best_type = right_base_type;
else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type)))
best_type = left_base_type;
else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type)))
best_type = right_base_type;
else
gcc_unreachable ();
}
else
gcc_unreachable ();
left_operand = convert (best_type, left_operand);
right_operand = convert (best_type, right_operand);
}
/* 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
&& integer_zerop (VEC_index (constructor_elt,
CONSTRUCTOR_ELTS (right_operand),
0)
->value))
{
right_operand = build_component_ref (left_operand, NULL_TREE,
TYPE_FIELDS (left_base_type),
false);
left_operand = convert (TREE_TYPE (right_operand),
integer_zero_node);
}
else
{
left_operand = convert (left_base_type, left_operand);
right_operand = convert (right_base_type, right_operand);
}
modulus = NULL_TREE;
break;
case PREINCREMENT_EXPR:
case PREDECREMENT_EXPR:
case POSTINCREMENT_EXPR:
case POSTDECREMENT_EXPR:
/* In these, the result type and the left operand type should be the
same. Do the operation in the base type of those and convert the
right operand (which is an integer) to that type.
Note that these operations are only used in loop control where
we guarantee that no overflow can occur. So nothing special need
be done for modular types. */
gcc_assert (left_type == result_type);
operation_type = get_base_type (result_type);
left_operand = convert (operation_type, left_operand);
right_operand = convert (operation_type, right_operand);
has_side_effects = true;
modulus = NULL_TREE;
break;
case LSHIFT_EXPR:
case RSHIFT_EXPR:
case LROTATE_EXPR:
case RROTATE_EXPR:
/* The RHS of a shift can be any type. Also, ignore any modulus
(we used to abort, but this is needed for unchecked conversion
to modular types). Otherwise, processing is the same as normal. */
gcc_assert (operation_type == left_base_type);
modulus = NULL_TREE;
left_operand = convert (operation_type, left_operand);
break;
case TRUTH_ANDIF_EXPR:
case TRUTH_ORIF_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_OR_EXPR:
case TRUTH_XOR_EXPR:
left_operand = gnat_truthvalue_conversion (left_operand);
right_operand = gnat_truthvalue_conversion (right_operand);
goto common;
case BIT_AND_EXPR:
case BIT_IOR_EXPR:
case BIT_XOR_EXPR:
/* For binary modulus, if the inputs are in range, so are the
outputs. */
if (modulus && integer_pow2p (modulus))
modulus = NULL_TREE;
goto common;
case COMPLEX_EXPR:
gcc_assert (TREE_TYPE (result_type) == left_base_type
&& TREE_TYPE (result_type) == right_base_type);
left_operand = convert (left_base_type, left_operand);
right_operand = convert (right_base_type, right_operand);
break;
case TRUNC_DIV_EXPR: case TRUNC_MOD_EXPR:
case CEIL_DIV_EXPR: case CEIL_MOD_EXPR:
case FLOOR_DIV_EXPR: case FLOOR_MOD_EXPR:
case ROUND_DIV_EXPR: case ROUND_MOD_EXPR:
/* These always produce results lower than either operand. */
modulus = NULL_TREE;
goto common;
case POINTER_PLUS_EXPR:
gcc_assert (operation_type == left_base_type
&& sizetype == right_base_type);
left_operand = convert (operation_type, left_operand);
right_operand = convert (sizetype, right_operand);
break;
default:
common:
/* The result type should be the same as the base types of the
both operands (and they should be the same). Convert
everything to the result type. */
gcc_assert (operation_type == left_base_type
&& left_base_type == right_base_type);
left_operand = convert (operation_type, left_operand);
right_operand = convert (operation_type, right_operand);
}
if (modulus && !integer_pow2p (modulus))
{
result = nonbinary_modular_operation (op_code, operation_type,
left_operand, right_operand);
modulus = NULL_TREE;
}
/* If either operand is a NULL_EXPR, just return a new one. */
else if (TREE_CODE (left_operand) == NULL_EXPR)
return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0));
else if (TREE_CODE (right_operand) == NULL_EXPR)
return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
result = fold (build4 (op_code, operation_type, left_operand,
right_operand, NULL_TREE, NULL_TREE));
else
result
= fold_build2 (op_code, operation_type, left_operand, right_operand);
TREE_SIDE_EFFECTS (result) |= has_side_effects;
TREE_CONSTANT (result)
|= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
&& op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
&& TYPE_VOLATILE (operation_type))
TREE_THIS_VOLATILE (result) = 1;
/* If we are working with modular types, perform the MOD operation
if something above hasn't eliminated the need for it. */
if (modulus)
result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result,
convert (operation_type, modulus));
if (result_type && result_type != operation_type)
result = convert (result_type, result);
return result;
}
/* Similar, but for unary operations. */
tree
build_unary_op (enum tree_code op_code, tree result_type, tree operand)
{
tree type = TREE_TYPE (operand);
tree base_type = get_base_type (type);
tree operation_type = result_type;
tree result;
bool side_effects = false;
if (operation_type
&& TREE_CODE (operation_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (operation_type))
operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
if (operation_type
&& !AGGREGATE_TYPE_P (operation_type)
&& TYPE_EXTRA_SUBTYPE_P (operation_type))
operation_type = get_base_type (operation_type);
switch (op_code)
{
case REALPART_EXPR:
case IMAGPART_EXPR:
if (!operation_type)
result_type = operation_type = TREE_TYPE (type);
else
gcc_assert (result_type == TREE_TYPE (type));
result = fold_build1 (op_code, operation_type, operand);
break;
case TRUTH_NOT_EXPR:
gcc_assert (result_type == base_type);
result = invert_truthvalue (gnat_truthvalue_conversion (operand));
break;
case ATTR_ADDR_EXPR:
case ADDR_EXPR:
switch (TREE_CODE (operand))
{
case INDIRECT_REF:
case UNCONSTRAINED_ARRAY_REF:
result = TREE_OPERAND (operand, 0);
/* Make sure the type here is a pointer, not a reference.
GCC wants pointer types for function addresses. */
if (!result_type)
result_type = build_pointer_type (type);
/* If the underlying object can alias everything, propagate the
property since we are effectively retrieving the object. */
if (POINTER_TYPE_P (TREE_TYPE (result))
&& TYPE_REF_CAN_ALIAS_ALL (TREE_TYPE (result)))
{
if (TREE_CODE (result_type) == POINTER_TYPE
&& !TYPE_REF_CAN_ALIAS_ALL (result_type))
result_type
= build_pointer_type_for_mode (TREE_TYPE (result_type),
TYPE_MODE (result_type),
true);
else if (TREE_CODE (result_type) == REFERENCE_TYPE
&& !TYPE_REF_CAN_ALIAS_ALL (result_type))
result_type
= build_reference_type_for_mode (TREE_TYPE (result_type),
TYPE_MODE (result_type),
true);
}
break;
case NULL_EXPR:
result = operand;
TREE_TYPE (result) = type = build_pointer_type (type);
break;
case ARRAY_REF:
case ARRAY_RANGE_REF:
case COMPONENT_REF:
case BIT_FIELD_REF:
/* If this is for 'Address, find the address of the prefix and
add the offset to the field. Otherwise, do this the normal
way. */
if (op_code == ATTR_ADDR_EXPR)
{
HOST_WIDE_INT bitsize;
HOST_WIDE_INT bitpos;
tree offset, inner;
enum machine_mode mode;
int unsignedp, volatilep;
inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
&mode, &unsignedp, &volatilep,
false);
/* If INNER is a padding type whose field has a self-referential
size, convert to that inner type. We know the offset is zero
and we need to have that type visible. */
if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (inner))
&& (CONTAINS_PLACEHOLDER_P
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
(TREE_TYPE (inner)))))))
inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
inner);
/* Compute the offset as a byte offset from INNER. */
if (!offset)
offset = size_zero_node;
if (bitpos % BITS_PER_UNIT != 0)
post_error
("taking address of object not aligned on storage unit?",
error_gnat_node);
offset = size_binop (PLUS_EXPR, offset,
size_int (bitpos / BITS_PER_UNIT));
/* Take the address of INNER, convert the offset to void *, and
add then. It will later be converted to the desired result
type, if any. */
inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
inner = convert (ptr_void_type_node, inner);
result = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
inner, offset);
result = convert (build_pointer_type (TREE_TYPE (operand)),
result);
break;
}
goto common;
case CONSTRUCTOR:
/* If this is just a constructor for a padded record, we can
just take the address of the single field and convert it to
a pointer to our type. */
if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
result = (VEC_index (constructor_elt,
CONSTRUCTOR_ELTS (operand),
0)
->value);
result = convert (build_pointer_type (TREE_TYPE (operand)),
build_unary_op (ADDR_EXPR, NULL_TREE, result));
break;
}
goto common;
case NOP_EXPR:
if (AGGREGATE_TYPE_P (type)
&& AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
return build_unary_op (ADDR_EXPR, result_type,
TREE_OPERAND (operand, 0));
/* ... fallthru ... */
case VIEW_CONVERT_EXPR:
/* If this just a variant conversion or if the conversion doesn't
change the mode, get the result type from this type and go down.
This is needed for conversions of CONST_DECLs, to eventually get
to the address of their CORRESPONDING_VARs. */
if ((TYPE_MAIN_VARIANT (type)
== TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
|| (TYPE_MODE (type) != BLKmode
&& (TYPE_MODE (type)
== TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
return build_unary_op (ADDR_EXPR,
(result_type ? result_type
: build_pointer_type (type)),
TREE_OPERAND (operand, 0));
goto common;
case CONST_DECL:
operand = DECL_CONST_CORRESPONDING_VAR (operand);
/* ... fall through ... */
default:
common:
/* If we are taking the address of a padded record whose field is
contains a template, take the address of the template. */
if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type)
&& TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
{
type = TREE_TYPE (TYPE_FIELDS (type));
operand = convert (type, operand);
}
if (type != error_mark_node)
operation_type = build_pointer_type (type);
gnat_mark_addressable (operand);
result = fold_build1 (ADDR_EXPR, operation_type, operand);
}
TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
break;
case INDIRECT_REF:
/* If we want to refer to an entire unconstrained array,
make up an expression to do so. This will never survive to
the backend. If TYPE is a thin pointer, first convert the
operand to a fat pointer. */
if (TYPE_THIN_POINTER_P (type)
&& TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
{
operand
= convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
operand);
type = TREE_TYPE (operand);
}
if (TYPE_FAT_POINTER_P (type))
{
result = build1 (UNCONSTRAINED_ARRAY_REF,
TYPE_UNCONSTRAINED_ARRAY (type), operand);
TREE_READONLY (result) = TREE_STATIC (result)
= TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type));
}
else if (TREE_CODE (operand) == ADDR_EXPR)
result = TREE_OPERAND (operand, 0);
else
{
result = fold_build1 (op_code, TREE_TYPE (type), operand);
TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
}
side_effects
= (!TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
break;
case NEGATE_EXPR:
case BIT_NOT_EXPR:
{
tree modulus = ((operation_type
&& TREE_CODE (operation_type) == INTEGER_TYPE
&& TYPE_MODULAR_P (operation_type))
? TYPE_MODULUS (operation_type) : NULL_TREE);
int mod_pow2 = modulus && integer_pow2p (modulus);
/* If this is a modular type, there are various possibilities
depending on the operation and whether the modulus is a
power of two or not. */
if (modulus)
{
gcc_assert (operation_type == base_type);
operand = convert (operation_type, operand);
/* The fastest in the negate case for binary modulus is
the straightforward code; the TRUNC_MOD_EXPR below
is an AND operation. */
if (op_code == NEGATE_EXPR && mod_pow2)
result = fold_build2 (TRUNC_MOD_EXPR, operation_type,
fold_build1 (NEGATE_EXPR, operation_type,
operand),
modulus);
/* For nonbinary negate case, return zero for zero operand,
else return the modulus minus the operand. If the modulus
is a power of two minus one, we can do the subtraction
as an XOR since it is equivalent and faster on most machines. */
else if (op_code == NEGATE_EXPR && !mod_pow2)
{
if (integer_pow2p (fold_build2 (PLUS_EXPR, operation_type,
modulus,
convert (operation_type,
integer_one_node))))
result = fold_build2 (BIT_XOR_EXPR, operation_type,
operand, modulus);
else
result = fold_build2 (MINUS_EXPR, operation_type,
modulus, operand);
result = fold_build3 (COND_EXPR, operation_type,
fold_build2 (NE_EXPR,
integer_type_node,
operand,
convert
(operation_type,
integer_zero_node)),
result, operand);
}
else
{
/* For the NOT cases, we need a constant equal to
the modulus minus one. For a binary modulus, we
XOR against the constant and subtract the operand from
that constant for nonbinary modulus. */
tree cnst = fold_build2 (MINUS_EXPR, operation_type, modulus,
convert (operation_type,
integer_one_node));
if (mod_pow2)
result = fold_build2 (BIT_XOR_EXPR, operation_type,
operand, cnst);
else
result = fold_build2 (MINUS_EXPR, operation_type,
cnst, operand);
}
break;
}
}
/* ... fall through ... */
default:
gcc_assert (operation_type == base_type);
result = fold_build1 (op_code, operation_type,
convert (operation_type, operand));
}
if (side_effects)
{
TREE_SIDE_EFFECTS (result) = 1;
if (TREE_CODE (result) == INDIRECT_REF)
TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
}
if (result_type && TREE_TYPE (result) != result_type)
result = convert (result_type, result);
return result;
}
/* Similar, but for COND_EXPR. */
tree
build_cond_expr (tree result_type, tree condition_operand,
tree true_operand, tree false_operand)
{
tree result;
bool addr_p = false;
/* The front-end verifies that result, true and false operands have same base
type. Convert everything to the result type. */
true_operand = convert (result_type, true_operand);
false_operand = convert (result_type, false_operand);
/* If the result type is unconstrained, take the address of
the operands and then dereference our result. */
if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
|| CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
{
addr_p = true;
result_type = build_pointer_type (result_type);
true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
}
result = fold_build3 (COND_EXPR, result_type, condition_operand,
true_operand, false_operand);
/* If either operand is a SAVE_EXPR (possibly surrounded by
arithmetic, make sure it gets done. */
true_operand = skip_simple_arithmetic (true_operand);
false_operand = skip_simple_arithmetic (false_operand);
if (TREE_CODE (true_operand) == SAVE_EXPR)
result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
if (TREE_CODE (false_operand) == SAVE_EXPR)
result = build2 (COMPOUND_EXPR, result_type, false_operand, result);
/* ??? Seems the code above is wrong, as it may move ahead of the COND
SAVE_EXPRs with side effects and not shared by both arms. */
if (addr_p)
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
return result;
}
/* Similar, but for RETURN_EXPR. If RESULT_DECL is non-zero, build
a RETURN_EXPR around the assignment of RET_VAL to RESULT_DECL.
If RESULT_DECL is zero, build a bare RETURN_EXPR. */
tree
build_return_expr (tree result_decl, tree ret_val)
{
tree result_expr;
if (result_decl)
{
/* The gimplifier explicitly enforces the following invariant:
RETURN_EXPR
|
MODIFY_EXPR
/ \
/ \
RESULT_DECL ...
As a consequence, type-homogeneity dictates that we use the type
of the RESULT_DECL as the operation type. */
tree operation_type = TREE_TYPE (result_decl);
/* Convert the right operand to the operation type. Note that
it's the same transformation as in the MODIFY_EXPR case of
build_binary_op with the additional guarantee that the type
cannot involve a placeholder, since otherwise the function
would use the "target pointer" return mechanism. */
if (operation_type != TREE_TYPE (ret_val))
ret_val = convert (operation_type, ret_val);
result_expr
= build2 (MODIFY_EXPR, operation_type, result_decl, ret_val);
}
else
result_expr = NULL_TREE;
return build1 (RETURN_EXPR, void_type_node, result_expr);
}
/* Build a CALL_EXPR to call FUNDECL with one argument, ARG. Return
the CALL_EXPR. */
tree
build_call_1_expr (tree fundecl, tree arg)
{
tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
1, arg);
TREE_SIDE_EFFECTS (call) = 1;
return call;
}
/* Build a CALL_EXPR to call FUNDECL with two arguments, ARG1 & ARG2. Return
the CALL_EXPR. */
tree
build_call_2_expr (tree fundecl, tree arg1, tree arg2)
{
tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
2, arg1, arg2);
TREE_SIDE_EFFECTS (call) = 1;
return call;
}
/* Likewise to call FUNDECL with no arguments. */
tree
build_call_0_expr (tree fundecl)
{
/* We rely on build_call_nary to compute TREE_SIDE_EFFECTS. This makes
it possible to propagate DECL_IS_PURE on parameterless functions. */
tree call = build_call_nary (TREE_TYPE (TREE_TYPE (fundecl)),
build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
0);
return call;
}
/* Call a function that raises an exception and pass the line number and file
name, if requested. MSG says which exception function to call.
GNAT_NODE is the gnat node conveying the source location for which the
error should be signaled, or Empty in which case the error is signaled on
the current ref_file_name/input_line.
KIND says which kind of exception this is for
(N_Raise_{Constraint,Storage,Program}_Error). */
tree
build_call_raise (int msg, Node_Id gnat_node, char kind)
{
tree fndecl = gnat_raise_decls[msg];
tree label = get_exception_label (kind);
tree filename;
int line_number;
const char *str;
int len;
/* If this is to be done as a goto, handle that case. */
if (label)
{
Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
/* If Local_Raise is present, generate
Local_Raise (exception'Identity); */
if (Present (local_raise))
{
tree gnu_local_raise
= gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
tree gnu_exception_entity
= gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
tree gnu_call
= build_call_1_expr (gnu_local_raise,
build_unary_op (ADDR_EXPR, NULL_TREE,
gnu_exception_entity));
gnu_result = build2 (COMPOUND_EXPR, void_type_node,
gnu_call, gnu_result);}
return gnu_result;
}
str
= (Debug_Flag_NN || Exception_Locations_Suppressed)
? ""
: (gnat_node != Empty && Sloc (gnat_node) != No_Location)
? IDENTIFIER_POINTER
(get_identifier (Get_Name_String
(Debug_Source_Name
(Get_Source_File_Index (Sloc (gnat_node))))))
: ref_filename;
len = strlen (str) + 1;
filename = build_string (len, str);
line_number
= (gnat_node != Empty && Sloc (gnat_node) != No_Location)
? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
TREE_TYPE (filename)
= build_array_type (char_type_node,
build_index_type (build_int_cst (NULL_TREE, len)));
return
build_call_2_expr (fndecl,
build1 (ADDR_EXPR, build_pointer_type (char_type_node),
filename),
build_int_cst (NULL_TREE, line_number));
}
/* qsort comparer for the bit positions of two constructor elements
for record components. */
static int
compare_elmt_bitpos (const PTR rt1, const PTR rt2)
{
const_tree const elmt1 = * (const_tree const *) rt1;
const_tree const elmt2 = * (const_tree const *) rt2;
const_tree const field1 = TREE_PURPOSE (elmt1);
const_tree const field2 = TREE_PURPOSE (elmt2);
const int ret
= tree_int_cst_compare (bit_position (field1), bit_position (field2));
return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
}
/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
tree
gnat_build_constructor (tree type, tree list)
{
tree elmt;
int n_elmts;
bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
bool side_effects = false;
tree result;
/* Scan the elements to see if they are all constant or if any has side
effects, to let us set global flags on the resulting constructor. Count
the elements along the way for possible sorting purposes below. */
for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++)
{
if (!TREE_CONSTANT (TREE_VALUE (elmt))
|| (TREE_CODE (type) == RECORD_TYPE
&& DECL_BIT_FIELD (TREE_PURPOSE (elmt))
&& TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST)
|| !initializer_constant_valid_p (TREE_VALUE (elmt),
TREE_TYPE (TREE_VALUE (elmt))))
allconstant = false;
if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt)))
side_effects = true;
/* Propagate an NULL_EXPR from the size of the type. We won't ever
be executing the code we generate here in that case, but handle it
specially to avoid the compiler blowing up. */
if (TREE_CODE (type) == RECORD_TYPE
&& (0 != (result
= contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt))))))
return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0));
}
/* For record types with constant components only, sort field list
by increasing bit position. This is necessary to ensure the
constructor can be output as static data. */
if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
{
/* Fill an array with an element tree per index, and ask qsort to order
them according to what a bitpos comparison function says. */
tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
int i;
for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++)
gnu_arr[i] = elmt;
qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
/* Then reconstruct the list from the sorted array contents. */
list = NULL_TREE;
for (i = n_elmts - 1; i >= 0; i--)
{
TREE_CHAIN (gnu_arr[i]) = list;
list = gnu_arr[i];
}
}
result = build_constructor_from_list (type, list);
TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant;
TREE_SIDE_EFFECTS (result) = side_effects;
TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
return result;
}
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, or FIELD, a FIELD_DECL,
for the field. Don't fold the result if NO_FOLD_P is true.
We also handle the fact that we might have been passed a pointer to the
actual record and know how to look for fields in variant parts. */
static tree
build_simple_component_ref (tree record_variable, tree component,
tree field, bool no_fold_p)
{
tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
tree ref, inner_variable;
gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
|| TREE_CODE (record_type) == UNION_TYPE
|| TREE_CODE (record_type) == QUAL_UNION_TYPE)
&& TYPE_SIZE (record_type)
&& (component != 0) != (field != 0));
/* If no field was specified, look for a field with the specified name
in the current record only. */
if (!field)
for (field = TYPE_FIELDS (record_type); field;
field = TREE_CHAIN (field))
if (DECL_NAME (field) == component)
break;
if (!field)
return NULL_TREE;
/* If this field is not in the specified record, see if we can find
something in the record whose original field is the same as this one. */
if (DECL_CONTEXT (field) != record_type)
/* Check if there is a field with name COMPONENT in the record. */
{
tree new_field;
/* First loop thru normal components. */
for (new_field = TYPE_FIELDS (record_type); new_field;
new_field = TREE_CHAIN (new_field))
if (field == new_field
|| DECL_ORIGINAL_FIELD (new_field) == field
|| new_field == DECL_ORIGINAL_FIELD (field)
|| (DECL_ORIGINAL_FIELD (field)
&& (DECL_ORIGINAL_FIELD (field)
== DECL_ORIGINAL_FIELD (new_field))))
break;
/* Next, loop thru DECL_INTERNAL_P components if we haven't found
the component in the first search. Doing this search in 2 steps
is required to avoiding hidden homonymous fields in the
_Parent field. */
if (!new_field)
for (new_field = TYPE_FIELDS (record_type); new_field;
new_field = TREE_CHAIN (new_field))
if (DECL_INTERNAL_P (new_field))
{
tree field_ref
= 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);
if (ref)
return ref;
}
field = new_field;
}
if (!field)
return NULL_TREE;
/* If the field's offset has overflowed, do not attempt to access it
as doing so may trigger sanity checks deeper in the back-end.
Note that we don't need to warn since this will be done on trying
to declare the object. */
if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST
&& TREE_OVERFLOW (DECL_FIELD_OFFSET (field)))
return NULL_TREE;
/* Look through conversion between type variants. Note that this
is transparent as far as the field is concerned. */
if (TREE_CODE (record_variable) == VIEW_CONVERT_EXPR
&& TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (record_variable, 0)))
== record_type)
inner_variable = TREE_OPERAND (record_variable, 0);
else
inner_variable = record_variable;
ref = build3 (COMPONENT_REF, TREE_TYPE (field), inner_variable, field,
NULL_TREE);
if (TREE_READONLY (record_variable) || TREE_READONLY (field))
TREE_READONLY (ref) = 1;
if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
if (no_fold_p)
return ref;
/* The generic folder may punt in this case because the inner array type
can be self-referential, but folding is in fact not problematic. */
else if (TREE_CODE (record_variable) == CONSTRUCTOR
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (record_variable)))
{
VEC(constructor_elt,gc) *elts = CONSTRUCTOR_ELTS (record_variable);
unsigned HOST_WIDE_INT idx;
tree index, value;
FOR_EACH_CONSTRUCTOR_ELT (elts, idx, index, value)
if (index == field)
return value;
return ref;
}
else
return fold (ref);
}
/* Like build_simple_component_ref, except that we give an error if the
reference could not be found. */
tree
build_component_ref (tree record_variable, tree component,
tree field, bool no_fold_p)
{
tree ref = build_simple_component_ref (record_variable, component, field,
no_fold_p);
if (ref)
return ref;
/* If FIELD was specified, assume this is an invalid user field so
raise constraint error. Otherwise, we can't find the type to return, so
abort. */
gcc_assert (field);
return build1 (NULL_EXPR, TREE_TYPE (field),
build_call_raise (CE_Discriminant_Check_Failed, Empty,
N_Raise_Constraint_Error));
}
/* Build a GCC tree to call an allocation or deallocation function.
If GNU_OBJ is nonzero, it is an object to deallocate. Otherwise,
generate an allocator.
GNU_SIZE is the size of the object in bytes and ALIGN is the alignment in
bits. GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the
storage pool to use. If not preset, malloc and free will be used except
if GNAT_PROC is the "fake" value of -1, in which case we allocate the
object dynamically on the stack frame. */
tree
build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
Entity_Id gnat_proc, Entity_Id gnat_pool,
Node_Id gnat_node)
{
tree gnu_align = size_int (align / BITS_PER_UNIT);
gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
if (Present (gnat_proc))
{
/* 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)))
{
/* The size is the third parameter; the alignment is the
same type. */
Entity_Id gnat_size_type
= Etype (Next_Formal (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);
tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
tree gnu_pool = gnat_to_gnu (gnat_pool);
tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
tree gnu_call;
gnu_size = convert (gnu_size_type, gnu_size);
gnu_align = convert (gnu_size_type, gnu_align);
/* The first arg is always the address of the storage pool; next
comes the address of the object, for a deallocator, then the
size and alignment. */
if (gnu_obj)
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 4, gnu_pool_addr,
gnu_obj, gnu_size, gnu_align);
else
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 3, gnu_pool_addr,
gnu_size, gnu_align);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
/* Secondary stack case. */
else
{
/* The size is the second parameter */
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);
tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
tree gnu_call;
gnu_size = convert (gnu_size_type, gnu_size);
/* The first arg is the address of the object, for a
deallocator, then the size */
if (gnu_obj)
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 2, gnu_obj, gnu_size);
else
gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, 1, gnu_size);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
}
else if (gnu_obj)
return build_call_1_expr (free_decl, gnu_obj);
/* ??? For now, disable variable-sized allocators in the stack since
we can't yet gimplify an ALLOCATE_EXPR. */
else if (gnat_pool == -1
&& TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check)
{
/* If the size is a constant, we can put it in the fixed portion of
the stack frame to avoid the need to adjust the stack pointer. */
if (TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check)
{
tree gnu_range
= build_range_type (NULL_TREE, size_one_node, gnu_size);
tree gnu_array_type = build_array_type (char_type_node, gnu_range);
tree gnu_decl
= create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
gnu_array_type, NULL_TREE, false, false, false,
false, NULL, gnat_node);
return convert (ptr_void_type_node,
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl));
}
else
gcc_unreachable ();
#if 0
return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
#endif
}
else
{
if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node))
Check_No_Implicit_Heap_Alloc (gnat_node);
/* If the allocator size is 32bits but the pointer size is 64bits then
allocate 32bit memory (sometimes necessary on 64bit VMS). Otherwise
default to standard malloc. */
if (UI_To_Int (Esize (Etype (gnat_node))) == 32 && POINTER_SIZE == 64)
return build_call_1_expr (malloc32_decl, gnu_size);
else
return build_call_1_expr (malloc_decl, gnu_size);
}
}
/* Build a GCC tree to correspond to allocating an object of TYPE whose
initial value is INIT, if INIT is nonzero. Convert the expression to
RESULT_TYPE, which must be some type of pointer. Return the tree.
GNAT_PROC and GNAT_POOL optionally give the procedure to call and
the storage pool to use. GNAT_NODE is used to provide an error
location for restriction violations messages. If IGNORE_INIT_TYPE is
true, ignore the type of INIT for the purpose of determining the size;
this will cause the maximum size to be allocated if TYPE is of
self-referential size. */
tree
build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
{
tree size = TYPE_SIZE_UNIT (type);
tree result;
unsigned int default_allocator_alignment
= get_target_default_allocator_alignment () * BITS_PER_UNIT;
/* If the initializer, if present, is a NULL_EXPR, just return a new one. */
if (init && TREE_CODE (init) == NULL_EXPR)
return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
/* If RESULT_TYPE is a fat or thin pointer, set SIZE to be the sum of the
sizes of the object and its template. Allocate the whole thing and
fill in the parts that are known. */
else if (TYPE_FAT_OR_THIN_POINTER_P (result_type))
{
tree storage_type
= build_unc_object_type_from_ptr (result_type, type,
get_identifier ("ALLOC"));
tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
tree storage_ptr_type = build_pointer_type (storage_type);
tree storage;
tree template_cons = NULL_TREE;
size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
init);
/* If the size overflows, pass -1 so the allocator will raise
storage error. */
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
size = ssize_int (-1);
storage = build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (storage_type),
gnat_proc, gnat_pool, gnat_node);
storage = convert (storage_ptr_type, protect_multiple_eval (storage));
if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
type = TREE_TYPE (TYPE_FIELDS (type));
if (init)
init = convert (type, init);
}
/* If there is an initializing expression, make a constructor for
the entire object including the bounds and copy it into the
object. If there is no initializing expression, just set the
bounds. */
if (init)
{
template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)),
init, NULL_TREE);
template_cons = tree_cons (TYPE_FIELDS (storage_type),
build_template (template_type, type,
init),
template_cons);
return convert
(result_type,
build2 (COMPOUND_EXPR, storage_ptr_type,
build_binary_op
(MODIFY_EXPR, storage_type,
build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
gnat_build_constructor (storage_type, template_cons)),
convert (storage_ptr_type, storage)));
}
else
return build2
(COMPOUND_EXPR, result_type,
build_binary_op
(MODIFY_EXPR, template_type,
build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
NULL_TREE, TYPE_FIELDS (storage_type), 0),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
/* If we have an initializing expression, see if its size is simpler
than the size from the type. */
if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init))
&& (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
|| CONTAINS_PLACEHOLDER_P (size)))
size = TYPE_SIZE_UNIT (TREE_TYPE (init));
/* If the size is still self-referential, reference the initializing
expression, if it is present. If not, this must have been a
call to allocate a library-level object, in which case we use
the maximum size. */
if (CONTAINS_PLACEHOLDER_P (size))
{
if (!ignore_init_type && init)
size = substitute_placeholder_in_expr (size, init);
else
size = max_size (size, true);
}
/* If the size overflows, pass -1 so the allocator will raise
storage error. */
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
size = ssize_int (-1);
/* If this is in the default storage pool and the type alignment is larger
than what the default allocator supports, make an "aligning" record type
with room to store a pointer before the field, allocate an object of that
type, store the system's allocator return value just in front of the
field and return the field's address. */
if (No (gnat_proc) && TYPE_ALIGN (type) > default_allocator_alignment)
{
/* Construct the aligning type with enough room for a pointer ahead
of the field, then allocate. */
tree record_type
= make_aligning_type (type, TYPE_ALIGN (type), size,
default_allocator_alignment,
POINTER_SIZE / BITS_PER_UNIT);
tree record, record_addr;
record_addr
= build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type),
default_allocator_alignment, Empty, Empty,
gnat_node);
record_addr
= convert (build_pointer_type (record_type),
save_expr (record_addr));
record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr);
/* Our RESULT (the Ada allocator's value) is the super-aligned address
of the internal record field ... */
result
= build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref
(record, NULL_TREE, TYPE_FIELDS (record_type), 0));
result = convert (result_type, result);
/* ... with the system allocator's return value stored just in
front. */
{
tree ptr_addr
= build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
convert (ptr_void_type_node, result),
size_int (-POINTER_SIZE/BITS_PER_UNIT));
tree ptr_ref
= convert (build_pointer_type (ptr_void_type_node), ptr_addr);
result
= build2 (COMPOUND_EXPR, TREE_TYPE (result),
build_binary_op (MODIFY_EXPR, NULL_TREE,
build_unary_op (INDIRECT_REF, NULL_TREE,
ptr_ref),
convert (ptr_void_type_node,
record_addr)),
result);
}
}
else
result = convert (result_type,
build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (type),
gnat_proc,
gnat_pool,
gnat_node));
/* If we have an initial value, put the new address into a SAVE_EXPR, assign
the value, and return the address. Do this with a COMPOUND_EXPR. */
if (init)
{
result = save_expr (result);
result
= build2 (COMPOUND_EXPR, TREE_TYPE (result),
build_binary_op
(MODIFY_EXPR, NULL_TREE,
build_unary_op (INDIRECT_REF,
TREE_TYPE (TREE_TYPE (result)), result),
init),
result);
}
return convert (result_type, result);
}
/* Fill in a VMS descriptor for EXPR and return a constructor for it.
GNAT_FORMAL is how we find the descriptor record. */
tree
fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
{
tree record_type = TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal)));
tree field;
tree const_list = NULL_TREE;
expr = maybe_unconstrained_array (expr);
gnat_mark_addressable (expr);
for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
const_list
= tree_cons (field,
convert (TREE_TYPE (field),
SUBSTITUTE_PLACEHOLDER_IN_EXPR
(DECL_INITIAL (field), expr)),
const_list);
return gnat_build_constructor (record_type, nreverse (const_list));
}
/* Indicate that we need to make the address of EXPR_NODE and it therefore
should not be allocated in a register. Returns true if successful. */
bool
gnat_mark_addressable (tree expr_node)
{
while (1)
switch (TREE_CODE (expr_node))
{
case ADDR_EXPR:
case COMPONENT_REF:
case ARRAY_REF:
case ARRAY_RANGE_REF:
case REALPART_EXPR:
case IMAGPART_EXPR:
case VIEW_CONVERT_EXPR:
case NON_LVALUE_EXPR:
CASE_CONVERT:
expr_node = TREE_OPERAND (expr_node, 0);
break;
case CONSTRUCTOR:
TREE_ADDRESSABLE (expr_node) = 1;
return true;
case VAR_DECL:
case PARM_DECL:
case RESULT_DECL:
TREE_ADDRESSABLE (expr_node) = 1;
return true;
case FUNCTION_DECL:
TREE_ADDRESSABLE (expr_node) = 1;
return true;
case CONST_DECL:
return (DECL_CONST_CORRESPONDING_VAR (expr_node)
&& (gnat_mark_addressable
(DECL_CONST_CORRESPONDING_VAR (expr_node))));
default:
return true;
}
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment