+++ /dev/null
-/****************************************************************************
- * *
- * 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)
+++ /dev/null
-/****************************************************************************
- * *
- * 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)
+++ /dev/null
-/****************************************************************************
- * *
- * 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
+++ /dev/null
-/****************************************************************************
- * *
- * 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;
-}
+++ /dev/null
-/****************************************************************************
- * *
- * GNAT COMPILER COMPONENTS *
- * *
- * D E C L *
- * *
- * 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 "flags.h"
-#include "toplev.h"
-#include "convert.h"
-#include "ggc.h"
-#include "obstack.h"
-#include "target.h"
-#include "expr.h"
-
-#include "ada.h"
-#include "types.h"
-#include "atree.h"
-#include "elists.h"
-#include "namet.h"
-#include "nlists.h"
-#include "repinfo.h"
-#include "snames.h"
-#include "stringt.h"
-#include "uintp.h"
-#include "fe.h"
-#include "sinfo.h"
-#include "einfo.h"
-#include "hashtab.h"
-#include "ada-tree.h"
-#include "gigi.h"
-
-#ifndef MAX_FIXED_MODE_SIZE
-#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
-#endif
-
-/* Convention_Stdcall should be processed in a specific way on Windows targets
- only. The macro below is a helper to avoid having to check for a Windows
- specific attribute throughout this unit. */
-
-#if TARGET_DLLIMPORT_DECL_ATTRIBUTES
-#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
-#else
-#define Has_Stdcall_Convention(E) (0)
-#endif
-
-/* Stack realignment for functions with foreign conventions is provided on a
- per back-end basis now, as it is handled by the prologue expanders and not
- as part of the function's body any more. It might be requested by way of a
- dedicated function type attribute on the targets that support it.
-
- We need a way to avoid setting the attribute on the targets that don't
- support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
-
- It is defined on targets where the circuitry is available, and indicates
- whether the realignment is needed for 'main'. We use this to decide for
- foreign subprograms as well.
-
- It is not defined on targets where the circuitry is not implemented, and
- we just never set the attribute in these cases.
-
- Whether it is defined on all targets that would need it in theory is
- not entirely clear. We currently trust the base GCC settings for this
- purpose. */
-
-#ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
-#define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
-#endif
-
-struct incomplete
-{
- struct incomplete *next;
- tree old_type;
- Entity_Id full_type;
-};
-
-/* These variables are used to defer recursively expanding incomplete types
- while we are processing an array, a record or a subprogram type. */
-static int defer_incomplete_level = 0;
-static struct incomplete *defer_incomplete_list;
-
-/* This variable is used to delay expanding From_With_Type types until the
- end of the spec. */
-static struct incomplete *defer_limited_with;
-
-/* These variables are used to defer finalizing types. The element of the
- list is the TYPE_DECL associated with the type. */
-static int defer_finalize_level = 0;
-static VEC (tree,heap) *defer_finalize_list;
-
-/* A hash table used to cache the result of annotate_value. */
-static GTY ((if_marked ("tree_int_map_marked_p"),
- param_is (struct tree_int_map))) htab_t annotate_value_cache;
-
-static void copy_alias_set (tree, tree);
-static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
-static bool allocatable_size_p (tree, bool);
-static void prepend_one_attribute_to (struct attrib **,
- enum attr_type, tree, tree, Node_Id);
-static void prepend_attributes (Entity_Id, struct attrib **);
-static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
-static bool is_variable_size (tree);
-static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
- bool, bool);
-static tree make_packable_type (tree, bool);
-static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
-static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
- bool *);
-static bool same_discriminant_p (Entity_Id, Entity_Id);
-static bool array_type_has_nonaliased_component (Entity_Id, tree);
-static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
- bool, bool, bool, bool);
-static Uint annotate_value (tree);
-static void annotate_rep (Entity_Id, tree);
-static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
-static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
-static void set_rm_size (Uint, tree, Entity_Id);
-static tree make_type_from_size (tree, tree, bool);
-static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
-static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
-static void check_ok_for_atomic (tree, Entity_Id, bool);
-static int compatible_signatures_p (tree ftype1, tree ftype2);
-static void rest_of_type_decl_compilation_no_defer (tree);
-
-/* Return true if GNAT_ADDRESS is a compile time known value.
- In particular catch System'To_Address. */
-
-static bool
-compile_time_known_address_p (Node_Id gnat_address)
-{
- return ((Nkind (gnat_address) == N_Unchecked_Type_Conversion
- && Compile_Time_Known_Value (Expression (gnat_address)))
- || Compile_Time_Known_Value (gnat_address));
-}
-
-/* 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. */
-
-tree
-gnat_to_gnu_type (Entity_Id gnat_entity)
-{
- tree gnu_decl;
-
- /* The back end never attempts to annotate generic types */
- if (Is_Generic_Type (gnat_entity) && type_annotate_only)
- return void_type_node;
-
- /* Convert the ada entity type into a GCC TYPE_DECL node. */
- gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
- gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
- return TREE_TYPE (gnu_decl);
-}
-\f
-/* 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. */
-
-tree
-gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
-{
- Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
- tree gnu_entity_id;
- tree gnu_type = NULL_TREE;
- /* Contains the gnu XXXX_DECL tree node which is equivalent to the input
- GNAT tree. This node will be associated with the GNAT node by calling
- the save_gnu_tree routine at the end of the `switch' statement. */
- tree gnu_decl = NULL_TREE;
- /* true if we have already saved gnu_decl as a gnat association. */
- bool saved = false;
- /* Nonzero if we incremented defer_incomplete_level. */
- bool this_deferred = false;
- /* Nonzero if we incremented force_global. */
- bool this_global = false;
- /* Nonzero if we should check to see if elaborated during processing. */
- bool maybe_present = false;
- /* Nonzero if we made GNU_DECL and its type here. */
- bool this_made_decl = false;
- struct attrib *attr_list = NULL;
- bool debug_info_p = (Needs_Debug_Info (gnat_entity)
- || debug_info_level == DINFO_LEVEL_VERBOSE);
- Entity_Kind kind = Ekind (gnat_entity);
- Entity_Id gnat_temp;
- unsigned int esize
- = ((Known_Esize (gnat_entity)
- && UI_Is_In_Int_Range (Esize (gnat_entity)))
- ? MIN (UI_To_Int (Esize (gnat_entity)),
- IN (kind, Float_Kind)
- ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
- : IN (kind, Access_Kind) ? POINTER_SIZE * 2
- : LONG_LONG_TYPE_SIZE)
- : LONG_LONG_TYPE_SIZE);
- tree gnu_size = 0;
- bool imported_p
- = (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
- unsigned int align = 0;
-
- /* Since a use of an Itype is a definition, process it as such if it
- is not in a with'ed unit. */
-
- if (!definition && Is_Itype (gnat_entity)
- && !present_gnu_tree (gnat_entity)
- && In_Extended_Main_Code_Unit (gnat_entity))
- {
- /* Ensure that we are in a subprogram mentioned in the Scope
- chain of this entity, our current scope is global,
- or that we encountered a task or entry (where we can't currently
- accurately check scoping). */
- if (!current_function_decl
- || DECL_ELABORATION_PROC_P (current_function_decl))
- {
- process_type (gnat_entity);
- return get_gnu_tree (gnat_entity);
- }
-
- for (gnat_temp = Scope (gnat_entity);
- Present (gnat_temp); gnat_temp = Scope (gnat_temp))
- {
- if (Is_Type (gnat_temp))
- gnat_temp = Underlying_Type (gnat_temp);
-
- if (Ekind (gnat_temp) == E_Subprogram_Body)
- gnat_temp
- = Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
-
- if (IN (Ekind (gnat_temp), Subprogram_Kind)
- && Present (Protected_Body_Subprogram (gnat_temp)))
- gnat_temp = Protected_Body_Subprogram (gnat_temp);
-
- if (Ekind (gnat_temp) == E_Entry
- || Ekind (gnat_temp) == E_Entry_Family
- || Ekind (gnat_temp) == E_Task_Type
- || (IN (Ekind (gnat_temp), Subprogram_Kind)
- && present_gnu_tree (gnat_temp)
- && (current_function_decl
- == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
- {
- process_type (gnat_entity);
- return get_gnu_tree (gnat_entity);
- }
- }
-
- /* This abort means the entity "gnat_entity" has an incorrect scope,
- i.e. that its scope does not correspond to the subprogram in which
- it is declared */
- gcc_unreachable ();
- }
-
- /* If this is entity 0, something went badly wrong. */
- gcc_assert (Present (gnat_entity));
-
- /* If we've already processed this entity, return what we got last time.
- If we are defining the node, we should not have already processed it.
- In that case, we will abort below when we try to save a new GCC tree for
- this object. We also need to handle the case of getting a dummy type
- when a Full_View exists. */
-
- if (present_gnu_tree (gnat_entity)
- && (!definition || (Is_Type (gnat_entity) && imported_p)))
- {
- gnu_decl = get_gnu_tree (gnat_entity);
-
- if (TREE_CODE (gnu_decl) == TYPE_DECL
- && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
- && IN (kind, Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity)))
- {
- gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
- NULL_TREE, 0);
-
- save_gnu_tree (gnat_entity, NULL_TREE, false);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- }
-
- return gnu_decl;
- }
-
- /* If this is a numeric or enumeral type, or an access type, a nonzero
- Esize must be specified unless it was specified by the programmer. */
- gcc_assert (!Unknown_Esize (gnat_entity)
- || Has_Size_Clause (gnat_entity)
- || (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind)
- && (!IN (kind, Access_Kind)
- || kind == E_Access_Protected_Subprogram_Type
- || kind == E_Anonymous_Access_Protected_Subprogram_Type
- || kind == E_Access_Subtype)));
-
- /* Likewise, RM_Size must be specified for all discrete and fixed-point
- types. */
- gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
- || !Unknown_RM_Size (gnat_entity));
-
- /* Get the name of the entity and set up the line number and filename of
- the original definition for use in any decl we make. */
- gnu_entity_id = get_entity_name (gnat_entity);
- Sloc_to_locus (Sloc (gnat_entity), &input_location);
-
- /* If we get here, it means we have not yet done anything with this
- entity. If we are not defining it here, it must be external,
- otherwise we should have defined it already. */
- gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only
- || kind == E_Discriminant || kind == E_Component
- || kind == E_Label
- || (kind == E_Constant && Present (Full_View (gnat_entity)))
- || IN (kind, Type_Kind));
-
- /* For cases when we are not defining (i.e., we are referencing from
- another compilation unit) Public entities, show we are at global level
- for the purpose of computing scopes. Don't do this for components or
- discriminants since the relevant test is whether or not the record is
- being defined. But do this for Imported functions or procedures in
- all cases. */
- if ((!definition && Is_Public (gnat_entity)
- && !Is_Statically_Allocated (gnat_entity)
- && kind != E_Discriminant && kind != E_Component)
- || (Is_Imported (gnat_entity)
- && (kind == E_Function || kind == E_Procedure)))
- force_global++, this_global = true;
-
- /* Handle any attributes directly attached to the entity. */
- if (Has_Gigi_Rep_Item (gnat_entity))
- prepend_attributes (gnat_entity, &attr_list);
-
- /* Machine_Attributes on types are expected to be propagated to subtypes.
- The corresponding Gigi_Rep_Items are only attached to the first subtype
- though, so we handle the propagation here. */
- if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity
- && !Is_First_Subtype (gnat_entity)
- && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
- prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list);
-
- switch (kind)
- {
- case E_Constant:
- /* If this is a use of a deferred constant, get its full
- declaration. */
- if (!definition && Present (Full_View (gnat_entity)))
- {
- gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
- gnu_expr, 0);
- saved = true;
- break;
- }
-
- /* If we have an external constant that we are not defining, get the
- expression that is was defined to represent. We may throw that
- expression away later if it is not a constant. Do not retrieve the
- expression if it is an aggregate or allocator, because in complex
- instantiation contexts it may not be expanded */
- if (!definition
- && Present (Expression (Declaration_Node (gnat_entity)))
- && !No_Initialization (Declaration_Node (gnat_entity))
- && (Nkind (Expression (Declaration_Node (gnat_entity)))
- != N_Aggregate)
- && (Nkind (Expression (Declaration_Node (gnat_entity)))
- != N_Allocator))
- gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
-
- /* Ignore deferred constant definitions; they are processed fully in the
- front-end. For deferred constant references get the full definition.
- On the other hand, constants that are renamings are handled like
- variable renamings. If No_Initialization is set, this is not a
- deferred constant but a constant whose value is built manually. */
- if (definition && !gnu_expr
- && !No_Initialization (Declaration_Node (gnat_entity))
- && No (Renamed_Object (gnat_entity)))
- {
- gnu_decl = error_mark_node;
- saved = true;
- break;
- }
- else if (!definition && IN (kind, Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity)))
- {
- gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
- NULL_TREE, 0);
- saved = true;
- break;
- }
-
- goto object;
-
- case E_Exception:
- /* We used to special case VMS exceptions here to directly map them to
- their associated condition code. Since this code had to be masked
- dynamically to strip off the severity bits, this caused trouble in
- the GCC/ZCX case because the "type" pointers we store in the tables
- have to be static. We now don't special case here anymore, and let
- the regular processing take place, which leaves us with a regular
- exception data object for VMS exceptions too. The condition code
- mapping is taken care of by the front end and the bitmasking by the
- runtime library. */
- goto object;
-
- case E_Discriminant:
- case E_Component:
- {
- /* The GNAT record where the component was defined. */
- Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
-
- /* If the variable is an inherited record component (in the case of
- extended record types), just return the inherited entity, which
- must be a FIELD_DECL. Likewise for discriminants.
- For discriminants of untagged records which have explicit
- stored discriminants, return the entity for the corresponding
- stored discriminant. Also use Original_Record_Component
- if the record has a private extension. */
-
- if (Present (Original_Record_Component (gnat_entity))
- && Original_Record_Component (gnat_entity) != gnat_entity)
- {
- gnu_decl
- = gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
- gnu_expr, definition);
- saved = true;
- break;
- }
-
- /* If the enclosing record has explicit stored discriminants,
- then it is an untagged record. If the Corresponding_Discriminant
- is not empty then this must be a renamed discriminant and its
- Original_Record_Component must point to the corresponding explicit
- stored discriminant (i.e., we should have taken the previous
- branch). */
-
- else if (Present (Corresponding_Discriminant (gnat_entity))
- && Is_Tagged_Type (gnat_record))
- {
- /* A tagged record has no explicit stored discriminants. */
-
- gcc_assert (First_Discriminant (gnat_record)
- == First_Stored_Discriminant (gnat_record));
- gnu_decl
- = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
- gnu_expr, definition);
- saved = true;
- break;
- }
-
- else if (Present (CR_Discriminant (gnat_entity))
- && type_annotate_only)
- {
- gnu_decl = gnat_to_gnu_entity (CR_Discriminant (gnat_entity),
- gnu_expr, definition);
- saved = true;
- break;
- }
-
- /* If the enclosing record has explicit stored discriminants,
- then it is an untagged record. If the Corresponding_Discriminant
- is not empty then this must be a renamed discriminant and its
- Original_Record_Component must point to the corresponding explicit
- stored discriminant (i.e., we should have taken the first
- branch). */
-
- else if (Present (Corresponding_Discriminant (gnat_entity))
- && (First_Discriminant (gnat_record)
- != First_Stored_Discriminant (gnat_record)))
- gcc_unreachable ();
-
- /* Otherwise, if we are not defining this and we have no GCC type
- for the containing record, make one for it. Then we should
- have made our own equivalent. */
- else if (!definition && !present_gnu_tree (gnat_record))
- {
- /* ??? If this is in a record whose scope is a protected
- type and we have an Original_Record_Component, use it.
- This is a workaround for major problems in protected type
- handling. */
- Entity_Id Scop = Scope (Scope (gnat_entity));
- if ((Is_Protected_Type (Scop)
- || (Is_Private_Type (Scop)
- && Present (Full_View (Scop))
- && Is_Protected_Type (Full_View (Scop))))
- && Present (Original_Record_Component (gnat_entity)))
- {
- gnu_decl
- = gnat_to_gnu_entity (Original_Record_Component
- (gnat_entity),
- gnu_expr, 0);
- saved = true;
- break;
- }
-
- gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
- gnu_decl = get_gnu_tree (gnat_entity);
- saved = true;
- break;
- }
-
- else
- /* Here we have no GCC type and this is a reference rather than a
- definition. This should never happen. Most likely the cause is a
- reference before declaration in the gnat tree for gnat_entity. */
- gcc_unreachable ();
- }
-
- case E_Loop_Parameter:
- case E_Out_Parameter:
- case E_Variable:
-
- /* Simple variables, loop variables, Out parameters, and exceptions. */
- object:
- {
- bool used_by_ref = false;
- bool const_flag
- = ((kind == E_Constant || kind == E_Variable)
- && Is_True_Constant (gnat_entity)
- && (((Nkind (Declaration_Node (gnat_entity))
- == N_Object_Declaration)
- && Present (Expression (Declaration_Node (gnat_entity))))
- || Present (Renamed_Object (gnat_entity))));
- bool inner_const_flag = const_flag;
- bool static_p = Is_Statically_Allocated (gnat_entity);
- bool mutable_p = false;
- tree gnu_ext_name = NULL_TREE;
- tree renamed_obj = NULL_TREE;
- tree gnu_object_size;
-
- if (Present (Renamed_Object (gnat_entity)) && !definition)
- {
- if (kind == E_Exception)
- gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
- NULL_TREE, 0);
- else
- gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
- }
-
- /* Get the type after elaborating the renamed object. */
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
-
- /* For a debug renaming declaration, build a pure debug entity. */
- if (Present (Debug_Renaming_Link (gnat_entity)))
- {
- rtx addr;
- gnu_decl = build_decl (VAR_DECL, gnu_entity_id, gnu_type);
- /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
- if (global_bindings_p ())
- addr = gen_rtx_CONST (VOIDmode, const0_rtx);
- else
- addr = stack_pointer_rtx;
- SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
- gnat_pushdecl (gnu_decl, gnat_entity);
- break;
- }
-
- /* If this is a loop variable, its type should be the base type.
- This is because the code for processing a loop determines whether
- a normal loop end test can be done by comparing the bounds of the
- loop against those of the base type, which is presumed to be the
- size used for computation. But this is not correct when the size
- of the subtype is smaller than the type. */
- if (kind == E_Loop_Parameter)
- gnu_type = get_base_type (gnu_type);
-
- /* Reject non-renamed objects whose types are unconstrained arrays or
- any object whose type is a dummy type or VOID_TYPE. */
-
- if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
- && No (Renamed_Object (gnat_entity)))
- || TYPE_IS_DUMMY_P (gnu_type)
- || TREE_CODE (gnu_type) == VOID_TYPE)
- {
- gcc_assert (type_annotate_only);
- if (this_global)
- force_global--;
- return error_mark_node;
- }
-
- /* If an alignment is specified, use it if valid. Note that
- exceptions are objects but don't have alignments. We must do this
- before we validate the size, since the alignment can affect the
- size. */
- if (kind != E_Exception && Known_Alignment (gnat_entity))
- {
- gcc_assert (Present (Alignment (gnat_entity)));
- align = validate_alignment (Alignment (gnat_entity), gnat_entity,
- TYPE_ALIGN (gnu_type));
- gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
- "PAD", false, definition, true);
- }
-
- /* If we are defining the object, see if it has a Size value and
- validate it if so. If we are not defining the object and a Size
- clause applies, simply retrieve the value. We don't want to ignore
- the clause and it is expected to have been validated already. Then
- get the new type, if any. */
- if (definition)
- gnu_size = validate_size (Esize (gnat_entity), gnu_type,
- gnat_entity, VAR_DECL, false,
- Has_Size_Clause (gnat_entity));
- else if (Has_Size_Clause (gnat_entity))
- gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
-
- if (gnu_size)
- {
- gnu_type
- = make_type_from_size (gnu_type, gnu_size,
- Has_Biased_Representation (gnat_entity));
-
- if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
- gnu_size = NULL_TREE;
- }
-
- /* If this object has self-referential size, it must be a record with
- a default value. We are supposed to allocate an object of the
- maximum size in this case unless it is a constant with an
- initializing expression, in which case we can get the size from
- that. Note that the resulting size may still be a variable, so
- this may end up with an indirect allocation. */
- if (No (Renamed_Object (gnat_entity))
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
- {
- if (gnu_expr && kind == E_Constant)
- {
- tree size = TYPE_SIZE (TREE_TYPE (gnu_expr));
- if (CONTAINS_PLACEHOLDER_P (size))
- {
- /* If the initializing expression is itself a constant,
- despite having a nominal type with self-referential
- size, we can get the size directly from it. */
- if (TREE_CODE (gnu_expr) == COMPONENT_REF
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
- == RECORD_TYPE
- && TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
- && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
- && (TREE_READONLY (TREE_OPERAND (gnu_expr, 0))
- || DECL_READONLY_ONCE_ELAB
- (TREE_OPERAND (gnu_expr, 0))))
- gnu_size = DECL_SIZE (TREE_OPERAND (gnu_expr, 0));
- else
- gnu_size
- = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_expr);
- }
- else
- gnu_size = size;
- }
- /* We may have no GNU_EXPR because No_Initialization is
- set even though there's an Expression. */
- else if (kind == E_Constant
- && (Nkind (Declaration_Node (gnat_entity))
- == N_Object_Declaration)
- && Present (Expression (Declaration_Node (gnat_entity))))
- gnu_size
- = TYPE_SIZE (gnat_to_gnu_type
- (Etype
- (Expression (Declaration_Node (gnat_entity)))));
- else
- {
- gnu_size = max_size (TYPE_SIZE (gnu_type), true);
- mutable_p = true;
- }
- }
-
- /* If the size is zero bytes, make it one byte since some linkers have
- trouble with zero-sized objects. If the object will have a
- template, that will make it nonzero so don't bother. Also avoid
- doing that for an object renaming or an object with an address
- clause, as we would lose useful information on the view size
- (e.g. for null array slices) and we are not allocating the object
- here anyway. */
- if (((gnu_size
- && integer_zerop (gnu_size)
- && !TREE_OVERFLOW (gnu_size))
- || (TYPE_SIZE (gnu_type)
- && integer_zerop (TYPE_SIZE (gnu_type))
- && !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
- && (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- || !Is_Array_Type (Etype (gnat_entity)))
- && !Present (Renamed_Object (gnat_entity))
- && !Present (Address_Clause (gnat_entity)))
- gnu_size = bitsize_unit_node;
-
- /* If this is an object with no specified size and alignment, and
- if either it is atomic or we are not optimizing alignment for
- space and it is composite and not an exception, an Out parameter
- or a reference to another object, and the size of its type is a
- constant, set the alignment to the smallest one which is not
- smaller than the size, with an appropriate cap. */
- if (!gnu_size && align == 0
- && (Is_Atomic (gnat_entity)
- || (!Optimize_Alignment_Space (gnat_entity)
- && kind != E_Exception
- && kind != E_Out_Parameter
- && Is_Composite_Type (Etype (gnat_entity))
- && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && !imported_p
- && No (Renamed_Object (gnat_entity))
- && No (Address_Clause (gnat_entity))))
- && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
- {
- /* No point in jumping through all the hoops needed in order
- to support BIGGEST_ALIGNMENT if we don't really have to. */
- unsigned int align_cap = Is_Atomic (gnat_entity)
- ? BIGGEST_ALIGNMENT
- : get_mode_alignment (word_mode);
-
- if (!host_integerp (TYPE_SIZE (gnu_type), 1)
- || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
- align = align_cap;
- else
- align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
-
- /* But make sure not to under-align the object. */
- if (align <= TYPE_ALIGN (gnu_type))
- align = 0;
-
- /* And honor the minimum valid atomic alignment, if any. */
-#ifdef MINIMUM_ATOMIC_ALIGNMENT
- else if (align < MINIMUM_ATOMIC_ALIGNMENT)
- align = MINIMUM_ATOMIC_ALIGNMENT;
-#endif
- }
-
- /* If the object is set to have atomic components, find the component
- type and validate it.
-
- ??? Note that we ignore Has_Volatile_Components on objects; it's
- not at all clear what to do in that case. */
-
- if (Has_Atomic_Components (gnat_entity))
- {
- tree gnu_inner = (TREE_CODE (gnu_type) == ARRAY_TYPE
- ? TREE_TYPE (gnu_type) : gnu_type);
-
- while (TREE_CODE (gnu_inner) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (gnu_inner))
- gnu_inner = TREE_TYPE (gnu_inner);
-
- check_ok_for_atomic (gnu_inner, gnat_entity, true);
- }
-
- /* Now check if the type of the object allows atomic access. Note
- that we must test the type, even if this object has size and
- alignment to allow such access, because we will be going
- inside the padded record to assign to the object. We could fix
- this by always copying via an intermediate value, but it's not
- clear it's worth the effort. */
- if (Is_Atomic (gnat_entity))
- check_ok_for_atomic (gnu_type, gnat_entity, false);
-
- /* If this is an aliased object with an unconstrained nominal subtype,
- make a type that includes the template. */
- if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && Is_Array_Type (Etype (gnat_entity))
- && !type_annotate_only)
- {
- tree gnu_fat
- = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
-
- gnu_type
- = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
- concat_id_with_name (gnu_entity_id,
- "UNC"));
- }
-
-#ifdef MINIMUM_ATOMIC_ALIGNMENT
- /* If the size is a constant and no alignment is specified, force
- the alignment to be the minimum valid atomic alignment. The
- restriction on constant size avoids problems with variable-size
- temporaries; if the size is variable, there's no issue with
- atomic access. Also don't do this for a constant, since it isn't
- necessary and can interfere with constant replacement. Finally,
- do not do it for Out parameters since that creates an
- size inconsistency with In parameters. */
- if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
- && !FLOAT_TYPE_P (gnu_type)
- && !const_flag && No (Renamed_Object (gnat_entity))
- && !imported_p && No (Address_Clause (gnat_entity))
- && kind != E_Out_Parameter
- && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST
- : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
- align = MINIMUM_ATOMIC_ALIGNMENT;
-#endif
-
- /* Make a new type with the desired size and alignment, if needed.
- But do not take into account alignment promotions to compute the
- size of the object. */
- gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
- if (gnu_size || align > 0)
- gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- "PAD", false, definition,
- gnu_size ? true : false);
-
- /* Make a volatile version of this object's type if we are to make
- the object volatile. We also interpret 13.3(19) conservatively
- and disallow any optimizations for an object covered by it. */
- if ((Treat_As_Volatile (gnat_entity)
- || (Is_Exported (gnat_entity)
- /* Exclude exported constants created by the compiler,
- which should boil down to static dispatch tables and
- make it possible to put them in read-only memory. */
- && (Comes_From_Source (gnat_entity) || !const_flag))
- || Is_Imported (gnat_entity)
- || Present (Address_Clause (gnat_entity)))
- && !TYPE_VOLATILE (gnu_type))
- gnu_type = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | TYPE_QUAL_VOLATILE));
-
- /* If this is a renaming, avoid as much as possible to create a new
- object. However, in several cases, creating it is required.
- This processing needs to be applied to the raw expression so
- as to make it more likely to rename the underlying object. */
- if (Present (Renamed_Object (gnat_entity)))
- {
- bool create_normal_object = false;
-
- /* If the renamed object had padding, strip off the reference
- to the inner object and reset our type. */
- if ((TREE_CODE (gnu_expr) == COMPONENT_REF
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
- == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
- /* Strip useless conversions around the object. */
- || TREE_CODE (gnu_expr) == NOP_EXPR)
- {
- gnu_expr = TREE_OPERAND (gnu_expr, 0);
- gnu_type = TREE_TYPE (gnu_expr);
- }
-
- /* Case 1: If this is a constant renaming stemming from a function
- call, treat it as a normal object whose initial value is what
- is being renamed. RM 3.3 says that the result of evaluating a
- function call is a constant object. As a consequence, it can
- be the inner object of a constant renaming. In this case, the
- renaming must be fully instantiated, i.e. it cannot be a mere
- reference to (part of) an existing object. */
- if (const_flag)
- {
- tree inner_object = gnu_expr;
- while (handled_component_p (inner_object))
- inner_object = TREE_OPERAND (inner_object, 0);
- if (TREE_CODE (inner_object) == CALL_EXPR)
- create_normal_object = true;
- }
-
- /* Otherwise, see if we can proceed with a stabilized version of
- the renamed entity or if we need to make a new object. */
- if (!create_normal_object)
- {
- tree maybe_stable_expr = NULL_TREE;
- bool stable = false;
-
- /* Case 2: If the renaming entity need not be materialized and
- the renamed expression is something we can stabilize, use
- that for the renaming. At the global level, we can only do
- this if we know no SAVE_EXPRs need be made, because the
- expression we return might be used in arbitrary conditional
- branches so we must force the SAVE_EXPRs evaluation
- immediately and this requires a function context. */
- if (!Materialize_Entity (gnat_entity)
- && (!global_bindings_p ()
- || (staticp (gnu_expr)
- && !TREE_SIDE_EFFECTS (gnu_expr))))
- {
- maybe_stable_expr
- = maybe_stabilize_reference (gnu_expr, true, &stable);
-
- if (stable)
- {
- gnu_decl = maybe_stable_expr;
- /* ??? No DECL_EXPR is created so we need to mark
- the expression manually lest it is shared. */
- if (global_bindings_p ())
- mark_visited (&gnu_decl);
- save_gnu_tree (gnat_entity, gnu_decl, true);
- saved = true;
- break;
- }
-
- /* The stabilization failed. Keep maybe_stable_expr
- untouched here to let the pointer case below know
- about that failure. */
- }
-
- /* Case 3: If this is a constant renaming and creating a
- new object is allowed and cheap, treat it as a normal
- object whose initial value is what is being renamed. */
- if (const_flag && Is_Elementary_Type (Etype (gnat_entity)))
- ;
-
- /* Case 4: Make this into a constant pointer to the object we
- are to rename and attach the object to the pointer if it is
- something we can stabilize.
-
- From the proper scope, attached objects will be referenced
- directly instead of indirectly via the pointer to avoid
- subtle aliasing problems with non-addressable entities.
- They have to be stable because we must not evaluate the
- variables in the expression every time the renaming is used.
- The pointer is called a "renaming" pointer in this case.
-
- In the rare cases where we cannot stabilize the renamed
- object, we just make a "bare" pointer, and the renamed
- entity is always accessed indirectly through it. */
- else
- {
- gnu_type = build_reference_type (gnu_type);
- inner_const_flag = TREE_READONLY (gnu_expr);
- const_flag = true;
-
- /* If the previous attempt at stabilizing failed, there
- is no point in trying again and we reuse the result
- without attaching it to the pointer. In this case it
- will only be used as the initializing expression of
- the pointer and thus needs no special treatment with
- regard to multiple evaluations. */
- if (maybe_stable_expr)
- ;
-
- /* Otherwise, try to stabilize and attach the expression
- to the pointer if the stabilization succeeds.
-
- Note that this might introduce SAVE_EXPRs and we don't
- check whether we're at the global level or not. This
- is fine since we are building a pointer initializer and
- neither the pointer nor the initializing expression can
- be accessed before the pointer elaboration has taken
- place in a correct program.
-
- These SAVE_EXPRs will be evaluated at the right place
- by either the evaluation of the initializer for the
- non-global case or the elaboration code for the global
- case, and will be attached to the elaboration procedure
- in the latter case. */
- else
- {
- maybe_stable_expr
- = maybe_stabilize_reference (gnu_expr, true, &stable);
-
- if (stable)
- renamed_obj = maybe_stable_expr;
-
- /* Attaching is actually performed downstream, as soon
- as we have a VAR_DECL for the pointer we make. */
- }
-
- gnu_expr
- = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
-
- gnu_size = NULL_TREE;
- used_by_ref = true;
- }
- }
- }
-
- /* If this is an aliased object whose nominal subtype is unconstrained,
- the object is a record that contains both the template and
- the object. If there is an initializer, it will have already
- been converted to the right type, but we need to create the
- template if there is no initializer. */
- else if (definition
- && TREE_CODE (gnu_type) == RECORD_TYPE
- && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
- /* Beware that padding might have been introduced
- via maybe_pad_type above. */
- || (TYPE_IS_PADDING_P (gnu_type)
- && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
- == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P
- (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
- && !gnu_expr)
- {
- tree template_field
- = TYPE_IS_PADDING_P (gnu_type)
- ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
- : TYPE_FIELDS (gnu_type);
-
- gnu_expr
- = gnat_build_constructor
- (gnu_type,
- tree_cons
- (template_field,
- build_template (TREE_TYPE (template_field),
- TREE_TYPE (TREE_CHAIN (template_field)),
- NULL_TREE),
- NULL_TREE));
- }
-
- /* Convert the expression to the type of the object except in the
- case where the object's type is unconstrained or the object's type
- is a padded record whose field is of self-referential size. In
- the former case, converting will generate unnecessary evaluations
- of the CONSTRUCTOR to compute the size and in the latter case, we
- want to only copy the actual data. */
- if (gnu_expr
- && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type)
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
- gnu_expr = convert (gnu_type, gnu_expr);
-
- /* If this is a pointer and it does not have an initializing
- expression, initialize it to NULL, unless the object is
- imported. */
- if (definition
- && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
- && !Is_Imported (gnat_entity) && !gnu_expr)
- gnu_expr = integer_zero_node;
-
- /* If we are defining the object and it has an Address clause we must
- get the address expression from the saved GCC tree for the
- object if the object has a Freeze_Node. Otherwise, we elaborate
- the address expression here since the front-end has guaranteed
- in that case that the elaboration has no effects. Note that
- only the latter mechanism is currently in use. */
- if (definition && Present (Address_Clause (gnat_entity)))
- {
- tree gnu_address
- = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
- : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
-
- save_gnu_tree (gnat_entity, NULL_TREE, false);
-
- /* Ignore the size. It's either meaningless or was handled
- above. */
- gnu_size = NULL_TREE;
- /* Convert the type of the object to a reference type that can
- alias everything as per 13.3(19). */
- gnu_type
- = build_reference_type_for_mode (gnu_type, ptr_mode, true);
- gnu_address = convert (gnu_type, gnu_address);
- used_by_ref = true;
- const_flag = !Is_Public (gnat_entity)
- || compile_time_known_address_p (Expression (Address_Clause
- (gnat_entity)));
-
- /* If we don't have an initializing expression for the underlying
- variable, the initializing expression for the pointer is the
- specified address. Otherwise, we have to make a COMPOUND_EXPR
- to assign both the address and the initial value. */
- if (!gnu_expr)
- gnu_expr = gnu_address;
- else
- gnu_expr
- = build2 (COMPOUND_EXPR, gnu_type,
- build_binary_op
- (MODIFY_EXPR, NULL_TREE,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- gnu_address),
- gnu_expr),
- gnu_address);
- }
-
- /* If it has an address clause and we are not defining it, mark it
- as an indirect object. Likewise for Stdcall objects that are
- imported. */
- if ((!definition && Present (Address_Clause (gnat_entity)))
- || (Is_Imported (gnat_entity)
- && Has_Stdcall_Convention (gnat_entity)))
- {
- /* Convert the type of the object to a reference type that can
- alias everything as per 13.3(19). */
- gnu_type
- = build_reference_type_for_mode (gnu_type, ptr_mode, true);
- gnu_size = NULL_TREE;
-
- /* No point in taking the address of an initializing expression
- that isn't going to be used. */
- gnu_expr = NULL_TREE;
-
- /* If it has an address clause whose value is known at compile
- time, make the object a CONST_DECL. This will avoid a
- useless dereference. */
- if (Present (Address_Clause (gnat_entity)))
- {
- Node_Id gnat_address
- = Expression (Address_Clause (gnat_entity));
-
- if (compile_time_known_address_p (gnat_address))
- {
- gnu_expr = gnat_to_gnu (gnat_address);
- const_flag = true;
- }
- }
-
- used_by_ref = true;
- }
-
- /* If we are at top level and this object is of variable size,
- make the actual type a hidden pointer to the real type and
- make the initializer be a memory allocation and initialization.
- Likewise for objects we aren't defining (presumed to be
- external references from other packages), but there we do
- not set up an initialization.
-
- If the object's size overflows, make an allocator too, so that
- Storage_Error gets raised. Note that we will never free
- such memory, so we presume it never will get allocated. */
-
- if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
- global_bindings_p () || !definition
- || static_p)
- || (gnu_size
- && ! allocatable_size_p (gnu_size,
- global_bindings_p () || !definition
- || static_p)))
- {
- gnu_type = build_reference_type (gnu_type);
- gnu_size = NULL_TREE;
- used_by_ref = true;
- const_flag = true;
-
- /* In case this was a aliased object whose nominal subtype is
- unconstrained, the pointer above will be a thin pointer and
- build_allocator will automatically make the template.
-
- If we have a template initializer only (that we made above),
- pretend there is none and rely on what build_allocator creates
- again anyway. Otherwise (if we have a full initializer), get
- the data part and feed that to build_allocator.
-
- If we are elaborating a mutable object, tell build_allocator to
- ignore a possibly simpler size from the initializer, if any, as
- we must allocate the maximum possible size in this case. */
-
- if (definition)
- {
- tree gnu_alloc_type = TREE_TYPE (gnu_type);
-
- if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
- {
- gnu_alloc_type
- = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
-
- if (TREE_CODE (gnu_expr) == CONSTRUCTOR
- && 1 == VEC_length (constructor_elt,
- CONSTRUCTOR_ELTS (gnu_expr)))
- gnu_expr = 0;
- else
- gnu_expr
- = build_component_ref
- (gnu_expr, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
- false);
- }
-
- if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
- && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
- && !Is_Imported (gnat_entity))
- post_error ("?Storage_Error will be raised at run-time!",
- gnat_entity);
-
- gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
- 0, 0, gnat_entity, mutable_p);
- }
- else
- {
- gnu_expr = NULL_TREE;
- const_flag = false;
- }
- }
-
- /* If this object would go into the stack and has an alignment larger
- than the largest stack alignment the back-end can honor, resort to
- a variable of "aligning type". */
- if (!global_bindings_p () && !static_p && definition
- && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
- {
- /* Create the new variable. No need for extra room before the
- aligned field as this is in automatic storage. */
- tree gnu_new_type
- = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
- TYPE_SIZE_UNIT (gnu_type),
- BIGGEST_ALIGNMENT, 0);
- tree gnu_new_var
- = create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
- NULL_TREE, gnu_new_type, NULL_TREE, false,
- false, false, false, NULL, gnat_entity);
-
- /* Initialize the aligned field if we have an initializer. */
- if (gnu_expr)
- add_stmt_with_node
- (build_binary_op (MODIFY_EXPR, NULL_TREE,
- build_component_ref
- (gnu_new_var, NULL_TREE,
- TYPE_FIELDS (gnu_new_type), false),
- gnu_expr),
- gnat_entity);
-
- /* And setup this entity as a reference to the aligned field. */
- gnu_type = build_reference_type (gnu_type);
- gnu_expr
- = build_unary_op
- (ADDR_EXPR, gnu_type,
- build_component_ref (gnu_new_var, NULL_TREE,
- TYPE_FIELDS (gnu_new_type), false));
-
- gnu_size = NULL_TREE;
- used_by_ref = true;
- const_flag = true;
- }
-
- if (const_flag)
- gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
- | TYPE_QUAL_CONST));
-
- /* Convert the expression to the type of the object except in the
- case where the object's type is unconstrained or the object's type
- is a padded record whose field is of self-referential size. In
- the former case, converting will generate unnecessary evaluations
- of the CONSTRUCTOR to compute the size and in the latter case, we
- want to only copy the actual data. */
- if (gnu_expr
- && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type)
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
- gnu_expr = convert (gnu_type, gnu_expr);
-
- /* If this name is external or there was a name specified, use it,
- unless this is a VMS exception object since this would conflict
- with the symbol we need to export in addition. Don't use the
- Interface_Name if there is an address clause (see CD30005). */
- if (!Is_VMS_Exception (gnat_entity)
- && ((Present (Interface_Name (gnat_entity))
- && No (Address_Clause (gnat_entity)))
- || (Is_Public (gnat_entity)
- && (!Is_Imported (gnat_entity)
- || Is_Exported (gnat_entity)))))
- gnu_ext_name = create_concat_name (gnat_entity, 0);
-
- /* If this is constant initialized to a static constant and the
- object has an aggregate type, force it to be statically
- allocated. */
- if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
- && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
- && (AGGREGATE_TYPE_P (gnu_type)
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type))))
- static_p = true;
-
- gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
- gnu_expr, const_flag,
- Is_Public (gnat_entity),
- imported_p || !definition,
- static_p, attr_list, gnat_entity);
- DECL_BY_REF_P (gnu_decl) = used_by_ref;
- DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
- if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
- {
- SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
- if (global_bindings_p ())
- {
- DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
- record_global_renaming_pointer (gnu_decl);
- }
- }
-
- if (definition && DECL_SIZE (gnu_decl)
- && get_block_jmpbuf_decl ()
- && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
- || (flag_stack_check && !STACK_CHECK_BUILTIN
- && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
- STACK_CHECK_MAX_VAR_SIZE))))
- add_stmt_with_node (build_call_1_expr
- (update_setjmp_buf_decl,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- get_block_jmpbuf_decl ())),
- gnat_entity);
-
- /* If this is a public constant or we're not optimizing and we're not
- making a VAR_DECL for it, make one just for export or debugger use.
- Likewise if the address is taken or if either the object or type is
- aliased. Make an external declaration for a reference, unless this
- is a Standard entity since there no real symbol at the object level
- for these. */
- if (TREE_CODE (gnu_decl) == CONST_DECL
- && (definition || Sloc (gnat_entity) > Standard_Location)
- && ((Is_Public (gnat_entity)
- && !Present (Address_Clause (gnat_entity)))
- || optimize == 0
- || Address_Taken (gnat_entity)
- || Is_Aliased (gnat_entity)
- || Is_Aliased (Etype (gnat_entity))))
- {
- tree gnu_corr_var
- = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
- gnu_expr, true, Is_Public (gnat_entity),
- !definition, static_p, NULL,
- gnat_entity);
-
- SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
-
- /* As debugging information will be generated for the variable,
- do not generate information for the constant. */
- DECL_IGNORED_P (gnu_decl) = true;
- }
-
- /* If this is declared in a block that contains a block with an
- exception handler, we must force this variable in memory to
- suppress an invalid optimization. */
- if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
- && Exception_Mechanism != Back_End_Exceptions)
- TREE_ADDRESSABLE (gnu_decl) = 1;
-
- gnu_type = TREE_TYPE (gnu_decl);
-
- /* Back-annotate Alignment and Esize of the object if not already
- known, except for when the object is actually a pointer to the
- real object, since alignment and size of a pointer don't have
- anything to do with those of the designated object. Note that
- we pick the values of the type, not those of the object, to
- shield ourselves from low-level platform-dependent adjustments
- like alignment promotion. This is both consistent with all the
- treatment above, where alignment and size are set on the type of
- the object and not on the object directly, and makes it possible
- to support confirming representation clauses in all cases. */
-
- if (!used_by_ref && Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity,
- UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
-
- if (!used_by_ref && Unknown_Esize (gnat_entity))
- {
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- gnu_object_size
- = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
-
- Set_Esize (gnat_entity, annotate_value (gnu_object_size));
- }
- }
- break;
-
- case E_Void:
- /* Return a TYPE_DECL for "void" that we previously made. */
- gnu_decl = void_type_decl_node;
- break;
-
- case E_Enumeration_Type:
- /* A special case, for the types Character and Wide_Character in
- Standard, we do not list all the literals. So if the literals
- are not specified, make this an unsigned type. */
- if (No (First_Literal (gnat_entity)))
- {
- gnu_type = make_unsigned_type (esize);
- TYPE_NAME (gnu_type) = gnu_entity_id;
-
- /* Set the TYPE_STRING_FLAG for Ada Character and
- Wide_Character types. This is needed by the dwarf-2 debug writer to
- distinguish between unsigned integer types and character types. */
- TYPE_STRING_FLAG (gnu_type) = 1;
- break;
- }
-
- /* Normal case of non-character type, or non-Standard character type */
- {
- /* Here we have a list of enumeral constants in First_Literal.
- We make a CONST_DECL for each and build into GNU_LITERAL_LIST
- the list to be places into TYPE_FIELDS. Each node in the list
- is a TREE_LIST node whose TREE_VALUE is the literal name
- and whose TREE_PURPOSE is the value of the literal.
-
- Esize contains the number of bits needed to represent the enumeral
- type, Type_Low_Bound also points to the first literal and
- Type_High_Bound points to the last literal. */
-
- Entity_Id gnat_literal;
- tree gnu_literal_list = NULL_TREE;
-
- if (Is_Unsigned_Type (gnat_entity))
- gnu_type = make_unsigned_type (esize);
- else
- gnu_type = make_signed_type (esize);
-
- TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
-
- for (gnat_literal = First_Literal (gnat_entity);
- Present (gnat_literal);
- gnat_literal = Next_Literal (gnat_literal))
- {
- tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
- gnu_type);
- tree gnu_literal
- = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
- gnu_type, gnu_value, true, false, false,
- false, NULL, gnat_literal);
-
- save_gnu_tree (gnat_literal, gnu_literal, false);
- gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
- gnu_value, gnu_literal_list);
- }
-
- TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
-
- /* Note that the bounds are updated at the end of this function
- because to avoid an infinite recursion when we get the bounds of
- this type, since those bounds are objects of this type. */
- }
- break;
-
- case E_Signed_Integer_Type:
- case E_Ordinary_Fixed_Point_Type:
- case E_Decimal_Fixed_Point_Type:
- /* For integer types, just make a signed type the appropriate number
- of bits. */
- gnu_type = make_signed_type (esize);
- break;
-
- case E_Modular_Integer_Type:
- /* For modular types, make the unsigned type of the proper number of
- bits and then set up the modulus, if required. */
- {
- enum machine_mode mode;
- tree gnu_modulus;
- tree gnu_high = 0;
-
- if (Is_Packed_Array_Type (gnat_entity))
- esize = UI_To_Int (RM_Size (gnat_entity));
-
- /* Find the smallest mode at least ESIZE bits wide and make a class
- using that mode. */
-
- for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
- GET_MODE_BITSIZE (mode) < esize;
- mode = GET_MODE_WIDER_MODE (mode))
- ;
-
- gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
- = (Is_Packed_Array_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
-
- /* Get the modulus in this type. If it overflows, assume it is because
- it is equal to 2**Esize. Note that there is no overflow checking
- done on unsigned type, so we detect the overflow by looking for
- a modulus of zero, which is otherwise invalid. */
- gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
-
- if (!integer_zerop (gnu_modulus))
- {
- TYPE_MODULAR_P (gnu_type) = 1;
- SET_TYPE_MODULUS (gnu_type, gnu_modulus);
- gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus,
- convert (gnu_type, integer_one_node));
- }
-
- /* If we have to set TYPE_PRECISION different from its natural value,
- make a subtype to do do. Likewise if there is a modulus and
- it is not one greater than TYPE_MAX_VALUE. */
- if (TYPE_PRECISION (gnu_type) != esize
- || (TYPE_MODULAR_P (gnu_type)
- && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
- {
- tree gnu_subtype = make_node (INTEGER_TYPE);
-
- TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
- TREE_TYPE (gnu_subtype) = gnu_type;
- TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
- TYPE_MAX_VALUE (gnu_subtype)
- = TYPE_MODULAR_P (gnu_type)
- ? gnu_high : TYPE_MAX_VALUE (gnu_type);
- TYPE_PRECISION (gnu_subtype) = esize;
- TYPE_UNSIGNED (gnu_subtype) = 1;
- TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
- TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
- = (Is_Packed_Array_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
- layout_type (gnu_subtype);
-
- gnu_type = gnu_subtype;
- }
- }
- break;
-
- case E_Signed_Integer_Subtype:
- case E_Enumeration_Subtype:
- case E_Modular_Integer_Subtype:
- case E_Ordinary_Fixed_Point_Subtype:
- case E_Decimal_Fixed_Point_Subtype:
-
- /* For integral subtypes, we make a new INTEGER_TYPE. Note
- that we do not want to call build_range_type since we would
- like each subtype node to be distinct. This will be important
- when memory aliasing is implemented.
-
- The TREE_TYPE field of the INTEGER_TYPE we make points to the
- parent type; this fact is used by the arithmetic conversion
- functions.
-
- We elaborate the Ancestor_Subtype if it is not in the current
- unit and one of our bounds is non-static. We do this to ensure
- consistent naming in the case where several subtypes share the same
- bounds by always elaborating the first such subtype first, thus
- using its name. */
-
- if (!definition
- && Present (Ancestor_Subtype (gnat_entity))
- && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
- && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
- || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
- gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
- gnu_expr, 0);
-
- gnu_type = make_node (INTEGER_TYPE);
- if (Is_Packed_Array_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
- {
- esize = UI_To_Int (RM_Size (gnat_entity));
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
- }
-
- TYPE_PRECISION (gnu_type) = esize;
- TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
-
- TYPE_MIN_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_Low_Bound (gnat_entity),
- gnat_entity,
- get_identifier ("L"), definition, 1,
- Needs_Debug_Info (gnat_entity)));
-
- TYPE_MAX_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_High_Bound (gnat_entity),
- gnat_entity,
- get_identifier ("U"), definition, 1,
- Needs_Debug_Info (gnat_entity)));
-
- /* One of the above calls might have caused us to be elaborated,
- so don't blow up if so. */
- if (present_gnu_tree (gnat_entity))
- {
- maybe_present = true;
- break;
- }
-
- TYPE_BIASED_REPRESENTATION_P (gnu_type)
- = Has_Biased_Representation (gnat_entity);
-
- /* This should be an unsigned type if the lower bound is constant
- and non-negative or if the base type is unsigned; a signed type
- otherwise. */
- TYPE_UNSIGNED (gnu_type)
- = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
- || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
- && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
- || TYPE_BIASED_REPRESENTATION_P (gnu_type)
- || Is_Unsigned_Type (gnat_entity));
-
- layout_type (gnu_type);
-
- /* Inherit our alias set from what we're a subtype of. Subtypes
- are not different types and a pointer can designate any instance
- within a subtype hierarchy. */
- copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
-
- /* If the type we are dealing with is to represent a packed array,
- we need to have the bits left justified on big-endian targets
- and right justified on little-endian targets. We also need to
- ensure that when the value is read (e.g. for comparison of two
- such values), we only get the good bits, since the unused bits
- are uninitialized. Both goals are accomplished by wrapping the
- modular value in an enclosing struct. */
- if (Is_Packed_Array_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
- {
- tree gnu_field_type = gnu_type;
- tree gnu_field;
-
- TYPE_RM_SIZE_NUM (gnu_field_type)
- = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
- gnu_type = make_node (RECORD_TYPE);
- TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
-
- /* Propagate the alignment of the modular type to the record.
- This means that bitpacked arrays have "ceil" alignment for
- their size, which may seem counter-intuitive but makes it
- possible to easily overlay them on modular types. */
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
- TYPE_PACKED (gnu_type) = 1;
-
- /* Create a stripped-down declaration of the original type, mainly
- for debugging. */
- create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
- NULL, true, debug_info_p, gnat_entity);
-
- /* Don't notify the field as "addressable", since we won't be taking
- it's address and it would prevent create_field_decl from making a
- bitfield. */
- gnu_field = create_field_decl (get_identifier ("OBJECT"),
- gnu_field_type, gnu_type, 1, 0, 0, 0);
-
- finish_record_type (gnu_type, gnu_field, 0, false);
- TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
- SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
-
- copy_alias_set (gnu_type, gnu_field_type);
- }
-
- /* If the type we are dealing with has got a smaller alignment than the
- natural one, we need to wrap it up in a record type and under-align
- the latter. We reuse the padding machinery for this purpose. */
- else if (Known_Alignment (gnat_entity)
- && UI_Is_In_Int_Range (Alignment (gnat_entity))
- && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT)
- && align < TYPE_ALIGN (gnu_type))
- {
- tree gnu_field_type = gnu_type;
- tree gnu_field;
-
- gnu_type = make_node (RECORD_TYPE);
- TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
-
- TYPE_ALIGN (gnu_type) = align;
- TYPE_PACKED (gnu_type) = 1;
-
- /* Create a stripped-down declaration of the original type, mainly
- for debugging. */
- create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
- NULL, true, debug_info_p, gnat_entity);
-
- /* Don't notify the field as "addressable", since we won't be taking
- it's address and it would prevent create_field_decl from making a
- bitfield. */
- gnu_field = create_field_decl (get_identifier ("OBJECT"),
- gnu_field_type, gnu_type, 1, 0, 0, 0);
-
- finish_record_type (gnu_type, gnu_field, 0, false);
- TYPE_IS_PADDING_P (gnu_type) = 1;
- SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
-
- copy_alias_set (gnu_type, gnu_field_type);
- }
-
- /* Otherwise reset the alignment lest we computed it above. */
- else
- align = 0;
-
- break;
-
- case E_Floating_Point_Type:
- /* If this is a VAX floating-point type, use an integer of the proper
- size. All the operations will be handled with ASM statements. */
- if (Vax_Float (gnat_entity))
- {
- gnu_type = make_signed_type (esize);
- TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
- SET_TYPE_DIGITS_VALUE (gnu_type,
- UI_To_gnu (Digits_Value (gnat_entity),
- sizetype));
- break;
- }
-
- /* The type of the Low and High bounds can be our type if this is
- a type from Standard, so set them at the end of the function. */
- gnu_type = make_node (REAL_TYPE);
- TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
- layout_type (gnu_type);
- break;
-
- case E_Floating_Point_Subtype:
- if (Vax_Float (gnat_entity))
- {
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
- break;
- }
-
- {
- if (!definition
- && Present (Ancestor_Subtype (gnat_entity))
- && !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
- && (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
- || !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
- gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
- gnu_expr, 0);
-
- gnu_type = make_node (REAL_TYPE);
- TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
- TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
-
- TYPE_MIN_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_Low_Bound (gnat_entity),
- gnat_entity, get_identifier ("L"),
- definition, 1,
- Needs_Debug_Info (gnat_entity)));
-
- TYPE_MAX_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_High_Bound (gnat_entity),
- gnat_entity, get_identifier ("U"),
- definition, 1,
- Needs_Debug_Info (gnat_entity)));
-
- /* One of the above calls might have caused us to be elaborated,
- so don't blow up if so. */
- if (present_gnu_tree (gnat_entity))
- {
- maybe_present = true;
- break;
- }
-
- layout_type (gnu_type);
-
- /* Inherit our alias set from what we're a subtype of, as for
- integer subtypes. */
- copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
- }
- break;
-
- /* Array and String Types and Subtypes
-
- Unconstrained array types are represented by E_Array_Type and
- constrained array types are represented by E_Array_Subtype. There
- are no actual objects of an unconstrained array type; all we have
- are pointers to that type.
-
- The following fields are defined on array types and subtypes:
-
- Component_Type Component type of the array.
- Number_Dimensions Number of dimensions (an int).
- First_Index Type of first index. */
-
- case E_String_Type:
- case E_Array_Type:
- {
- tree gnu_template_fields = NULL_TREE;
- tree gnu_template_type = make_node (RECORD_TYPE);
- tree gnu_ptr_template = build_pointer_type (gnu_template_type);
- tree gnu_fat_type = make_node (RECORD_TYPE);
- int ndim = Number_Dimensions (gnat_entity);
- int firstdim
- = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
- int nextdim
- = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
- int index;
- tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
- tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
- tree gnu_comp_size = 0;
- tree gnu_max_size = size_one_node;
- tree gnu_max_size_unit;
- Entity_Id gnat_ind_subtype;
- Entity_Id gnat_ind_base_subtype;
- tree gnu_template_reference;
- tree tem;
-
- TYPE_NAME (gnu_template_type)
- = create_concat_name (gnat_entity, "XUB");
-
- /* Make a node for the array. If we are not defining the array
- suppress expanding incomplete types. */
- gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
-
- if (!definition)
- defer_incomplete_level++, this_deferred = true;
-
- /* Build the fat pointer type. Use a "void *" object instead of
- a pointer to the array type since we don't have the array type
- yet (it will reference the fat pointer via the bounds). */
- tem = chainon (chainon (NULL_TREE,
- create_field_decl (get_identifier ("P_ARRAY"),
- ptr_void_type_node,
- gnu_fat_type, 0, 0, 0, 0)),
- create_field_decl (get_identifier ("P_BOUNDS"),
- gnu_ptr_template,
- gnu_fat_type, 0, 0, 0, 0));
-
- /* Make sure we can put this into a register. */
- TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
-
- /* Do not finalize this record type since the types of its fields
- are still incomplete at this point. */
- finish_record_type (gnu_fat_type, tem, 0, true);
- TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
-
- /* Build a reference to the template from a PLACEHOLDER_EXPR that
- is the fat pointer. This will be used to access the individual
- fields once we build them. */
- tem = build3 (COMPONENT_REF, gnu_ptr_template,
- build0 (PLACEHOLDER_EXPR, gnu_fat_type),
- TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
- gnu_template_reference
- = build_unary_op (INDIRECT_REF, gnu_template_type, tem);
- TREE_READONLY (gnu_template_reference) = 1;
-
- /* Now create the GCC type for each index and add the fields for
- that index to the template. */
- for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
- gnat_ind_base_subtype
- = First_Index (Implementation_Base_Type (gnat_entity));
- index < ndim && index >= 0;
- index += nextdim,
- gnat_ind_subtype = Next_Index (gnat_ind_subtype),
- gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
- {
- char field_name[10];
- tree gnu_ind_subtype
- = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
- tree gnu_base_subtype
- = get_unpadded_type (Etype (gnat_ind_base_subtype));
- tree gnu_base_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
- tree gnu_base_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
- tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
-
- /* Make the FIELD_DECLs for the minimum and maximum of this
- type and then make extractions of that field from the
- template. */
- sprintf (field_name, "LB%d", index);
- gnu_min_field = create_field_decl (get_identifier (field_name),
- gnu_ind_subtype,
- gnu_template_type, 0, 0, 0, 0);
- field_name[0] = 'U';
- gnu_max_field = create_field_decl (get_identifier (field_name),
- gnu_ind_subtype,
- gnu_template_type, 0, 0, 0, 0);
-
- Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_min_field));
- Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_max_field));
- gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
-
- /* We can't use build_component_ref here since the template
- type isn't complete yet. */
- gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_min_field,
- NULL_TREE);
- gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_max_field,
- NULL_TREE);
- TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
-
- /* Make a range type with the new ranges, but using
- the Ada subtype. Then we convert to sizetype. */
- gnu_index_types[index]
- = create_index_type (convert (sizetype, gnu_min),
- convert (sizetype, gnu_max),
- build_range_type (gnu_ind_subtype,
- gnu_min, gnu_max),
- gnat_entity);
- /* Update the maximum size of the array, in elements. */
- gnu_max_size
- = size_binop (MULT_EXPR, gnu_max_size,
- size_binop (PLUS_EXPR, size_one_node,
- size_binop (MINUS_EXPR, gnu_base_max,
- gnu_base_min)));
-
- TYPE_NAME (gnu_index_types[index])
- = create_concat_name (gnat_entity, field_name);
- }
-
- for (index = 0; index < ndim; index++)
- gnu_template_fields
- = chainon (gnu_template_fields, gnu_temp_fields[index]);
-
- /* Install all the fields into the template. */
- finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
- TYPE_READONLY (gnu_template_type) = 1;
-
- /* Now make the array of arrays and update the pointer to the array
- in the fat pointer. Note that it is the first field. */
- tem = gnat_to_gnu_type (Component_Type (gnat_entity));
-
- /* Try to get a smaller form of the component if needed. */
- if ((Is_Packed (gnat_entity)
- || Has_Component_Size_Clause (gnat_entity))
- && !Is_Bit_Packed_Array (gnat_entity)
- && !Has_Aliased_Components (gnat_entity)
- && !Strict_Alignment (Component_Type (gnat_entity))
- && TREE_CODE (tem) == RECORD_TYPE
- && host_integerp (TYPE_SIZE (tem), 1))
- tem = make_packable_type (tem, false);
-
- if (Has_Atomic_Components (gnat_entity))
- check_ok_for_atomic (tem, gnat_entity, true);
-
- /* Get and validate any specified Component_Size, but if Packed,
- ignore it since the front end will have taken care of it. */
- gnu_comp_size
- = validate_size (Component_Size (gnat_entity), tem,
- gnat_entity,
- (Is_Bit_Packed_Array (gnat_entity)
- ? TYPE_DECL : VAR_DECL),
- true, Has_Component_Size_Clause (gnat_entity));
-
- /* If the component type is a RECORD_TYPE that has a self-referential
- size, use the maxium size. */
- if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
- gnu_comp_size = max_size (TYPE_SIZE (tem), true);
-
- if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
- {
- tree orig_tem;
- tem = make_type_from_size (tem, gnu_comp_size, false);
- orig_tem = tem;
- tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
- "C_PAD", false, definition, true);
- /* If a padding record was made, declare it now since it will
- never be declared otherwise. This is necessary to ensure
- that its subtrees are properly marked. */
- if (tem != orig_tem)
- create_type_decl (TYPE_NAME (tem), tem, NULL, true, false,
- gnat_entity);
- }
-
- if (Has_Volatile_Components (gnat_entity))
- tem = build_qualified_type (tem,
- TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
-
- /* If Component_Size is not already specified, annotate it with the
- size of the component. */
- if (Unknown_Component_Size (gnat_entity))
- Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
-
- gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
- size_binop (MULT_EXPR, gnu_max_size,
- TYPE_SIZE_UNIT (tem)));
- gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
- size_binop (MULT_EXPR,
- convert (bitsizetype,
- gnu_max_size),
- TYPE_SIZE (tem)));
-
- for (index = ndim - 1; index >= 0; index--)
- {
- tem = build_array_type (tem, gnu_index_types[index]);
- TYPE_MULTI_ARRAY_P (tem) = (index > 0);
- if (array_type_has_nonaliased_component (gnat_entity, tem))
- TYPE_NONALIASED_COMPONENT (tem) = 1;
- }
-
- /* If an alignment is specified, use it if valid. But ignore it for
- types that represent the unpacked base type for packed arrays. If
- the alignment was requested with an explicit user alignment clause,
- state so. */
- if (No (Packed_Array_Type (gnat_entity))
- && Known_Alignment (gnat_entity))
- {
- gcc_assert (Present (Alignment (gnat_entity)));
- TYPE_ALIGN (tem)
- = validate_alignment (Alignment (gnat_entity), gnat_entity,
- TYPE_ALIGN (tem));
- if (Present (Alignment_Clause (gnat_entity)))
- TYPE_USER_ALIGN (tem) = 1;
- }
-
- TYPE_CONVENTION_FORTRAN_P (tem)
- = (Convention (gnat_entity) == Convention_Fortran);
- TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
-
- /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
- corresponding fat pointer. */
- TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
- = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
- TYPE_MODE (gnu_type) = BLKmode;
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
- SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
-
- /* If the maximum size doesn't overflow, use it. */
- if (TREE_CODE (gnu_max_size) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_max_size))
- TYPE_SIZE (tem)
- = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
- if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_max_size_unit))
- TYPE_SIZE_UNIT (tem)
- = size_binop (MIN_EXPR, gnu_max_size_unit,
- TYPE_SIZE_UNIT (tem));
-
- create_type_decl (create_concat_name (gnat_entity, "XUA"),
- tem, NULL, !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
-
- /* Give the fat pointer type a name. */
- create_type_decl (create_concat_name (gnat_entity, "XUP"),
- gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
-
- /* Create the type to be used as what a thin pointer designates: an
- record type for the object and its template with the field offsets
- shifted to have the template at a negative offset. */
- tem = build_unc_object_type (gnu_template_type, tem,
- create_concat_name (gnat_entity, "XUT"));
- shift_unc_components_for_thin_pointers (tem);
-
- SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
- TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
-
- /* Give the thin pointer type a name. */
- create_type_decl (create_concat_name (gnat_entity, "XUX"),
- build_pointer_type (tem), NULL,
- !Comes_From_Source (gnat_entity), debug_info_p,
- gnat_entity);
- }
- break;
-
- case E_String_Subtype:
- case E_Array_Subtype:
-
- /* This is the actual data type for array variables. Multidimensional
- arrays are implemented in the gnu tree as arrays of arrays. Note
- that for the moment arrays which have sparse enumeration subtypes as
- index components create sparse arrays, which is obviously space
- inefficient but so much easier to code for now.
-
- Also note that the subtype never refers to the unconstrained
- array type, which is somewhat at variance with Ada semantics.
-
- First check to see if this is simply a renaming of the array
- type. If so, the result is the array type. */
-
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
- if (!Is_Constrained (gnat_entity))
- break;
- else
- {
- int index;
- int array_dim = Number_Dimensions (gnat_entity);
- int first_dim
- = ((Convention (gnat_entity) == Convention_Fortran)
- ? array_dim - 1 : 0);
- int next_dim
- = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
- Entity_Id gnat_ind_subtype;
- Entity_Id gnat_ind_base_subtype;
- tree gnu_base_type = gnu_type;
- tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
- tree gnu_comp_size = NULL_TREE;
- tree gnu_max_size = size_one_node;
- tree gnu_max_size_unit;
- bool need_index_type_struct = false;
- bool max_overflow = false;
-
- /* First create the gnu types for each index. Create types for
- debugging information to point to the index types if the
- are not integer types, have variable bounds, or are
- wider than sizetype. */
-
- for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
- gnat_ind_base_subtype
- = First_Index (Implementation_Base_Type (gnat_entity));
- index < array_dim && index >= 0;
- index += next_dim,
- gnat_ind_subtype = Next_Index (gnat_ind_subtype),
- gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
- {
- tree gnu_index_subtype
- = get_unpadded_type (Etype (gnat_ind_subtype));
- tree gnu_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
- tree gnu_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
- tree gnu_base_subtype
- = get_unpadded_type (Etype (gnat_ind_base_subtype));
- tree gnu_base_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
- tree gnu_base_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
- tree gnu_base_type = get_base_type (gnu_base_subtype);
- tree gnu_base_base_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
- tree gnu_base_base_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
- tree gnu_high;
- tree gnu_this_max;
-
- /* If the minimum and maximum values both overflow in
- SIZETYPE, but the difference in the original type
- does not overflow in SIZETYPE, ignore the overflow
- indications. */
- if ((TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype)
- || TYPE_UNSIGNED (gnu_index_subtype)
- != TYPE_UNSIGNED (sizetype))
- && TREE_CODE (gnu_min) == INTEGER_CST
- && TREE_CODE (gnu_max) == INTEGER_CST
- && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
- && (!TREE_OVERFLOW
- (fold_build2 (MINUS_EXPR, gnu_index_subtype,
- TYPE_MAX_VALUE (gnu_index_subtype),
- TYPE_MIN_VALUE (gnu_index_subtype)))))
- {
- TREE_OVERFLOW (gnu_min) = 0;
- TREE_OVERFLOW (gnu_max) = 0;
- }
-
- /* Similarly, if the range is null, use bounds of 1..0 for
- the sizetype bounds. */
- else if ((TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype)
- || TYPE_UNSIGNED (gnu_index_subtype)
- != TYPE_UNSIGNED (sizetype))
- && TREE_CODE (gnu_min) == INTEGER_CST
- && TREE_CODE (gnu_max) == INTEGER_CST
- && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
- && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
- TYPE_MIN_VALUE (gnu_index_subtype)))
- gnu_min = size_one_node, gnu_max = size_zero_node;
-
- /* Now compute the size of this bound. We need to provide
- GCC with an upper bound to use but have to deal with the
- "superflat" case. There are three ways to do this. If we
- can prove that the array can never be superflat, we can
- just use the high bound of the index subtype. If we can
- prove that the low bound minus one can't overflow, we
- can do this as MAX (hb, lb - 1). Otherwise, we have to use
- the expression hb >= lb ? hb : lb - 1. */
- gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
-
- /* See if the base array type is already flat. If it is, we
- are probably compiling an ACVC test, but it will cause the
- code below to malfunction if we don't handle it specially. */
- if (TREE_CODE (gnu_base_min) == INTEGER_CST
- && TREE_CODE (gnu_base_max) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_base_min)
- && !TREE_OVERFLOW (gnu_base_max)
- && tree_int_cst_lt (gnu_base_max, gnu_base_min))
- gnu_high = size_zero_node, gnu_min = size_one_node;
-
- /* If gnu_high is now an integer which overflowed, the array
- cannot be superflat. */
- else if (TREE_CODE (gnu_high) == INTEGER_CST
- && TREE_OVERFLOW (gnu_high))
- gnu_high = gnu_max;
- else if (TYPE_UNSIGNED (gnu_base_subtype)
- || TREE_CODE (gnu_high) == INTEGER_CST)
- gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
- else
- gnu_high
- = build_cond_expr
- (sizetype, build_binary_op (GE_EXPR, integer_type_node,
- gnu_max, gnu_min),
- gnu_max, gnu_high);
-
- gnu_index_type[index]
- = create_index_type (gnu_min, gnu_high, gnu_index_subtype,
- gnat_entity);
-
- /* Also compute the maximum size of the array. Here we
- see if any constraint on the index type of the base type
- can be used in the case of self-referential bound on
- the index type of the subtype. We look for a non-"infinite"
- and non-self-referential bound from any type involved and
- handle each bound separately. */
-
- if ((TREE_CODE (gnu_min) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_min)
- && !operand_equal_p (gnu_min, gnu_base_base_min, 0))
- || !CONTAINS_PLACEHOLDER_P (gnu_min)
- || !(TREE_CODE (gnu_base_min) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_base_min)))
- gnu_base_min = gnu_min;
-
- if ((TREE_CODE (gnu_max) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_max)
- && !operand_equal_p (gnu_max, gnu_base_base_max, 0))
- || !CONTAINS_PLACEHOLDER_P (gnu_max)
- || !(TREE_CODE (gnu_base_max) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_base_max)))
- gnu_base_max = gnu_max;
-
- if ((TREE_CODE (gnu_base_min) == INTEGER_CST
- && TREE_OVERFLOW (gnu_base_min))
- || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
- || (TREE_CODE (gnu_base_max) == INTEGER_CST
- && TREE_OVERFLOW (gnu_base_max))
- || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
- max_overflow = true;
-
- gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
- gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
-
- gnu_this_max
- = size_binop (MAX_EXPR,
- size_binop (PLUS_EXPR, size_one_node,
- size_binop (MINUS_EXPR, gnu_base_max,
- gnu_base_min)),
- size_zero_node);
-
- if (TREE_CODE (gnu_this_max) == INTEGER_CST
- && TREE_OVERFLOW (gnu_this_max))
- max_overflow = true;
-
- gnu_max_size
- = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
-
- if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
- || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
- != INTEGER_CST)
- || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
- || (TREE_TYPE (gnu_index_subtype)
- && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
- != INTEGER_TYPE))
- || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
- || (TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype)))
- need_index_type_struct = true;
- }
-
- /* Then flatten: create the array of arrays. For an array type
- used to implement a packed array, get the component type from
- the original array type since the representation clauses that
- can affect it are on the latter. */
- if (Is_Packed_Array_Type (gnat_entity)
- && !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
- {
- gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
- for (index = array_dim - 1; index >= 0; index--)
- gnu_type = TREE_TYPE (gnu_type);
-
- /* One of the above calls might have caused us to be elaborated,
- so don't blow up if so. */
- if (present_gnu_tree (gnat_entity))
- {
- maybe_present = true;
- break;
- }
- }
- else
- {
- gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
-
- /* One of the above calls might have caused us to be elaborated,
- so don't blow up if so. */
- if (present_gnu_tree (gnat_entity))
- {
- maybe_present = true;
- break;
- }
-
- /* Try to get a smaller form of the component if needed. */
- if ((Is_Packed (gnat_entity)
- || Has_Component_Size_Clause (gnat_entity))
- && !Is_Bit_Packed_Array (gnat_entity)
- && !Has_Aliased_Components (gnat_entity)
- && !Strict_Alignment (Component_Type (gnat_entity))
- && TREE_CODE (gnu_type) == RECORD_TYPE
- && host_integerp (TYPE_SIZE (gnu_type), 1))
- gnu_type = make_packable_type (gnu_type, false);
-
- /* Get and validate any specified Component_Size, but if Packed,
- ignore it since the front end will have taken care of it. */
- gnu_comp_size
- = validate_size (Component_Size (gnat_entity), gnu_type,
- gnat_entity,
- (Is_Bit_Packed_Array (gnat_entity)
- ? TYPE_DECL : VAR_DECL), true,
- Has_Component_Size_Clause (gnat_entity));
-
- /* If the component type is a RECORD_TYPE that has a
- self-referential size, use the maxium size. */
- if (!gnu_comp_size
- && TREE_CODE (gnu_type) == RECORD_TYPE
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
- gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
-
- if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
- {
- tree orig_gnu_type;
- gnu_type
- = make_type_from_size (gnu_type, gnu_comp_size, false);
- orig_gnu_type = gnu_type;
- gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
- gnat_entity, "C_PAD", false,
- definition, true);
- /* If a padding record was made, declare it now since it
- will never be declared otherwise. This is necessary
- to ensure that its subtrees are properly marked. */
- if (gnu_type != orig_gnu_type)
- create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL,
- true, false, gnat_entity);
- }
-
- if (Has_Volatile_Components (Base_Type (gnat_entity)))
- gnu_type = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | TYPE_QUAL_VOLATILE));
- }
-
- gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
- TYPE_SIZE_UNIT (gnu_type));
- gnu_max_size = size_binop (MULT_EXPR,
- convert (bitsizetype, gnu_max_size),
- TYPE_SIZE (gnu_type));
-
- for (index = array_dim - 1; index >= 0; index --)
- {
- gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
- TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
- if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
- TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
- }
-
- /* If we are at file level and this is a multi-dimensional array, we
- need to make a variable corresponding to the stride of the
- inner dimensions. */
- if (global_bindings_p () && array_dim > 1)
- {
- tree gnu_str_name = get_identifier ("ST");
- tree gnu_arr_type;
-
- for (gnu_arr_type = TREE_TYPE (gnu_type);
- TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
- gnu_arr_type = TREE_TYPE (gnu_arr_type),
- gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
- {
- tree eltype = TREE_TYPE (gnu_arr_type);
-
- TYPE_SIZE (gnu_arr_type)
- = elaborate_expression_1 (gnat_entity, gnat_entity,
- TYPE_SIZE (gnu_arr_type),
- gnu_str_name, definition, 0);
-
- /* ??? For now, store the size as a multiple of the
- alignment of the element type in bytes so that we
- can see the alignment from the tree. */
- TYPE_SIZE_UNIT (gnu_arr_type)
- = build_binary_op
- (MULT_EXPR, sizetype,
- elaborate_expression_1
- (gnat_entity, gnat_entity,
- build_binary_op (EXACT_DIV_EXPR, sizetype,
- TYPE_SIZE_UNIT (gnu_arr_type),
- size_int (TYPE_ALIGN (eltype)
- / BITS_PER_UNIT)),
- concat_id_with_name (gnu_str_name, "A_U"),
- definition, 0),
- size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
-
- /* ??? create_type_decl is not invoked on the inner types so
- the MULT_EXPR node built above will never be marked. */
- mark_visited (&TYPE_SIZE_UNIT (gnu_arr_type));
- }
- }
-
- /* If we need to write out a record type giving the names of
- the bounds, do it now. */
- if (need_index_type_struct && debug_info_p)
- {
- tree gnu_bound_rec_type = make_node (RECORD_TYPE);
- tree gnu_field_list = NULL_TREE;
- tree gnu_field;
-
- TYPE_NAME (gnu_bound_rec_type)
- = create_concat_name (gnat_entity, "XA");
-
- for (index = array_dim - 1; index >= 0; index--)
- {
- tree gnu_type_name
- = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
-
- if (TREE_CODE (gnu_type_name) == TYPE_DECL)
- gnu_type_name = DECL_NAME (gnu_type_name);
-
- gnu_field = create_field_decl (gnu_type_name,
- integer_type_node,
- gnu_bound_rec_type,
- 0, NULL_TREE, NULL_TREE, 0);
- TREE_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- }
-
- finish_record_type (gnu_bound_rec_type, gnu_field_list,
- 0, false);
-
- TYPE_STUB_DECL (gnu_type)
- = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
-
- add_parallel_type
- (TYPE_STUB_DECL (gnu_type), gnu_bound_rec_type);
- }
-
- TYPE_CONVENTION_FORTRAN_P (gnu_type)
- = (Convention (gnat_entity) == Convention_Fortran);
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
- = (Is_Packed_Array_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
-
- /* If our size depends on a placeholder and the maximum size doesn't
- overflow, use it. */
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
- && !(TREE_CODE (gnu_max_size) == INTEGER_CST
- && TREE_OVERFLOW (gnu_max_size))
- && !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
- && TREE_OVERFLOW (gnu_max_size_unit))
- && !max_overflow)
- {
- TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
- TYPE_SIZE (gnu_type));
- TYPE_SIZE_UNIT (gnu_type)
- = size_binop (MIN_EXPR, gnu_max_size_unit,
- TYPE_SIZE_UNIT (gnu_type));
- }
-
- /* Set our alias set to that of our base type. This gives all
- array subtypes the same alias set. */
- copy_alias_set (gnu_type, gnu_base_type);
- }
-
- /* If this is a packed type, make this type the same as the packed
- array type, but do some adjusting in the type first. */
-
- if (Present (Packed_Array_Type (gnat_entity)))
- {
- Entity_Id gnat_index;
- tree gnu_inner_type;
-
- /* First finish the type we had been making so that we output
- debugging information for it */
- gnu_type
- = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | (TYPE_QUAL_VOLATILE
- * Treat_As_Volatile (gnat_entity))));
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- if (!Comes_From_Source (gnat_entity))
- DECL_ARTIFICIAL (gnu_decl) = 1;
-
- /* Save it as our equivalent in case the call below elaborates
- this type again. */
- save_gnu_tree (gnat_entity, gnu_decl, false);
-
- gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
- NULL_TREE, 0);
- this_made_decl = true;
- gnu_type = TREE_TYPE (gnu_decl);
- save_gnu_tree (gnat_entity, NULL_TREE, false);
-
- gnu_inner_type = gnu_type;
- while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
- && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type)
- || TYPE_IS_PADDING_P (gnu_inner_type)))
- gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
-
- /* We need to point the type we just made to our index type so
- the actual bounds can be put into a template. */
-
- if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
- && !TYPE_ACTUAL_BOUNDS (gnu_inner_type))
- || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
- && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
- {
- if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
- {
- /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
- If it is, we need to make another type. */
- if (TYPE_MODULAR_P (gnu_inner_type))
- {
- tree gnu_subtype;
-
- gnu_subtype = make_node (INTEGER_TYPE);
-
- TREE_TYPE (gnu_subtype) = gnu_inner_type;
- TYPE_MIN_VALUE (gnu_subtype)
- = TYPE_MIN_VALUE (gnu_inner_type);
- TYPE_MAX_VALUE (gnu_subtype)
- = TYPE_MAX_VALUE (gnu_inner_type);
- TYPE_PRECISION (gnu_subtype)
- = TYPE_PRECISION (gnu_inner_type);
- TYPE_UNSIGNED (gnu_subtype)
- = TYPE_UNSIGNED (gnu_inner_type);
- TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
- layout_type (gnu_subtype);
-
- gnu_inner_type = gnu_subtype;
- }
-
- TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
- }
-
- SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
-
- for (gnat_index = First_Index (gnat_entity);
- Present (gnat_index); gnat_index = Next_Index (gnat_index))
- SET_TYPE_ACTUAL_BOUNDS
- (gnu_inner_type,
- tree_cons (NULL_TREE,
- get_unpadded_type (Etype (gnat_index)),
- TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
-
- if (Convention (gnat_entity) != Convention_Fortran)
- SET_TYPE_ACTUAL_BOUNDS
- (gnu_inner_type,
- nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
-
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
- TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
- }
- }
-
- /* Abort if packed array with no packed array type field set. */
- else
- gcc_assert (!Is_Packed (gnat_entity));
-
- break;
-
- case E_String_Literal_Subtype:
- /* Create the type for a string literal. */
- {
- Entity_Id gnat_full_type
- = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
- && Present (Full_View (Etype (gnat_entity)))
- ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
- tree gnu_string_type = get_unpadded_type (gnat_full_type);
- tree gnu_string_array_type
- = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
- tree gnu_string_index_type
- = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
- (TYPE_DOMAIN (gnu_string_array_type))));
- tree gnu_lower_bound
- = convert (gnu_string_index_type,
- gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
- int length = UI_To_Int (String_Literal_Length (gnat_entity));
- tree gnu_length = ssize_int (length - 1);
- tree gnu_upper_bound
- = build_binary_op (PLUS_EXPR, gnu_string_index_type,
- gnu_lower_bound,
- convert (gnu_string_index_type, gnu_length));
- tree gnu_range_type
- = build_range_type (gnu_string_index_type,
- gnu_lower_bound, gnu_upper_bound);
- tree gnu_index_type
- = create_index_type (convert (sizetype,
- TYPE_MIN_VALUE (gnu_range_type)),
- convert (sizetype,
- TYPE_MAX_VALUE (gnu_range_type)),
- gnu_range_type, gnat_entity);
-
- gnu_type
- = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
- gnu_index_type);
- copy_alias_set (gnu_type, gnu_string_type);
- }
- break;
-
- /* Record Types and Subtypes
-
- The following fields are defined on record types:
-
- Has_Discriminants True if the record has discriminants
- First_Discriminant Points to head of list of discriminants
- First_Entity Points to head of list of fields
- Is_Tagged_Type True if the record is tagged
-
- Implementation of Ada records and discriminated records:
-
- A record type definition is transformed into the equivalent of a C
- struct definition. The fields that are the discriminants which are
- found in the Full_Type_Declaration node and the elements of the
- Component_List found in the Record_Type_Definition node. The
- Component_List can be a recursive structure since each Variant of
- the Variant_Part of the Component_List has a Component_List.
-
- Processing of a record type definition comprises starting the list of
- field declarations here from the discriminants and the calling the
- function components_to_record to add the rest of the fields from the
- component list and return the gnu type node. The function
- components_to_record will call itself recursively as it traverses
- the tree. */
-
- case E_Record_Type:
- if (Has_Complex_Representation (gnat_entity))
- {
- gnu_type
- = build_complex_type
- (get_unpadded_type
- (Etype (Defining_Entity
- (First (Component_Items
- (Component_List
- (Type_Definition
- (Declaration_Node (gnat_entity)))))))));
-
- break;
- }
-
- {
- Node_Id full_definition = Declaration_Node (gnat_entity);
- Node_Id record_definition = Type_Definition (full_definition);
- Entity_Id gnat_field;
- tree gnu_field;
- tree gnu_field_list = NULL_TREE;
- tree gnu_get_parent;
- /* Set PACKED in keeping with gnat_to_gnu_field. */
- int packed
- = Is_Packed (gnat_entity)
- ? 1
- : Component_Alignment (gnat_entity) == Calign_Storage_Unit
- ? -1
- : (Known_Alignment (gnat_entity)
- || (Strict_Alignment (gnat_entity)
- && Known_Static_Esize (gnat_entity)))
- ? -2
- : 0;
- bool has_rep = Has_Specified_Layout (gnat_entity);
- bool all_rep = has_rep;
- bool is_extension
- = (Is_Tagged_Type (gnat_entity)
- && Nkind (record_definition) == N_Derived_Type_Definition);
-
- /* See if all fields have a rep clause. Stop when we find one
- that doesn't. */
- for (gnat_field = First_Entity (gnat_entity);
- Present (gnat_field) && all_rep;
- gnat_field = Next_Entity (gnat_field))
- if ((Ekind (gnat_field) == E_Component
- || Ekind (gnat_field) == E_Discriminant)
- && No (Component_Clause (gnat_field)))
- all_rep = false;
-
- /* If this is a record extension, go a level further to find the
- record definition. Also, verify we have a Parent_Subtype. */
- if (is_extension)
- {
- if (!type_annotate_only
- || Present (Record_Extension_Part (record_definition)))
- record_definition = Record_Extension_Part (record_definition);
-
- gcc_assert (type_annotate_only
- || Present (Parent_Subtype (gnat_entity)));
- }
-
- /* Make a node for the record. If we are not defining the record,
- suppress expanding incomplete types. */
- gnu_type = make_node (tree_code_for_record_type (gnat_entity));
- TYPE_NAME (gnu_type) = gnu_entity_id;
- TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
-
- if (!definition)
- defer_incomplete_level++, this_deferred = true;
-
- /* If both a size and rep clause was specified, put the size in
- the record type now so that it can get the proper mode. */
- if (has_rep && Known_Esize (gnat_entity))
- TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
-
- /* Always set the alignment here so that it can be used to
- set the mode, if it is making the alignment stricter. If
- it is invalid, it will be checked again below. If this is to
- be Atomic, choose a default alignment of a word unless we know
- the size and it's smaller. */
- if (Known_Alignment (gnat_entity))
- TYPE_ALIGN (gnu_type)
- = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
- else if (Is_Atomic (gnat_entity))
- TYPE_ALIGN (gnu_type)
- = esize >= BITS_PER_WORD ? BITS_PER_WORD : ceil_alignment (esize);
- /* If a type needs strict alignment, the minimum size will be the
- type size instead of the RM size (see validate_size). Cap the
- alignment, lest it causes this type size to become too large. */
- else if (Strict_Alignment (gnat_entity)
- && Known_Static_Esize (gnat_entity))
- {
- unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
- unsigned int raw_align = raw_size & -raw_size;
- if (raw_align < BIGGEST_ALIGNMENT)
- TYPE_ALIGN (gnu_type) = raw_align;
- }
- else
- TYPE_ALIGN (gnu_type) = 0;
-
- /* If we have a Parent_Subtype, make a field for the parent. If
- this record has rep clauses, force the position to zero. */
- if (Present (Parent_Subtype (gnat_entity)))
- {
- Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
- tree gnu_parent;
-
- /* A major complexity here is that the parent subtype will
- reference our discriminants in its Discriminant_Constraint
- list. But those must reference the parent component of this
- record which is of the parent subtype we have not built yet!
- To break the circle we first build a dummy COMPONENT_REF which
- represents the "get to the parent" operation and initialize
- each of those discriminants to a COMPONENT_REF of the above
- dummy parent referencing the corresponding discriminant of the
- base type of the parent subtype. */
- gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
- build0 (PLACEHOLDER_EXPR, gnu_type),
- build_decl (FIELD_DECL, NULL_TREE,
- void_type_node),
- NULL_TREE);
-
- if (Has_Discriminants (gnat_entity))
- for (gnat_field = First_Stored_Discriminant (gnat_entity);
- Present (gnat_field);
- gnat_field = Next_Stored_Discriminant (gnat_field))
- if (Present (Corresponding_Discriminant (gnat_field)))
- save_gnu_tree
- (gnat_field,
- build3 (COMPONENT_REF,
- get_unpadded_type (Etype (gnat_field)),
- gnu_get_parent,
- gnat_to_gnu_field_decl (Corresponding_Discriminant
- (gnat_field)),
- NULL_TREE),
- true);
-
- /* Then we build the parent subtype. */
- gnu_parent = gnat_to_gnu_type (gnat_parent);
-
- /* Finally we fix up both kinds of twisted COMPONENT_REF we have
- initially built. The discriminants must reference the fields
- of the parent subtype and not those of its base type for the
- placeholder machinery to properly work. */
- if (Has_Discriminants (gnat_entity))
- for (gnat_field = First_Stored_Discriminant (gnat_entity);
- Present (gnat_field);
- gnat_field = Next_Stored_Discriminant (gnat_field))
- if (Present (Corresponding_Discriminant (gnat_field)))
- {
- Entity_Id field = Empty;
- for (field = First_Stored_Discriminant (gnat_parent);
- Present (field);
- field = Next_Stored_Discriminant (field))
- if (same_discriminant_p (gnat_field, field))
- break;
- gcc_assert (Present (field));
- TREE_OPERAND (get_gnu_tree (gnat_field), 1)
- = gnat_to_gnu_field_decl (field);
- }
-
- /* The "get to the parent" COMPONENT_REF must be given its
- proper type... */
- TREE_TYPE (gnu_get_parent) = gnu_parent;
-
- /* ...and reference the _parent field of this record. */
- gnu_field_list
- = create_field_decl (get_identifier
- (Get_Name_String (Name_uParent)),
- gnu_parent, gnu_type, 0,
- has_rep ? TYPE_SIZE (gnu_parent) : 0,
- has_rep ? bitsize_zero_node : 0, 1);
- DECL_INTERNAL_P (gnu_field_list) = 1;
- TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
- }
-
- /* Make the fields for the discriminants and put them into the record
- unless it's an Unchecked_Union. */
- if (Has_Discriminants (gnat_entity))
- for (gnat_field = First_Stored_Discriminant (gnat_entity);
- Present (gnat_field);
- gnat_field = Next_Stored_Discriminant (gnat_field))
- {
- /* If this is a record extension and this discriminant
- is the renaming of another discriminant, we've already
- handled the discriminant above. */
- if (Present (Parent_Subtype (gnat_entity))
- && Present (Corresponding_Discriminant (gnat_field)))
- continue;
-
- gnu_field
- = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
-
- /* Make an expression using a PLACEHOLDER_EXPR from the
- FIELD_DECL node just created and link that with the
- corresponding GNAT defining identifier. Then add to the
- list of fields. */
- save_gnu_tree (gnat_field,
- build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
- build0 (PLACEHOLDER_EXPR,
- DECL_CONTEXT (gnu_field)),
- gnu_field, NULL_TREE),
- true);
-
- if (!Is_Unchecked_Union (gnat_entity))
- {
- TREE_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- }
- }
-
- /* Put the discriminants into the record (backwards), so we can
- know the appropriate discriminant to use for the names of the
- variants. */
- TYPE_FIELDS (gnu_type) = gnu_field_list;
-
- /* Add the listed fields into the record and finish it up. */
- components_to_record (gnu_type, Component_List (record_definition),
- gnu_field_list, packed, definition, NULL,
- false, all_rep, false,
- Is_Unchecked_Union (gnat_entity));
-
- /* We used to remove the associations of the discriminants and
- _Parent for validity checking, but we may need them if there's
- Freeze_Node for a subtype used in this record. */
- TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
- TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
-
- /* If it is a tagged record force the type to BLKmode to insure
- that these objects will always be placed in memory. Do the
- same thing for limited record types. */
- if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
- TYPE_MODE (gnu_type) = BLKmode;
-
- /* If this is a derived type, we must make the alias set of this type
- the same as that of the type we are derived from. We assume here
- that the other type is already frozen. */
- if (Etype (gnat_entity) != gnat_entity
- && !(Is_Private_Type (Etype (gnat_entity))
- && Full_View (Etype (gnat_entity)) == gnat_entity))
- copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
-
- /* Fill in locations of fields. */
- annotate_rep (gnat_entity, gnu_type);
-
- /* If there are any entities in the chain corresponding to
- components that we did not elaborate, ensure we elaborate their
- types if they are Itypes. */
- for (gnat_temp = First_Entity (gnat_entity);
- Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
- if ((Ekind (gnat_temp) == E_Component
- || Ekind (gnat_temp) == E_Discriminant)
- && Is_Itype (Etype (gnat_temp))
- && !present_gnu_tree (gnat_temp))
- gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
- }
- break;
-
- case E_Class_Wide_Subtype:
- /* If an equivalent type is present, that is what we should use.
- Otherwise, fall through to handle this like a record subtype
- since it may have constraints. */
- if (gnat_equiv_type != gnat_entity)
- {
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
- maybe_present = true;
- break;
- }
-
- /* ... fall through ... */
-
- case E_Record_Subtype:
-
- /* If Cloned_Subtype is Present it means this record subtype has
- identical layout to that type or subtype and we should use
- that GCC type for this one. The front end guarantees that
- the component list is shared. */
- if (Present (Cloned_Subtype (gnat_entity)))
- {
- gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
- NULL_TREE, 0);
- maybe_present = true;
- }
-
- /* Otherwise, first ensure the base type is elaborated. Then, if we are
- changing the type, make a new type with each field having the
- type of the field in the new subtype but having the position
- computed by transforming every discriminant reference according
- to the constraints. We don't see any difference between
- private and nonprivate type here since derivations from types should
- have been deferred until the completion of the private type. */
- else
- {
- Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
- tree gnu_base_type;
- tree gnu_orig_type;
-
- if (!definition)
- defer_incomplete_level++, this_deferred = true;
-
- /* Get the base type initially for its alignment and sizes. But
- if it is a padded type, we do all the other work with the
- unpadded type. */
- gnu_base_type = gnat_to_gnu_type (gnat_base_type);
-
- if (TREE_CODE (gnu_base_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_base_type))
- gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
- else
- gnu_type = gnu_orig_type = gnu_base_type;
-
- if (present_gnu_tree (gnat_entity))
- {
- maybe_present = true;
- break;
- }
-
- /* When the type has discriminants, and these discriminants
- affect the shape of what it built, factor them in.
-
- If we are making a subtype of an Unchecked_Union (must be an
- Itype), just return the type.
-
- We can't just use Is_Constrained because private subtypes without
- discriminants of full types with discriminants with default
- expressions are Is_Constrained but aren't constrained! */
-
- if (IN (Ekind (gnat_base_type), Record_Kind)
- && !Is_For_Access_Subtype (gnat_entity)
- && !Is_Unchecked_Union (gnat_base_type)
- && Is_Constrained (gnat_entity)
- && Stored_Constraint (gnat_entity) != No_Elist
- && Present (Discriminant_Constraint (gnat_entity)))
- {
- Entity_Id gnat_field;
- tree gnu_field_list = 0;
- tree gnu_pos_list
- = compute_field_positions (gnu_orig_type, NULL_TREE,
- size_zero_node, bitsize_zero_node,
- BIGGEST_ALIGNMENT);
- tree gnu_subst_list
- = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
- definition);
- tree gnu_temp;
-
- gnu_type = make_node (RECORD_TYPE);
- TYPE_NAME (gnu_type) = gnu_entity_id;
- TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
-
- /* Set the size, alignment and alias set of the new type to
- match that of the old one, doing required substitutions.
- We do it this early because we need the size of the new
- type below to discard old fields if necessary. */
- TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
- TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
- SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
- copy_alias_set (gnu_type, gnu_base_type);
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- TYPE_SIZE (gnu_type)
- = substitute_in_expr (TYPE_SIZE (gnu_type),
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp));
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- TYPE_SIZE_UNIT (gnu_type)
- = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp));
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- SET_TYPE_ADA_SIZE
- (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp)));
-
- for (gnat_field = First_Entity (gnat_entity);
- Present (gnat_field); gnat_field = Next_Entity (gnat_field))
- if ((Ekind (gnat_field) == E_Component
- || Ekind (gnat_field) == E_Discriminant)
- && (Underlying_Type (Scope (Original_Record_Component
- (gnat_field)))
- == gnat_base_type)
- && (No (Corresponding_Discriminant (gnat_field))
- || !Is_Tagged_Type (gnat_base_type)))
- {
- tree gnu_old_field
- = gnat_to_gnu_field_decl (Original_Record_Component
- (gnat_field));
- tree gnu_offset
- = TREE_VALUE (purpose_member (gnu_old_field,
- gnu_pos_list));
- tree gnu_pos = TREE_PURPOSE (gnu_offset);
- tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
- tree gnu_field_type
- = gnat_to_gnu_type (Etype (gnat_field));
- tree gnu_size = TYPE_SIZE (gnu_field_type);
- tree gnu_new_pos = NULL_TREE;
- unsigned int offset_align
- = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
- 1);
- tree gnu_field;
-
- /* If there was a component clause, the field types must be
- the same for the type and subtype, so copy the data from
- the old field to avoid recomputation here. Also if the
- field is justified modular and the optimization in
- gnat_to_gnu_field was applied. */
- if (Present (Component_Clause
- (Original_Record_Component (gnat_field)))
- || (TREE_CODE (gnu_field_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
- && TREE_TYPE (TYPE_FIELDS (gnu_field_type))
- == TREE_TYPE (gnu_old_field)))
- {
- gnu_size = DECL_SIZE (gnu_old_field);
- gnu_field_type = TREE_TYPE (gnu_old_field);
- }
-
- /* If the old field was packed and of constant size, we
- have to get the old size here, as it might differ from
- what the Etype conveys and the latter might overlap
- onto the following field. Try to arrange the type for
- possible better packing along the way. */
- else if (DECL_PACKED (gnu_old_field)
- && TREE_CODE (DECL_SIZE (gnu_old_field))
- == INTEGER_CST)
- {
- gnu_size = DECL_SIZE (gnu_old_field);
- if (TYPE_MODE (gnu_field_type) == BLKmode
- && TREE_CODE (gnu_field_type) == RECORD_TYPE
- && host_integerp (TYPE_SIZE (gnu_field_type), 1))
- gnu_field_type
- = make_packable_type (gnu_field_type, true);
- }
-
- if (CONTAINS_PLACEHOLDER_P (gnu_pos))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- gnu_pos = substitute_in_expr (gnu_pos,
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp));
-
- /* If the position is now a constant, we can set it as the
- position of the field when we make it. Otherwise, we need
- to deal with it specially below. */
- if (TREE_CONSTANT (gnu_pos))
- {
- gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
-
- /* Discard old fields that are outside the new type.
- This avoids confusing code scanning it to decide
- how to pass it to functions on some platforms. */
- if (TREE_CODE (gnu_new_pos) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
- && !integer_zerop (gnu_size)
- && !tree_int_cst_lt (gnu_new_pos,
- TYPE_SIZE (gnu_type)))
- continue;
- }
-
- gnu_field
- = create_field_decl
- (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
- DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
- !DECL_NONADDRESSABLE_P (gnu_old_field));
-
- if (!TREE_CONSTANT (gnu_pos))
- {
- normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
- DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
- DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
- SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
- DECL_SIZE (gnu_field) = gnu_size;
- DECL_SIZE_UNIT (gnu_field)
- = convert (sizetype,
- size_binop (CEIL_DIV_EXPR, gnu_size,
- bitsize_unit_node));
- layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
- }
-
- DECL_INTERNAL_P (gnu_field)
- = DECL_INTERNAL_P (gnu_old_field);
- SET_DECL_ORIGINAL_FIELD
- (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
- ? DECL_ORIGINAL_FIELD (gnu_old_field)
- : gnu_old_field));
- DECL_DISCRIMINANT_NUMBER (gnu_field)
- = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
- TREE_THIS_VOLATILE (gnu_field)
- = TREE_THIS_VOLATILE (gnu_old_field);
- TREE_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- save_gnu_tree (gnat_field, gnu_field, false);
- }
-
- /* Now go through the entities again looking for Itypes that
- we have not elaborated but should (e.g., Etypes of fields
- that have Original_Components). */
- for (gnat_field = First_Entity (gnat_entity);
- Present (gnat_field); gnat_field = Next_Entity (gnat_field))
- if ((Ekind (gnat_field) == E_Discriminant
- || Ekind (gnat_field) == E_Component)
- && !present_gnu_tree (Etype (gnat_field)))
- gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
-
- /* Do not finalize it since we're going to modify it below. */
- gnu_field_list = nreverse (gnu_field_list);
- finish_record_type (gnu_type, gnu_field_list, 2, true);
-
- /* Finalize size and mode. */
- TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
- TYPE_SIZE_UNIT (gnu_type)
- = variable_size (TYPE_SIZE_UNIT (gnu_type));
-
- compute_record_mode (gnu_type);
-
- /* Fill in locations of fields. */
- annotate_rep (gnat_entity, gnu_type);
-
- /* We've built a new type, make an XVS type to show what this
- is a subtype of. Some debuggers require the XVS type to be
- output first, so do it in that order. */
- if (debug_info_p)
- {
- tree gnu_subtype_marker = make_node (RECORD_TYPE);
- tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
-
- if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
- gnu_orig_name = DECL_NAME (gnu_orig_name);
-
- TYPE_NAME (gnu_subtype_marker)
- = create_concat_name (gnat_entity, "XVS");
- finish_record_type (gnu_subtype_marker,
- create_field_decl (gnu_orig_name,
- integer_type_node,
- gnu_subtype_marker,
- 0, NULL_TREE,
- NULL_TREE, 0),
- 0, false);
-
- add_parallel_type (TYPE_STUB_DECL (gnu_type),
- gnu_subtype_marker);
- }
-
- /* Now we can finalize it. */
- rest_of_record_type_compilation (gnu_type);
- }
-
- /* Otherwise, go down all the components in the new type and
- make them equivalent to those in the base type. */
- else
- for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
- gnat_temp = Next_Entity (gnat_temp))
- if ((Ekind (gnat_temp) == E_Discriminant
- && !Is_Unchecked_Union (gnat_base_type))
- || Ekind (gnat_temp) == E_Component)
- save_gnu_tree (gnat_temp,
- gnat_to_gnu_field_decl
- (Original_Record_Component (gnat_temp)), false);
- }
- break;
-
- case E_Access_Subprogram_Type:
- /* Use the special descriptor type for dispatch tables if needed,
- that is to say for the Prim_Ptr of a-tags.ads and its clones.
- Note that we are only required to do so for static tables in
- order to be compatible with the C++ ABI, but Ada 2005 allows
- to extend library level tagged types at the local level so
- we do it in the non-static case as well. */
- if (TARGET_VTABLE_USES_DESCRIPTORS
- && Is_Dispatch_Table_Entity (gnat_entity))
- {
- gnu_type = fdesc_type_node;
- gnu_size = TYPE_SIZE (gnu_type);
- break;
- }
-
- /* ... fall through ... */
-
- case E_Anonymous_Access_Subprogram_Type:
- /* If we are not defining this entity, and we have incomplete
- entities being processed above us, make a dummy type and
- fill it in later. */
- if (!definition && defer_incomplete_level != 0)
- {
- struct incomplete *p
- = (struct incomplete *) xmalloc (sizeof (struct incomplete));
-
- gnu_type
- = build_pointer_type
- (make_dummy_type (Directly_Designated_Type (gnat_entity)));
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- this_made_decl = true;
- gnu_type = TREE_TYPE (gnu_decl);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- saved = true;
-
- p->old_type = TREE_TYPE (gnu_type);
- p->full_type = Directly_Designated_Type (gnat_entity);
- p->next = defer_incomplete_list;
- defer_incomplete_list = p;
- break;
- }
-
- /* ... fall through ... */
-
- case E_Allocator_Type:
- case E_Access_Type:
- case E_Access_Attribute_Type:
- case E_Anonymous_Access_Type:
- case E_General_Access_Type:
- {
- Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
- Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
- bool is_from_limited_with
- = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
- && From_With_Type (gnat_desig_equiv));
-
- /* Get the "full view" of this entity. If this is an incomplete
- entity from a limited with, treat its non-limited view as the full
- view. Otherwise, if this is an incomplete or private type, use the
- full view. In the former case, we might point to a private type,
- in which case, we need its full view. Also, we want to look at the
- actual type used for the representation, so this takes a total of
- three steps. */
- Entity_Id gnat_desig_full_direct_first
- = (is_from_limited_with ? Non_Limited_View (gnat_desig_equiv)
- : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
- ? Full_View (gnat_desig_equiv) : Empty));
- Entity_Id gnat_desig_full_direct
- = ((is_from_limited_with
- && Present (gnat_desig_full_direct_first)
- && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
- ? Full_View (gnat_desig_full_direct_first)
- : gnat_desig_full_direct_first);
- Entity_Id gnat_desig_full
- = Gigi_Equivalent_Type (gnat_desig_full_direct);
-
- /* This the type actually used to represent the designated type,
- either gnat_desig_full or gnat_desig_equiv. */
- Entity_Id gnat_desig_rep;
-
- /* Nonzero if this is a pointer to an unconstrained array. */
- bool is_unconstrained_array;
-
- /* We want to know if we'll be seeing the freeze node for any
- incomplete type we may be pointing to. */
- bool in_main_unit
- = (Present (gnat_desig_full)
- ? In_Extended_Main_Code_Unit (gnat_desig_full)
- : In_Extended_Main_Code_Unit (gnat_desig_type));
-
- /* Nonzero if we make a dummy type here. */
- bool got_fat_p = false;
- /* Nonzero if the dummy is a fat pointer. */
- bool made_dummy = false;
- tree gnu_desig_type = NULL_TREE;
- enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
-
- if (!targetm.valid_pointer_mode (p_mode))
- p_mode = ptr_mode;
-
- /* If either the designated type or its full view is an unconstrained
- array subtype, replace it with the type it's a subtype of. This
- avoids problems with multiple copies of unconstrained array types.
- Likewise, if the designated type is a subtype of an incomplete
- record type, use the parent type to avoid order of elaboration
- issues. This can lose some code efficiency, but there is no
- alternative. */
- if (Ekind (gnat_desig_equiv) == E_Array_Subtype
- && ! Is_Constrained (gnat_desig_equiv))
- gnat_desig_equiv = Etype (gnat_desig_equiv);
- if (Present (gnat_desig_full)
- && ((Ekind (gnat_desig_full) == E_Array_Subtype
- && ! Is_Constrained (gnat_desig_full))
- || (Ekind (gnat_desig_full) == E_Record_Subtype
- && Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
- gnat_desig_full = Etype (gnat_desig_full);
-
- /* Now set the type that actually marks the representation of
- the designated type and also flag whether we have a unconstrained
- array. */
- gnat_desig_rep = gnat_desig_full ? gnat_desig_full : gnat_desig_equiv;
- is_unconstrained_array
- = (Is_Array_Type (gnat_desig_rep)
- && ! Is_Constrained (gnat_desig_rep));
-
- /* If we are pointing to an incomplete type whose completion is an
- unconstrained array, make a fat pointer type. The two types in our
- fields will be pointers to dummy nodes and will be replaced in
- update_pointer_to. Similarly, if the type itself is a dummy type or
- an unconstrained array. Also make a dummy TYPE_OBJECT_RECORD_TYPE
- in case we have any thin pointers to it. */
- if (is_unconstrained_array
- && (Present (gnat_desig_full)
- || (present_gnu_tree (gnat_desig_equiv)
- && TYPE_IS_DUMMY_P (TREE_TYPE
- (get_gnu_tree (gnat_desig_equiv))))
- || (No (gnat_desig_full) && ! in_main_unit
- && defer_incomplete_level != 0
- && ! present_gnu_tree (gnat_desig_equiv))
- || (in_main_unit && is_from_limited_with
- && Present (Freeze_Node (gnat_desig_rep)))))
- {
- tree gnu_old
- = (present_gnu_tree (gnat_desig_rep)
- ? TREE_TYPE (get_gnu_tree (gnat_desig_rep))
- : make_dummy_type (gnat_desig_rep));
- tree fields;
-
- /* Show the dummy we get will be a fat pointer. */
- got_fat_p = made_dummy = true;
-
- /* If the call above got something that has a pointer, that
- pointer is our type. This could have happened either
- because the type was elaborated or because somebody
- else executed the code below. */
- gnu_type = TYPE_POINTER_TO (gnu_old);
- if (!gnu_type)
- {
- tree gnu_template_type = make_node (ENUMERAL_TYPE);
- tree gnu_ptr_template = build_pointer_type (gnu_template_type);
- tree gnu_array_type = make_node (ENUMERAL_TYPE);
- tree gnu_ptr_array = build_pointer_type (gnu_array_type);
-
- TYPE_NAME (gnu_template_type)
- = concat_id_with_name (get_entity_name (gnat_desig_equiv),
- "XUB");
- TYPE_DUMMY_P (gnu_template_type) = 1;
-
- TYPE_NAME (gnu_array_type)
- = concat_id_with_name (get_entity_name (gnat_desig_equiv),
- "XUA");
- TYPE_DUMMY_P (gnu_array_type) = 1;
-
- gnu_type = make_node (RECORD_TYPE);
- SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
- TYPE_POINTER_TO (gnu_old) = gnu_type;
-
- Sloc_to_locus (Sloc (gnat_entity), &input_location);
- fields
- = chainon (chainon (NULL_TREE,
- create_field_decl
- (get_identifier ("P_ARRAY"),
- gnu_ptr_array,
- gnu_type, 0, 0, 0, 0)),
- create_field_decl (get_identifier ("P_BOUNDS"),
- gnu_ptr_template,
- gnu_type, 0, 0, 0, 0));
-
- /* Make sure we can place this into a register. */
- TYPE_ALIGN (gnu_type)
- = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
- TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
-
- /* Do not finalize this record type since the types of
- its fields are incomplete. */
- finish_record_type (gnu_type, fields, 0, true);
-
- TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
- TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
- = concat_id_with_name (get_entity_name (gnat_desig_equiv),
- "XUT");
- TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
- }
- }
-
- /* If we already know what the full type is, use it. */
- else if (Present (gnat_desig_full)
- && present_gnu_tree (gnat_desig_full))
- gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
-
- /* Get the type of the thing we are to point to and build a pointer
- to it. If it is a reference to an incomplete or private type with a
- full view that is a record, make a dummy type node and get the
- actual type later when we have verified it is safe. */
- else if ((! in_main_unit
- && ! present_gnu_tree (gnat_desig_equiv)
- && Present (gnat_desig_full)
- && ! present_gnu_tree (gnat_desig_full)
- && Is_Record_Type (gnat_desig_full))
- /* Likewise if we are pointing to a record or array and we
- are to defer elaborating incomplete types. We do this
- since this access type may be the full view of some
- private type. Note that the unconstrained array case is
- handled above. */
- || ((! in_main_unit || imported_p)
- && defer_incomplete_level != 0
- && ! present_gnu_tree (gnat_desig_equiv)
- && ((Is_Record_Type (gnat_desig_rep)
- || Is_Array_Type (gnat_desig_rep))))
- /* If this is a reference from a limited_with type back to our
- main unit and there's a Freeze_Node for it, either we have
- already processed the declaration and made the dummy type,
- in which case we just reuse the latter, or we have not yet,
- in which case we make the dummy type and it will be reused
- when the declaration is processed. In both cases, the
- pointer eventually created below will be automatically
- adjusted when the Freeze_Node is processed. Note that the
- unconstrained array case is handled above. */
- || (in_main_unit && is_from_limited_with
- && Present (Freeze_Node (gnat_desig_rep))))
- {
- gnu_desig_type = make_dummy_type (gnat_desig_equiv);
- made_dummy = true;
- }
-
- /* Otherwise handle the case of a pointer to itself. */
- else if (gnat_desig_equiv == gnat_entity)
- {
- gnu_type
- = build_pointer_type_for_mode (void_type_node, p_mode,
- No_Strict_Aliasing (gnat_entity));
- TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
- }
-
- /* If expansion is disabled, the equivalent type of a concurrent
- type is absent, so build a dummy pointer type. */
- else if (type_annotate_only && No (gnat_desig_equiv))
- gnu_type = ptr_void_type_node;
-
- /* Finally, handle the straightforward case where we can just
- elaborate our designated type and point to it. */
- else
- gnu_desig_type = gnat_to_gnu_type (gnat_desig_equiv);
-
- /* It is possible that a call to gnat_to_gnu_type above resolved our
- type. If so, just return it. */
- if (present_gnu_tree (gnat_entity))
- {
- maybe_present = true;
- break;
- }
-
- /* If we have a GCC type for the designated type, possibly modify it
- if we are pointing only to constant objects and then make a pointer
- to it. Don't do this for unconstrained arrays. */
- if (!gnu_type && gnu_desig_type)
- {
- if (Is_Access_Constant (gnat_entity)
- && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_desig_type
- = build_qualified_type
- (gnu_desig_type,
- TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
-
- /* Some extra processing is required if we are building a
- pointer to an incomplete type (in the GCC sense). We might
- have such a type if we just made a dummy, or directly out
- of the call to gnat_to_gnu_type above if we are processing
- an access type for a record component designating the
- record type itself. */
- if (TYPE_MODE (gnu_desig_type) == VOIDmode)
- {
- /* We must ensure that the pointer to variant we make will
- be processed by update_pointer_to when the initial type
- is completed. Pretend we made a dummy and let further
- processing act as usual. */
- made_dummy = true;
-
- /* We must ensure that update_pointer_to will not retrieve
- the dummy variant when building a properly qualified
- version of the complete type. We take advantage of the
- fact that get_qualified_type is requiring TYPE_NAMEs to
- match to influence build_qualified_type and then also
- update_pointer_to here. */
- TYPE_NAME (gnu_desig_type)
- = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
- }
- }
-
- gnu_type
- = build_pointer_type_for_mode (gnu_desig_type, p_mode,
- No_Strict_Aliasing (gnat_entity));
- }
-
- /* If we are not defining this object and we made a dummy pointer,
- save our current definition, evaluate the actual type, and replace
- the tentative type we made with the actual one. If we are to defer
- actually looking up the actual type, make an entry in the
- deferred list. If this is from a limited with, we have to defer
- to the end of the current spec in two cases: first if the
- designated type is in the current unit and second if the access
- type is. */
- if ((! in_main_unit || is_from_limited_with) && made_dummy)
- {
- tree gnu_old_type
- = TYPE_FAT_POINTER_P (gnu_type)
- ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
-
- if (esize == POINTER_SIZE
- && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
- gnu_type
- = build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE
- (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
-
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- this_made_decl = true;
- gnu_type = TREE_TYPE (gnu_decl);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- saved = true;
-
- if (defer_incomplete_level == 0
- && ! (is_from_limited_with
- && (in_main_unit
- || In_Extended_Main_Code_Unit (gnat_entity))))
- update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
- gnat_to_gnu_type (gnat_desig_equiv));
-
- /* Note that the call to gnat_to_gnu_type here might have
- updated gnu_old_type directly, in which case it is not a
- dummy type any more when we get into update_pointer_to.
-
- This may happen for instance when the designated type is a
- record type, because their elaboration starts with an
- initial node from make_dummy_type, which may yield the same
- node as the one we got.
-
- Besides, variants of this non-dummy type might have been
- created along the way. update_pointer_to is expected to
- properly take care of those situations. */
- else
- {
- struct incomplete *p
- = (struct incomplete *) xmalloc (sizeof
- (struct incomplete));
- struct incomplete **head
- = (is_from_limited_with
- && (in_main_unit
- || In_Extended_Main_Code_Unit (gnat_entity))
- ? &defer_limited_with : &defer_incomplete_list);
-
- p->old_type = gnu_old_type;
- p->full_type = gnat_desig_equiv;
- p->next = *head;
- *head = p;
- }
- }
- }
- break;
-
- case E_Access_Protected_Subprogram_Type:
- case E_Anonymous_Access_Protected_Subprogram_Type:
- if (type_annotate_only && No (gnat_equiv_type))
- gnu_type = ptr_void_type_node;
- else
- {
- /* The runtime representation is the equivalent type. */
- gnu_type = gnat_to_gnu_type (gnat_equiv_type);
- maybe_present = 1;
- }
-
- if (Is_Itype (Directly_Designated_Type (gnat_entity))
- && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
- && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
- && !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
- gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
- NULL_TREE, 0);
-
- break;
-
- case E_Access_Subtype:
-
- /* We treat this as identical to its base type; any constraint is
- meaningful only to the front end.
-
- The designated type must be elaborated as well, if it does
- not have its own freeze node. Designated (sub)types created
- for constrained components of records with discriminants are
- not frozen by the front end and thus not elaborated by gigi,
- because their use may appear before the base type is frozen,
- and because it is not clear that they are needed anywhere in
- Gigi. With the current model, there is no correct place where
- they could be elaborated. */
-
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
- if (Is_Itype (Directly_Designated_Type (gnat_entity))
- && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
- && Is_Frozen (Directly_Designated_Type (gnat_entity))
- && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
- {
- /* If we are not defining this entity, and we have incomplete
- entities being processed above us, make a dummy type and
- elaborate it later. */
- if (!definition && defer_incomplete_level != 0)
- {
- struct incomplete *p
- = (struct incomplete *) xmalloc (sizeof (struct incomplete));
- tree gnu_ptr_type
- = build_pointer_type
- (make_dummy_type (Directly_Designated_Type (gnat_entity)));
-
- p->old_type = TREE_TYPE (gnu_ptr_type);
- p->full_type = Directly_Designated_Type (gnat_entity);
- p->next = defer_incomplete_list;
- defer_incomplete_list = p;
- }
- else if (!IN (Ekind (Base_Type
- (Directly_Designated_Type (gnat_entity))),
- Incomplete_Or_Private_Kind))
- gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
- NULL_TREE, 0);
- }
-
- maybe_present = true;
- break;
-
- /* Subprogram Entities
-
- The following access functions are defined for subprograms (functions
- or procedures):
-
- First_Formal The first formal parameter.
- Is_Imported Indicates that the subprogram has appeared in
- an INTERFACE or IMPORT pragma. For now we
- assume that the external language is C.
- Is_Exported Likewise but for an EXPORT pragma.
- Is_Inlined True if the subprogram is to be inlined.
-
- In addition for function subprograms we have:
-
- Etype Return type of the function.
-
- Each parameter is first checked by calling must_pass_by_ref on its
- type to determine if it is passed by reference. For parameters which
- are copied in, if they are Ada In Out or Out parameters, their return
- value becomes part of a record which becomes the return type of the
- function (C function - note that this applies only to Ada procedures
- so there is no Ada return type). Additional code to store back the
- parameters will be generated on the caller side. This transformation
- is done here, not in the front-end.
-
- The intended result of the transformation can be seen from the
- equivalent source rewritings that follow:
-
- struct temp {int a,b};
- procedure P (A,B: In Out ...) is temp P (int A,B)
- begin {
- .. ..
- end P; return {A,B};
- }
-
- temp t;
- P(X,Y); t = P(X,Y);
- X = t.a , Y = t.b;
-
- For subprogram types we need to perform mainly the same conversions to
- GCC form that are needed for procedures and function declarations. The
- only difference is that at the end, we make a type declaration instead
- of a function declaration. */
-
- case E_Subprogram_Type:
- case E_Function:
- case E_Procedure:
- {
- /* The first GCC parameter declaration (a PARM_DECL node). The
- PARM_DECL nodes are chained through the TREE_CHAIN field, so this
- actually is the head of this parameter list. */
- tree gnu_param_list = NULL_TREE;
- /* Likewise for the stub associated with an exported procedure. */
- tree gnu_stub_param_list = NULL_TREE;
- /* The type returned by a function. If the subprogram is a procedure
- this type should be void_type_node. */
- tree gnu_return_type = void_type_node;
- /* List of fields in return type of procedure with copy-in copy-out
- parameters. */
- tree gnu_field_list = NULL_TREE;
- /* Non-null for subprograms containing parameters passed by copy-in
- copy-out (Ada In Out or Out parameters not passed by reference),
- in which case it is the list of nodes used to specify the values of
- the in out/out parameters that are returned as a record upon
- procedure return. The TREE_PURPOSE of an element of this list is
- a field of the record and the TREE_VALUE is the PARM_DECL
- corresponding to that field. This list will be saved in the
- TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
- tree gnu_return_list = NULL_TREE;
- /* If an import pragma asks to map this subprogram to a GCC builtin,
- this is the builtin DECL node. */
- tree gnu_builtin_decl = NULL_TREE;
- /* For the stub associated with an exported procedure. */
- tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE;
- tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
- Entity_Id gnat_param;
- bool inline_flag = Is_Inlined (gnat_entity);
- bool public_flag = Is_Public (gnat_entity) || imported_p;
- bool extern_flag
- = (Is_Public (gnat_entity) && !definition) || imported_p;
- bool pure_flag = Is_Pure (gnat_entity);
- bool volatile_flag = No_Return (gnat_entity);
- bool returns_by_ref = false;
- bool returns_unconstrained = false;
- bool returns_by_target_ptr = false;
- bool has_copy_in_out = false;
- bool has_stub = false;
- int parmnum;
-
- if (kind == E_Subprogram_Type && !definition)
- /* A parameter may refer to this type, so defer completion
- of any incomplete types. */
- defer_incomplete_level++, this_deferred = true;
-
- /* If the subprogram has an alias, it is probably inherited, so
- we can use the original one. If the original "subprogram"
- is actually an enumeration literal, it may be the first use
- of its type, so we must elaborate that type now. */
- if (Present (Alias (gnat_entity)))
- {
- if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
- gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
-
- gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
- gnu_expr, 0);
-
- /* Elaborate any Itypes in the parameters of this entity. */
- for (gnat_temp = First_Formal_With_Extras (gnat_entity);
- Present (gnat_temp);
- gnat_temp = Next_Formal_With_Extras (gnat_temp))
- if (Is_Itype (Etype (gnat_temp)))
- gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
-
- break;
- }
-
- /* If this subprogram is expectedly bound to a GCC builtin, fetch the
- corresponding DECL node.
-
- We still want the parameter associations to take place because the
- proper generation of calls depends on it (a GNAT parameter without
- a corresponding GCC tree has a very specific meaning), so we don't
- just break here. */
- if (Convention (gnat_entity) == Convention_Intrinsic)
- gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
-
- /* ??? What if we don't find the builtin node above ? warn ? err ?
- In the current state we neither warn nor err, and calls will just
- be handled as for regular subprograms. */
-
- if (kind == E_Function || kind == E_Subprogram_Type)
- gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
-
- /* If this function returns by reference, make the actual
- return type of this function the pointer and mark the decl. */
- if (Returns_By_Ref (gnat_entity))
- {
- returns_by_ref = true;
- gnu_return_type = build_pointer_type (gnu_return_type);
- }
-
- /* If the Mechanism is By_Reference, ensure the return type uses
- the machine's by-reference mechanism, which may not the same
- as above (e.g., it might be by passing a fake parameter). */
- else if (kind == E_Function
- && Mechanism (gnat_entity) == By_Reference)
- {
- TREE_ADDRESSABLE (gnu_return_type) = 1;
-
- /* We expect this bit to be reset by gigi shortly, so can avoid a
- type node copy here. This actually also prevents troubles with
- the generation of debug information for the function, because
- we might have issued such info for this type already, and would
- be attaching a distinct type node to the function if we made a
- copy here. */
- }
-
- /* If we are supposed to return an unconstrained array,
- actually return a fat pointer and make a note of that. Return
- a pointer to an unconstrained record of variable size. */
- else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_return_type = TREE_TYPE (gnu_return_type);
- returns_unconstrained = true;
- }
-
- /* If the type requires a transient scope, the result is allocated
- on the secondary stack, so the result type of the function is
- just a pointer. */
- else if (Requires_Transient_Scope (Etype (gnat_entity)))
- {
- gnu_return_type = build_pointer_type (gnu_return_type);
- returns_unconstrained = true;
- }
-
- /* If the type is a padded type and the underlying type would not
- be passed by reference or this function has a foreign convention,
- return the underlying type. */
- else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_return_type)
- && (!default_pass_by_ref (TREE_TYPE
- (TYPE_FIELDS (gnu_return_type)))
- || Has_Foreign_Convention (gnat_entity)))
- gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
-
- /* If the return type has a non-constant size, we convert the function
- into a procedure and its caller will pass a pointer to an object as
- the first parameter when we call the function. This can happen for
- an unconstrained type with a maximum size or a constrained type with
- a size not known at compile time. */
- if (TYPE_SIZE_UNIT (gnu_return_type)
- && !TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type)))
- {
- returns_by_target_ptr = true;
- gnu_param_list
- = create_param_decl (get_identifier ("TARGET"),
- build_reference_type (gnu_return_type),
- true);
- gnu_return_type = void_type_node;
- }
-
- /* If the return type has a size that overflows, we cannot have
- a function that returns that type. This usage doesn't make
- sense anyway, so give an error here. */
- if (TYPE_SIZE_UNIT (gnu_return_type)
- && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
- && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
- {
- post_error ("cannot return type whose size overflows",
- gnat_entity);
- gnu_return_type = copy_node (gnu_return_type);
- TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
- TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
- TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
- TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
- }
-
- /* Look at all our parameters and get the type of
- each. While doing this, build a copy-out structure if
- we need one. */
-
- /* Loop over the parameters and get their associated GCC tree.
- While doing this, build a copy-out structure if we need one. */
- for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
- Present (gnat_param);
- gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
- {
- tree gnu_param_name = get_entity_name (gnat_param);
- tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
- tree gnu_param, gnu_field;
- bool copy_in_copy_out = false;
- Mechanism_Type mech = Mechanism (gnat_param);
-
- /* Builtins are expanded inline and there is no real call sequence
- involved. So the type expected by the underlying expander is
- always the type of each argument "as is". */
- if (gnu_builtin_decl)
- mech = By_Copy;
- /* Handle the first parameter of a valued procedure specially. */
- else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
- mech = By_Copy_Return;
- /* Otherwise, see if a Mechanism was supplied that forced this
- parameter to be passed one way or another. */
- else if (mech == Default
- || mech == By_Copy || mech == By_Reference)
- ;
- else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
- mech = By_Descriptor;
- else if (mech > 0)
- {
- if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
- || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
- || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
- mech))
- mech = By_Reference;
- else
- mech = By_Copy;
- }
- else
- {
- post_error ("unsupported mechanism for&", gnat_param);
- mech = Default;
- }
-
- gnu_param
- = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
- Has_Foreign_Convention (gnat_entity),
- ©_in_copy_out);
-
- /* We are returned either a PARM_DECL or a type if no parameter
- needs to be passed; in either case, adjust the type. */
- if (DECL_P (gnu_param))
- gnu_param_type = TREE_TYPE (gnu_param);
- else
- {
- gnu_param_type = gnu_param;
- gnu_param = NULL_TREE;
- }
-
- if (gnu_param)
- {
- /* If it's an exported subprogram, we build a parameter list
- in parallel, in case we need to emit a stub for it. */
- if (Is_Exported (gnat_entity))
- {
- gnu_stub_param_list
- = chainon (gnu_param, gnu_stub_param_list);
- /* Change By_Descriptor parameter to By_Reference for
- the internal version of an exported subprogram. */
- if (mech == By_Descriptor)
- {
- gnu_param
- = gnat_to_gnu_param (gnat_param, By_Reference,
- gnat_entity, false,
- ©_in_copy_out);
- has_stub = true;
- }
- else
- gnu_param = copy_node (gnu_param);
- }
-
- gnu_param_list = chainon (gnu_param, gnu_param_list);
- Sloc_to_locus (Sloc (gnat_param),
- &DECL_SOURCE_LOCATION (gnu_param));
- save_gnu_tree (gnat_param, gnu_param, false);
-
- /* If a parameter is a pointer, this function may modify
- memory through it and thus shouldn't be considered
- a pure function. Also, the memory may be modified
- between two calls, so they can't be CSE'ed. The latter
- case also handles by-ref parameters. */
- if (POINTER_TYPE_P (gnu_param_type)
- || TYPE_FAT_POINTER_P (gnu_param_type))
- pure_flag = false;
- }
-
- if (copy_in_copy_out)
- {
- if (!has_copy_in_out)
- {
- gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
- gnu_return_type = make_node (RECORD_TYPE);
- TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
- has_copy_in_out = true;
- }
-
- gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
- gnu_return_type, 0, 0, 0, 0);
- Sloc_to_locus (Sloc (gnat_param),
- &DECL_SOURCE_LOCATION (gnu_field));
- TREE_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- gnu_return_list = tree_cons (gnu_field, gnu_param,
- gnu_return_list);
- }
- }
-
- /* Do not compute record for out parameters if subprogram is
- stubbed since structures are incomplete for the back-end. */
- if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
- finish_record_type (gnu_return_type, nreverse (gnu_field_list),
- 0, false);
-
- /* If we have a CICO list but it has only one entry, we convert
- this function into a function that simply returns that one
- object. */
- if (list_length (gnu_return_list) == 1)
- gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
-
- if (Has_Stdcall_Convention (gnat_entity))
- prepend_one_attribute_to
- (&attr_list, ATTR_MACHINE_ATTRIBUTE,
- get_identifier ("stdcall"), NULL_TREE,
- gnat_entity);
-
- /* If we are on a target where stack realignment is needed for 'main'
- to honor GCC's implicit expectations (stack alignment greater than
- what the base ABI guarantees), ensure we do the same for foreign
- convention subprograms as they might be used as callbacks from code
- breaking such expectations. Note that this applies to task entry
- points in particular. */
- if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
- && Has_Foreign_Convention (gnat_entity))
- prepend_one_attribute_to
- (&attr_list, ATTR_MACHINE_ATTRIBUTE,
- get_identifier ("force_align_arg_pointer"), NULL_TREE,
- gnat_entity);
-
- /* The lists have been built in reverse. */
- gnu_param_list = nreverse (gnu_param_list);
- if (has_stub)
- gnu_stub_param_list = nreverse (gnu_stub_param_list);
- gnu_return_list = nreverse (gnu_return_list);
-
- if (Ekind (gnat_entity) == E_Function)
- Set_Mechanism (gnat_entity,
- (returns_by_ref || returns_unconstrained
- ? By_Reference : By_Copy));
- gnu_type
- = create_subprog_type (gnu_return_type, gnu_param_list,
- gnu_return_list, returns_unconstrained,
- returns_by_ref, returns_by_target_ptr);
-
- if (has_stub)
- gnu_stub_type
- = create_subprog_type (gnu_return_type, gnu_stub_param_list,
- gnu_return_list, returns_unconstrained,
- returns_by_ref, returns_by_target_ptr);
-
- /* A subprogram (something that doesn't return anything) shouldn't
- be considered Pure since there would be no reason for such a
- subprogram. Note that procedures with Out (or In Out) parameters
- have already been converted into a function with a return type. */
- if (TREE_CODE (gnu_return_type) == VOID_TYPE)
- pure_flag = false;
-
- /* The semantics of "pure" in Ada essentially matches that of "const"
- in the back-end. In particular, both properties are orthogonal to
- the "nothrow" property. But this is true only if the EH circuitry
- is explicit in the internal representation of the back-end. If we
- are to completely hide the EH circuitry from it, we need to declare
- that calls to pure Ada subprograms that can throw have side effects
- since they can trigger an "abnormal" transfer of control flow; thus
- they can be neither "const" nor "pure" in the back-end sense. */
- gnu_type
- = build_qualified_type (gnu_type,
- TYPE_QUALS (gnu_type)
- | (Exception_Mechanism == Back_End_Exceptions
- ? TYPE_QUAL_CONST * pure_flag : 0)
- | (TYPE_QUAL_VOLATILE * volatile_flag));
-
- Sloc_to_locus (Sloc (gnat_entity), &input_location);
-
- if (has_stub)
- gnu_stub_type
- = build_qualified_type (gnu_stub_type,
- TYPE_QUALS (gnu_stub_type)
- | (Exception_Mechanism == Back_End_Exceptions
- ? TYPE_QUAL_CONST * pure_flag : 0)
- | (TYPE_QUAL_VOLATILE * volatile_flag));
-
- /* If we have a builtin decl for that function, check the signatures
- compatibilities. If the signatures are compatible, use the builtin
- decl. If they are not, we expect the checker predicate to have
- posted the appropriate errors, and just continue with what we have
- so far. */
- if (gnu_builtin_decl)
- {
- tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
-
- if (compatible_signatures_p (gnu_type, gnu_builtin_type))
- {
- gnu_decl = gnu_builtin_decl;
- gnu_type = gnu_builtin_type;
- break;
- }
- }
-
- /* If there was no specified Interface_Name and the external and
- internal names of the subprogram are the same, only use the
- internal name to allow disambiguation of nested subprograms. */
- if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
- gnu_ext_name = NULL_TREE;
-
- /* If we are defining the subprogram and it has an Address clause
- we must get the address expression from the saved GCC tree for the
- subprogram if it has a Freeze_Node. Otherwise, we elaborate
- the address expression here since the front-end has guaranteed
- in that case that the elaboration has no effects. If there is
- an Address clause and we are not defining the object, just
- make it a constant. */
- if (Present (Address_Clause (gnat_entity)))
- {
- tree gnu_address = NULL_TREE;
-
- if (definition)
- gnu_address
- = (present_gnu_tree (gnat_entity)
- ? get_gnu_tree (gnat_entity)
- : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
-
- save_gnu_tree (gnat_entity, NULL_TREE, false);
-
- /* Convert the type of the object to a reference type that can
- alias everything as per 13.3(19). */
- gnu_type
- = build_reference_type_for_mode (gnu_type, ptr_mode, true);
- if (gnu_address)
- gnu_address = convert (gnu_type, gnu_address);
-
- gnu_decl
- = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
- gnu_address, false, Is_Public (gnat_entity),
- extern_flag, false, NULL, gnat_entity);
- DECL_BY_REF_P (gnu_decl) = 1;
- }
-
- else if (kind == E_Subprogram_Type)
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- else
- {
- if (has_stub)
- {
- gnu_stub_name = gnu_ext_name;
- gnu_ext_name = create_concat_name (gnat_entity, "internal");
- public_flag = false;
- }
-
- gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
- gnu_type, gnu_param_list,
- inline_flag, public_flag,
- extern_flag, attr_list,
- gnat_entity);
- if (has_stub)
- {
- tree gnu_stub_decl
- = create_subprog_decl (gnu_entity_id, gnu_stub_name,
- gnu_stub_type, gnu_stub_param_list,
- inline_flag, true,
- extern_flag, attr_list,
- gnat_entity);
- SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
- }
-
- /* This is unrelated to the stub built right above. */
- DECL_STUBBED_P (gnu_decl)
- = Convention (gnat_entity) == Convention_Stubbed;
- }
- }
- break;
-
- case E_Incomplete_Type:
- case E_Incomplete_Subtype:
- case E_Private_Type:
- case E_Private_Subtype:
- case E_Limited_Private_Type:
- case E_Limited_Private_Subtype:
- case E_Record_Type_With_Private:
- case E_Record_Subtype_With_Private:
- {
- /* Get the "full view" of this entity. If this is an incomplete
- entity from a limited with, treat its non-limited view as the
- full view. Otherwise, use either the full view or the underlying
- full view, whichever is present. This is used in all the tests
- below. */
- Entity_Id full_view
- = (IN (Ekind (gnat_entity), Incomplete_Kind)
- && From_With_Type (gnat_entity))
- ? Non_Limited_View (gnat_entity)
- : Present (Full_View (gnat_entity))
- ? Full_View (gnat_entity)
- : Underlying_Full_View (gnat_entity);
-
- /* If this is an incomplete type with no full view, it must be a Taft
- Amendment type, in which case we return a dummy type. Otherwise,
- just get the type from its Etype. */
- if (No (full_view))
- {
- if (kind == E_Incomplete_Type)
- gnu_type = make_dummy_type (gnat_entity);
- else
- {
- gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
- NULL_TREE, 0);
- maybe_present = true;
- }
- break;
- }
-
- /* If we already made a type for the full view, reuse it. */
- else if (present_gnu_tree (full_view))
- {
- gnu_decl = get_gnu_tree (full_view);
- break;
- }
-
- /* Otherwise, if we are not defining the type now, get the type
- from the full view. But always get the type from the full view
- for define on use types, since otherwise we won't see them! */
- else if (!definition
- || (Is_Itype (full_view)
- && No (Freeze_Node (gnat_entity)))
- || (Is_Itype (gnat_entity)
- && No (Freeze_Node (full_view))))
- {
- gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
- maybe_present = true;
- break;
- }
-
- /* For incomplete types, make a dummy type entry which will be
- replaced later. */
- gnu_type = make_dummy_type (gnat_entity);
-
- /* Save this type as the full declaration's type so we can do any
- needed updates when we see it. */
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- save_gnu_tree (full_view, gnu_decl, 0);
- break;
- }
-
- /* Simple class_wide types are always viewed as their root_type
- by Gigi unless an Equivalent_Type is specified. */
- case E_Class_Wide_Type:
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
- maybe_present = true;
- break;
-
- case E_Task_Type:
- case E_Task_Subtype:
- case E_Protected_Type:
- case E_Protected_Subtype:
- if (type_annotate_only && No (gnat_equiv_type))
- gnu_type = void_type_node;
- else
- gnu_type = gnat_to_gnu_type (gnat_equiv_type);
-
- maybe_present = true;
- break;
-
- case E_Label:
- gnu_decl = create_label_decl (gnu_entity_id);
- break;
-
- case E_Block:
- case E_Loop:
- /* Nothing at all to do here, so just return an ERROR_MARK and claim
- we've already saved it, so we don't try to. */
- gnu_decl = error_mark_node;
- saved = true;
- break;
-
- default:
- gcc_unreachable ();
- }
-
- /* If we had a case where we evaluated another type and it might have
- defined this one, handle it here. */
- if (maybe_present && present_gnu_tree (gnat_entity))
- {
- gnu_decl = get_gnu_tree (gnat_entity);
- saved = true;
- }
-
- /* If we are processing a type and there is either no decl for it or
- we just made one, do some common processing for the type, such as
- handling alignment and possible padding. */
-
- if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
- {
- if (Is_Tagged_Type (gnat_entity)
- || Is_Class_Wide_Equivalent_Type (gnat_entity))
- TYPE_ALIGN_OK (gnu_type) = 1;
-
- if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
- TYPE_BY_REFERENCE_P (gnu_type) = 1;
-
- /* ??? Don't set the size for a String_Literal since it is either
- confirming or we don't handle it properly (if the low bound is
- non-constant). */
- if (!gnu_size && kind != E_String_Literal_Subtype)
- gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
- TYPE_DECL, false,
- Has_Size_Clause (gnat_entity));
-
- /* If a size was specified, see if we can make a new type of that size
- by rearranging the type, for example from a fat to a thin pointer. */
- if (gnu_size)
- {
- gnu_type
- = make_type_from_size (gnu_type, gnu_size,
- Has_Biased_Representation (gnat_entity));
-
- if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
- && operand_equal_p (rm_size (gnu_type), gnu_size, 0))
- gnu_size = 0;
- }
-
- /* If the alignment hasn't already been processed and this is
- not an unconstrained array, see if an alignment is specified.
- If not, we pick a default alignment for atomic objects. */
- if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
- ;
- else if (Known_Alignment (gnat_entity))
- {
- align = validate_alignment (Alignment (gnat_entity), gnat_entity,
- TYPE_ALIGN (gnu_type));
-
- /* Warn on suspiciously large alignments. This should catch
- errors about the (alignment,byte)/(size,bit) discrepancy. */
- if (align > BIGGEST_ALIGNMENT && Has_Alignment_Clause (gnat_entity))
- {
- tree size;
-
- /* If a size was specified, take it into account. Otherwise
- use the RM size for records as the type size has already
- been adjusted to the alignment. */
- if (gnu_size)
- size = gnu_size;
- else if ((TREE_CODE (gnu_type) == RECORD_TYPE
- || TREE_CODE (gnu_type) == UNION_TYPE
- || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (gnu_type))
- size = rm_size (gnu_type);
- else
- size = TYPE_SIZE (gnu_type);
-
- /* Consider an alignment as suspicious if the alignment/size
- ratio is greater or equal to the byte/bit ratio. */
- if (host_integerp (size, 1)
- && align >= TREE_INT_CST_LOW (size) * BITS_PER_UNIT)
- post_error_ne ("?suspiciously large alignment specified for&",
- Expression (Alignment_Clause (gnat_entity)),
- gnat_entity);
- }
- }
- else if (Is_Atomic (gnat_entity) && !gnu_size
- && host_integerp (TYPE_SIZE (gnu_type), 1)
- && integer_pow2p (TYPE_SIZE (gnu_type)))
- align = MIN (BIGGEST_ALIGNMENT,
- tree_low_cst (TYPE_SIZE (gnu_type), 1));
- else if (Is_Atomic (gnat_entity) && gnu_size
- && host_integerp (gnu_size, 1)
- && integer_pow2p (gnu_size))
- align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
-
- /* See if we need to pad the type. If we did, and made a record,
- the name of the new type may be changed. So get it back for
- us when we make the new TYPE_DECL below. */
- if (gnu_size || align > 0)
- gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- "PAD", true, definition, false);
-
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type))
- {
- gnu_entity_id = TYPE_NAME (gnu_type);
- if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
- gnu_entity_id = DECL_NAME (gnu_entity_id);
- }
-
- set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
-
- /* If we are at global level, GCC will have applied variable_size to
- the type, but that won't have done anything. So, if it's not
- a constant or self-referential, call elaborate_expression_1 to
- make a variable for the size rather than calculating it each time.
- Handle both the RM size and the actual size. */
- if (global_bindings_p ()
- && TYPE_SIZE (gnu_type)
- && !TREE_CONSTANT (TYPE_SIZE (gnu_type))
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
- {
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && operand_equal_p (TYPE_ADA_SIZE (gnu_type),
- TYPE_SIZE (gnu_type), 0))
- {
- TYPE_SIZE (gnu_type)
- = elaborate_expression_1 (gnat_entity, gnat_entity,
- TYPE_SIZE (gnu_type),
- get_identifier ("SIZE"),
- definition, 0);
- SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
- }
- else
- {
- TYPE_SIZE (gnu_type)
- = elaborate_expression_1 (gnat_entity, gnat_entity,
- TYPE_SIZE (gnu_type),
- get_identifier ("SIZE"),
- definition, 0);
-
- /* ??? For now, store the size as a multiple of the alignment
- in bytes so that we can see the alignment from the tree. */
- TYPE_SIZE_UNIT (gnu_type)
- = build_binary_op
- (MULT_EXPR, sizetype,
- elaborate_expression_1
- (gnat_entity, gnat_entity,
- build_binary_op (EXACT_DIV_EXPR, sizetype,
- TYPE_SIZE_UNIT (gnu_type),
- size_int (TYPE_ALIGN (gnu_type)
- / BITS_PER_UNIT)),
- get_identifier ("SIZE_A_UNIT"),
- definition, 0),
- size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
-
- if (TREE_CODE (gnu_type) == RECORD_TYPE)
- SET_TYPE_ADA_SIZE
- (gnu_type,
- elaborate_expression_1 (gnat_entity,
- gnat_entity,
- TYPE_ADA_SIZE (gnu_type),
- get_identifier ("RM_SIZE"),
- definition, 0));
- }
- }
-
- /* If this is a record type or subtype, call elaborate_expression_1 on
- any field position. Do this for both global and local types.
- Skip any fields that we haven't made trees for to avoid problems with
- class wide types. */
- if (IN (kind, Record_Kind))
- for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
- gnat_temp = Next_Entity (gnat_temp))
- if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
- {
- tree gnu_field = get_gnu_tree (gnat_temp);
-
- /* ??? Unfortunately, GCC needs to be able to prove the
- alignment of this offset and if it's a variable, it can't.
- In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
- right now, we have to put in an explicit multiply and
- divide by that value. */
- if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
- {
- DECL_FIELD_OFFSET (gnu_field)
- = build_binary_op
- (MULT_EXPR, sizetype,
- elaborate_expression_1
- (gnat_temp, gnat_temp,
- build_binary_op (EXACT_DIV_EXPR, sizetype,
- DECL_FIELD_OFFSET (gnu_field),
- size_int (DECL_OFFSET_ALIGN (gnu_field)
- / BITS_PER_UNIT)),
- get_identifier ("OFFSET"),
- definition, 0),
- size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
-
- /* ??? The context of gnu_field is not necessarily gnu_type so
- the MULT_EXPR node built above may not be marked by the call
- to create_type_decl below. */
- if (global_bindings_p ())
- mark_visited (&DECL_FIELD_OFFSET (gnu_field));
- }
- }
-
- gnu_type = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | (TYPE_QUAL_VOLATILE
- * Treat_As_Volatile (gnat_entity))));
-
- if (Is_Atomic (gnat_entity))
- check_ok_for_atomic (gnu_type, gnat_entity, false);
-
- if (Present (Alignment_Clause (gnat_entity)))
- TYPE_USER_ALIGN (gnu_type) = 1;
-
- if (Universal_Aliasing (gnat_entity))
- TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
-
- if (!gnu_decl)
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- else
- TREE_TYPE (gnu_decl) = gnu_type;
- }
-
- if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
- {
- gnu_type = TREE_TYPE (gnu_decl);
-
- /* Back-annotate the Alignment of the type if not already in the
- tree. Likewise for sizes. */
- if (Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity,
- UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
-
- if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
- {
- /* If the size is self-referential, we annotate the maximum
- value of that size. */
- tree gnu_size = TYPE_SIZE (gnu_type);
-
- if (CONTAINS_PLACEHOLDER_P (gnu_size))
- gnu_size = max_size (gnu_size, true);
-
- Set_Esize (gnat_entity, annotate_value (gnu_size));
-
- if (type_annotate_only && Is_Tagged_Type (gnat_entity))
- {
- /* In this mode the tag and the parent components are not
- generated by the front-end, so the sizes must be adjusted
- explicitly now. */
- int size_offset, new_size;
-
- if (Is_Derived_Type (gnat_entity))
- {
- size_offset
- = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
- Set_Alignment (gnat_entity,
- Alignment (Etype (Base_Type (gnat_entity))));
- }
- else
- size_offset = POINTER_SIZE;
-
- new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
- Set_Esize (gnat_entity,
- UI_From_Int (((new_size + (POINTER_SIZE - 1))
- / POINTER_SIZE) * POINTER_SIZE));
- Set_RM_Size (gnat_entity, Esize (gnat_entity));
- }
- }
-
- if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
- Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
- }
-
- if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
- DECL_ARTIFICIAL (gnu_decl) = 1;
-
- if (!debug_info_p && DECL_P (gnu_decl)
- && TREE_CODE (gnu_decl) != FUNCTION_DECL
- && No (Renamed_Object (gnat_entity)))
- DECL_IGNORED_P (gnu_decl) = 1;
-
- /* If we haven't already, associate the ..._DECL node that we just made with
- the input GNAT entity node. */
- if (!saved)
- save_gnu_tree (gnat_entity, gnu_decl, false);
-
- /* If this is an enumeral or floating-point type, we were not able to set
- the bounds since they refer to the type. These bounds are always static.
-
- For enumeration types, also write debugging information and declare the
- enumeration literal table, if needed. */
-
- if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
- || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
- {
- tree gnu_scalar_type = gnu_type;
-
- /* If this is a padded type, we need to use the underlying type. */
- if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_scalar_type))
- gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
-
- /* If this is a floating point type and we haven't set a floating
- point type yet, use this in the evaluation of the bounds. */
- if (!longest_float_type_node && kind == E_Floating_Point_Type)
- longest_float_type_node = gnu_type;
-
- TYPE_MIN_VALUE (gnu_scalar_type)
- = gnat_to_gnu (Type_Low_Bound (gnat_entity));
- TYPE_MAX_VALUE (gnu_scalar_type)
- = gnat_to_gnu (Type_High_Bound (gnat_entity));
-
- if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
- {
- /* Since this has both a typedef and a tag, avoid outputting
- the name twice. */
- DECL_ARTIFICIAL (gnu_decl) = 1;
- rest_of_type_decl_compilation (gnu_decl);
- }
- }
-
- /* If we deferred processing of incomplete types, re-enable it. If there
- were no other disables and we have some to process, do so. */
- if (this_deferred && --defer_incomplete_level == 0)
- {
- if (defer_incomplete_list)
- {
- struct incomplete *incp, *next;
-
- /* We are back to level 0 for the deferring of incomplete types.
- But processing these incomplete types below may itself require
- deferring, so preserve what we have and restart from scratch. */
- incp = defer_incomplete_list;
- defer_incomplete_list = NULL;
-
- /* For finalization, however, all types must be complete so we
- cannot do the same because deferred incomplete types may end up
- referencing each other. Process them all recursively first. */
- defer_finalize_level++;
-
- for (; incp; incp = next)
- {
- next = incp->next;
-
- if (incp->old_type)
- update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
- gnat_to_gnu_type (incp->full_type));
- free (incp);
- }
-
- defer_finalize_level--;
- }
-
- /* All the deferred incomplete types have been processed so we can
- now proceed with the finalization of the deferred types. */
- if (defer_finalize_level == 0 && defer_finalize_list)
- {
- unsigned int i;
- tree t;
-
- for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
- rest_of_type_decl_compilation_no_defer (t);
-
- VEC_free (tree, heap, defer_finalize_list);
- }
- }
-
- /* If we are not defining this type, see if it's in the incomplete list.
- If so, handle that list entry now. */
- else if (!definition)
- {
- struct incomplete *incp;
-
- for (incp = defer_incomplete_list; incp; incp = incp->next)
- if (incp->old_type && incp->full_type == gnat_entity)
- {
- update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
- TREE_TYPE (gnu_decl));
- incp->old_type = NULL_TREE;
- }
- }
-
- if (this_global)
- force_global--;
-
- if (Is_Packed_Array_Type (gnat_entity)
- && Is_Itype (Associated_Node_For_Itype (gnat_entity))
- && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
- && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
- gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
-
- return gnu_decl;
-}
-
-/* Similar, but if the returned value is a COMPONENT_REF, return the
- FIELD_DECL. */
-
-tree
-gnat_to_gnu_field_decl (Entity_Id gnat_entity)
-{
- tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
-
- if (TREE_CODE (gnu_field) == COMPONENT_REF)
- gnu_field = TREE_OPERAND (gnu_field, 1);
-
- return gnu_field;
-}
-
-/* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
- Every TYPE_DECL generated for a type definition must be passed
- to this function once everything else has been done for it. */
-
-void
-rest_of_type_decl_compilation (tree decl)
-{
- /* We need to defer finalizing the type if incomplete types
- are being deferred or if they are being processed. */
- if (defer_incomplete_level || defer_finalize_level)
- VEC_safe_push (tree, heap, defer_finalize_list, decl);
- else
- rest_of_type_decl_compilation_no_defer (decl);
-}
-
-/* Same as above but without deferring the compilation. This
- function should not be invoked directly on a TYPE_DECL. */
-
-static void
-rest_of_type_decl_compilation_no_defer (tree decl)
-{
- const int toplev = global_bindings_p ();
- tree t = TREE_TYPE (decl);
-
- rest_of_decl_compilation (decl, toplev, 0);
-
- /* Now process all the variants. This is needed for STABS. */
- for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
- {
- if (t == TREE_TYPE (decl))
- continue;
-
- if (!TYPE_STUB_DECL (t))
- {
- TYPE_STUB_DECL (t) = build_decl (TYPE_DECL, DECL_NAME (decl), t);
- DECL_ARTIFICIAL (TYPE_STUB_DECL (t)) = 1;
- }
-
- rest_of_type_compilation (t, toplev);
- }
-}
-
-/* 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. */
-
-void
-finalize_from_with_types (void)
-{
- struct incomplete *incp = defer_limited_with;
- struct incomplete *next;
-
- defer_limited_with = 0;
- for (; incp; incp = next)
- {
- next = incp->next;
-
- if (incp->old_type != 0)
- update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
- gnat_to_gnu_type (incp->full_type));
- free (incp);
- }
-}
-
-/* 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. */
-
-Entity_Id
-Gigi_Equivalent_Type (Entity_Id gnat_entity)
-{
- Entity_Id gnat_equiv = gnat_entity;
-
- if (No (gnat_entity))
- return gnat_entity;
-
- switch (Ekind (gnat_entity))
- {
- case E_Class_Wide_Subtype:
- if (Present (Equivalent_Type (gnat_entity)))
- gnat_equiv = Equivalent_Type (gnat_entity);
- break;
-
- case E_Access_Protected_Subprogram_Type:
- case E_Anonymous_Access_Protected_Subprogram_Type:
- gnat_equiv = Equivalent_Type (gnat_entity);
- break;
-
- case E_Class_Wide_Type:
- gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
- ? Equivalent_Type (gnat_entity)
- : Root_Type (gnat_entity));
- break;
-
- case E_Task_Type:
- case E_Task_Subtype:
- case E_Protected_Type:
- case E_Protected_Subtype:
- gnat_equiv = Corresponding_Record_Type (gnat_entity);
- break;
-
- default:
- break;
- }
-
- gcc_assert (Present (gnat_equiv) || type_annotate_only);
- return gnat_equiv;
-}
-
-/* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
- using MECH as its passing mechanism, to be placed in the parameter
- list built for GNAT_SUBPROG. Assume a foreign convention for the
- latter if FOREIGN is true. Also set CICO to true if the parameter
- must use the copy-in copy-out implementation mechanism.
-
- The returned tree is a PARM_DECL, except for those cases where no
- parameter needs to be actually passed to the subprogram; the type
- of this "shadow" parameter is then returned instead. */
-
-static tree
-gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
- Entity_Id gnat_subprog, bool foreign, bool *cico)
-{
- tree gnu_param_name = get_entity_name (gnat_param);
- tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
- bool in_param = (Ekind (gnat_param) == E_In_Parameter);
- /* The parameter can be indirectly modified if its address is taken. */
- bool ro_param = in_param && !Address_Taken (gnat_param);
- bool by_return = false, by_component_ptr = false, by_ref = false;
- tree gnu_param;
-
- /* Copy-return is used only for the first parameter of a valued procedure.
- It's a copy mechanism for which a parameter is never allocated. */
- if (mech == By_Copy_Return)
- {
- gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
- mech = By_Copy;
- by_return = true;
- }
-
- /* If this is either a foreign function or if the underlying type won't
- be passed by reference, strip off possible padding type. */
- if (TREE_CODE (gnu_param_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_param_type))
- {
- tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
-
- if (mech == By_Reference
- || foreign
- || (!must_pass_by_ref (unpadded_type)
- && (mech == By_Copy || !default_pass_by_ref (unpadded_type))))
- gnu_param_type = unpadded_type;
- }
-
- /* If this is a read-only parameter, make a variant of the type that is
- read-only. ??? However, if this is an unconstrained array, that type
- can be very complex, so skip it for now. Likewise for any other
- self-referential type. */
- if (ro_param
- && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
- gnu_param_type = build_qualified_type (gnu_param_type,
- (TYPE_QUALS (gnu_param_type)
- | TYPE_QUAL_CONST));
-
- /* For foreign conventions, pass arrays as pointers to the element type.
- First check for unconstrained array and get the underlying array. */
- if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
- gnu_param_type
- = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
-
- /* VMS descriptors are themselves passed by reference. */
- if (mech == By_Descriptor)
- gnu_param_type
- = build_pointer_type (build_vms_descriptor (gnu_param_type,
- Mechanism (gnat_param),
- gnat_subprog));
-
- /* Arrays are passed as pointers to element type for foreign conventions. */
- else if (foreign
- && mech != By_Copy
- && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
- {
- /* Strip off any multi-dimensional entries, then strip
- off the last array to get the component type. */
- while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
- gnu_param_type = TREE_TYPE (gnu_param_type);
-
- by_component_ptr = true;
- gnu_param_type = TREE_TYPE (gnu_param_type);
-
- if (ro_param)
- gnu_param_type = build_qualified_type (gnu_param_type,
- (TYPE_QUALS (gnu_param_type)
- | TYPE_QUAL_CONST));
-
- gnu_param_type = build_pointer_type (gnu_param_type);
- }
-
- /* Fat pointers are passed as thin pointers for foreign conventions. */
- else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
- gnu_param_type
- = make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
-
- /* If we must pass or were requested to pass by reference, do so.
- If we were requested to pass by copy, do so.
- Otherwise, for foreign conventions, pass In Out or Out parameters
- or aggregates by reference. For COBOL and Fortran, pass all
- integer and FP types that way too. For Convention Ada, use
- the standard Ada default. */
- else if (must_pass_by_ref (gnu_param_type)
- || mech == By_Reference
- || (mech != By_Copy
- && ((foreign
- && (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
- || (foreign
- && (Convention (gnat_subprog) == Convention_Fortran
- || Convention (gnat_subprog) == Convention_COBOL)
- && (INTEGRAL_TYPE_P (gnu_param_type)
- || FLOAT_TYPE_P (gnu_param_type)))
- || (!foreign
- && default_pass_by_ref (gnu_param_type)))))
- {
- gnu_param_type = build_reference_type (gnu_param_type);
- by_ref = true;
- }
-
- /* Pass In Out or Out parameters using copy-in copy-out mechanism. */
- else if (!in_param)
- *cico = true;
-
- if (mech == By_Copy && (by_ref || by_component_ptr))
- post_error ("?cannot pass & by copy", gnat_param);
-
- /* If this is an Out parameter that isn't passed by reference and isn't
- a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
- it will be a VAR_DECL created when we process the procedure, so just
- return its type. For the special parameter of a valued procedure,
- never pass it in.
-
- An exception is made to cover the RM-6.4.1 rule requiring "by copy"
- Out parameters with discriminants or implicit initial values to be
- handled like In Out parameters. These type are normally built as
- aggregates, hence passed by reference, except for some packed arrays
- which end up encoded in special integer types.
-
- The exception we need to make is then for packed arrays of records
- with discriminants or implicit initial values. We have no light/easy
- way to check for the latter case, so we merely check for packed arrays
- of records. This may lead to useless copy-in operations, but in very
- rare cases only, as these would be exceptions in a set of already
- exceptional situations. */
- if (Ekind (gnat_param) == E_Out_Parameter
- && !by_ref
- && (by_return
- || (mech != By_Descriptor
- && !POINTER_TYPE_P (gnu_param_type)
- && !AGGREGATE_TYPE_P (gnu_param_type)))
- && !(Is_Array_Type (Etype (gnat_param))
- && Is_Packed (Etype (gnat_param))
- && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
- return gnu_param_type;
-
- gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
- ro_param || by_ref || by_component_ptr);
- DECL_BY_REF_P (gnu_param) = by_ref;
- DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
- DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
- DECL_POINTS_TO_READONLY_P (gnu_param)
- = (ro_param && (by_ref || by_component_ptr));
-
- /* If no Mechanism was specified, indicate what we're using, then
- back-annotate it. */
- if (mech == Default)
- mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
-
- Set_Mechanism (gnat_param, mech);
- return gnu_param;
-}
-
-/* Return true if DISCR1 and DISCR2 represent the same discriminant. */
-
-static bool
-same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
-{
- while (Present (Corresponding_Discriminant (discr1)))
- discr1 = Corresponding_Discriminant (discr1);
-
- while (Present (Corresponding_Discriminant (discr2)))
- discr2 = Corresponding_Discriminant (discr2);
-
- return
- Original_Record_Component (discr1) == Original_Record_Component (discr2);
-}
-
-/* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
- a non-aliased component in the back-end sense. */
-
-static bool
-array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
-{
- /* If the type below this is a multi-array type, then
- this does not have aliased components. */
- if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
- return true;
-
- if (Has_Aliased_Components (gnat_type))
- return false;
-
- return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
-}
-\f
-/* Given GNAT_ENTITY, elaborate all expressions that are required to
- be elaborated at the point of its definition, but do nothing else. */
-
-void
-elaborate_entity (Entity_Id gnat_entity)
-{
- switch (Ekind (gnat_entity))
- {
- case E_Signed_Integer_Subtype:
- case E_Modular_Integer_Subtype:
- case E_Enumeration_Subtype:
- case E_Ordinary_Fixed_Point_Subtype:
- case E_Decimal_Fixed_Point_Subtype:
- case E_Floating_Point_Subtype:
- {
- Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
- Node_Id gnat_hb = Type_High_Bound (gnat_entity);
-
- /* ??? Tests for avoiding static constraint error expression
- is needed until the front stops generating bogus conversions
- on bounds of real types. */
-
- if (!Raises_Constraint_Error (gnat_lb))
- elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
- 1, 0, Needs_Debug_Info (gnat_entity));
- if (!Raises_Constraint_Error (gnat_hb))
- elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
- 1, 0, Needs_Debug_Info (gnat_entity));
- break;
- }
-
- case E_Record_Type:
- {
- Node_Id full_definition = Declaration_Node (gnat_entity);
- Node_Id record_definition = Type_Definition (full_definition);
-
- /* If this is a record extension, go a level further to find the
- record definition. */
- if (Nkind (record_definition) == N_Derived_Type_Definition)
- record_definition = Record_Extension_Part (record_definition);
- }
- break;
-
- case E_Record_Subtype:
- case E_Private_Subtype:
- case E_Limited_Private_Subtype:
- case E_Record_Subtype_With_Private:
- if (Is_Constrained (gnat_entity)
- && Has_Discriminants (Base_Type (gnat_entity))
- && Present (Discriminant_Constraint (gnat_entity)))
- {
- Node_Id gnat_discriminant_expr;
- Entity_Id gnat_field;
-
- for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
- gnat_discriminant_expr
- = First_Elmt (Discriminant_Constraint (gnat_entity));
- Present (gnat_field);
- gnat_field = Next_Discriminant (gnat_field),
- gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
- /* ??? For now, ignore access discriminants. */
- if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
- elaborate_expression (Node (gnat_discriminant_expr),
- gnat_entity,
- get_entity_name (gnat_field), 1, 0, 0);
- }
- break;
-
- }
-}
-\f
-/* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark
- any entities on its entity chain similarly. */
-
-void
-mark_out_of_scope (Entity_Id gnat_entity)
-{
- Entity_Id gnat_sub_entity;
- unsigned int kind = Ekind (gnat_entity);
-
- /* If this has an entity list, process all in the list. */
- if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
- || IN (kind, Private_Kind)
- || kind == E_Block || kind == E_Entry || kind == E_Entry_Family
- || kind == E_Function || kind == E_Generic_Function
- || kind == E_Generic_Package || kind == E_Generic_Procedure
- || kind == E_Loop || kind == E_Operator || kind == E_Package
- || kind == E_Package_Body || kind == E_Procedure
- || kind == E_Record_Type || kind == E_Record_Subtype
- || kind == E_Subprogram_Body || kind == E_Subprogram_Type)
- for (gnat_sub_entity = First_Entity (gnat_entity);
- Present (gnat_sub_entity);
- gnat_sub_entity = Next_Entity (gnat_sub_entity))
- if (Scope (gnat_sub_entity) == gnat_entity
- && gnat_sub_entity != gnat_entity)
- mark_out_of_scope (gnat_sub_entity);
-
- /* Now clear this if it has been defined, but only do so if it isn't
- a subprogram or parameter. We could refine this, but it isn't
- worth it. If this is statically allocated, it is supposed to
- hang around out of cope. */
- if (present_gnu_tree (gnat_entity) && !Is_Statically_Allocated (gnat_entity)
- && kind != E_Procedure && kind != E_Function && !IN (kind, Formal_Kind))
- {
- save_gnu_tree (gnat_entity, NULL_TREE, true);
- save_gnu_tree (gnat_entity, error_mark_node, true);
- }
-}
-\f
-/* Set the alias set of GNU_NEW_TYPE to be that of GNU_OLD_TYPE. If this
- is a multi-dimensional array type, do this recursively. */
-
-static void
-copy_alias_set (tree gnu_new_type, tree gnu_old_type)
-{
- /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
- of a one-dimensional array, since the padding has the same alias set
- as the field type, but if it's a multi-dimensional array, we need to
- see the inner types. */
- while (TREE_CODE (gnu_old_type) == RECORD_TYPE
- && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
- || TYPE_IS_PADDING_P (gnu_old_type)))
- gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
-
- /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
- array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
- so we need to go down to what does. */
- if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
- gnu_old_type
- = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
-
- if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
- && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
- copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
-
- TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
- record_component_aliases (gnu_new_type);
-}
-\f
-/* Return a TREE_LIST describing the substitutions needed to reflect
- discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
- them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
- of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
- gives the tree for the discriminant and TREE_VALUES is the replacement
- value. They are in the form of operands to substitute_in_expr.
- DEFINITION is as in gnat_to_gnu_entity. */
-
-static tree
-substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
- tree gnu_list, bool definition)
-{
- Entity_Id gnat_discrim;
- Node_Id gnat_value;
-
- if (No (gnat_type))
- gnat_type = Implementation_Base_Type (gnat_subtype);
-
- if (Has_Discriminants (gnat_type))
- for (gnat_discrim = First_Stored_Discriminant (gnat_type),
- gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
- Present (gnat_discrim);
- gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
- gnat_value = Next_Elmt (gnat_value))
- /* Ignore access discriminants. */
- if (!Is_Access_Type (Etype (Node (gnat_value))))
- gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
- elaborate_expression
- (Node (gnat_value), gnat_subtype,
- get_entity_name (gnat_discrim), definition,
- 1, 0),
- gnu_list);
-
- return gnu_list;
-}
-\f
-/* Return true if the size represented by GNU_SIZE can be handled by an
- allocation. If STATIC_P is true, consider only what can be done with a
- static allocation. */
-
-static bool
-allocatable_size_p (tree gnu_size, bool static_p)
-{
- HOST_WIDE_INT our_size;
-
- /* If this is not a static allocation, the only case we want to forbid
- is an overflowing size. That will be converted into a raise a
- Storage_Error. */
- if (!static_p)
- return !(TREE_CODE (gnu_size) == INTEGER_CST
- && TREE_OVERFLOW (gnu_size));
-
- /* Otherwise, we need to deal with both variable sizes and constant
- sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
- since assemblers may not like very large sizes. */
- if (!host_integerp (gnu_size, 1))
- return false;
-
- our_size = tree_low_cst (gnu_size, 1);
- return (int) our_size == our_size;
-}
-\f
-/* Prepend to ATTR_LIST an entry for an attribute with provided TYPE,
- NAME, ARGS and ERROR_POINT. */
-
-static void
-prepend_one_attribute_to (struct attrib ** attr_list,
- enum attr_type attr_type,
- tree attr_name,
- tree attr_args,
- Node_Id attr_error_point)
-{
- struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
-
- attr->type = attr_type;
- attr->name = attr_name;
- attr->args = attr_args;
- attr->error_point = attr_error_point;
-
- attr->next = *attr_list;
- *attr_list = attr;
-}
-
-/* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
-
-static void
-prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
-{
- Node_Id gnat_temp;
-
- for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
- gnat_temp = Next_Rep_Item (gnat_temp))
- if (Nkind (gnat_temp) == N_Pragma)
- {
- tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
- Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
- enum attr_type etype;
-
- if (Present (gnat_assoc) && Present (First (gnat_assoc))
- && Present (Next (First (gnat_assoc)))
- && (Nkind (Expression (Next (First (gnat_assoc))))
- == N_String_Literal))
- {
- gnu_arg0 = get_identifier (TREE_STRING_POINTER
- (gnat_to_gnu
- (Expression (Next
- (First (gnat_assoc))))));
- if (Present (Next (Next (First (gnat_assoc))))
- && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
- == N_String_Literal))
- gnu_arg1 = get_identifier (TREE_STRING_POINTER
- (gnat_to_gnu
- (Expression
- (Next (Next
- (First (gnat_assoc)))))));
- }
-
- switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
- {
- case Pragma_Machine_Attribute:
- etype = ATTR_MACHINE_ATTRIBUTE;
- break;
-
- case Pragma_Linker_Alias:
- etype = ATTR_LINK_ALIAS;
- break;
-
- case Pragma_Linker_Section:
- etype = ATTR_LINK_SECTION;
- break;
-
- case Pragma_Linker_Constructor:
- etype = ATTR_LINK_CONSTRUCTOR;
- break;
-
- case Pragma_Linker_Destructor:
- etype = ATTR_LINK_DESTRUCTOR;
- break;
-
- case Pragma_Weak_External:
- etype = ATTR_WEAK_EXTERNAL;
- break;
-
- default:
- continue;
- }
-
-
- /* Prepend to the list now. Make a list of the argument we might
- have, as GCC expects it. */
- prepend_one_attribute_to
- (attr_list,
- etype, gnu_arg0,
- (gnu_arg1 != NULL_TREE)
- ? build_tree_list (NULL_TREE, gnu_arg1) : NULL_TREE,
- Present (Next (First (gnat_assoc)))
- ? Expression (Next (First (gnat_assoc))) : gnat_temp);
- }
-}
-\f
-/* Get the unpadded version of a GNAT type. */
-
-tree
-get_unpadded_type (Entity_Id gnat_entity)
-{
- tree type = gnat_to_gnu_type (gnat_entity);
-
- if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
- type = TREE_TYPE (TYPE_FIELDS (type));
-
- return type;
-}
-\f
-/* Called when we need to protect a variable object using a save_expr. */
-
-tree
-maybe_variable (tree gnu_operand)
-{
- if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
- || TREE_CODE (gnu_operand) == SAVE_EXPR
- || TREE_CODE (gnu_operand) == NULL_EXPR)
- return gnu_operand;
-
- if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
- {
- tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
- TREE_TYPE (gnu_operand),
- variable_size (TREE_OPERAND (gnu_operand, 0)));
-
- TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
- = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
- return gnu_result;
- }
- else
- return variable_size (gnu_operand);
-}
-\f
-/* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
- type definition (either a bound or a discriminant value) for GNAT_ENTITY,
- return the GCC tree to use for that expression. GNU_NAME is the
- qualification to use if an external name is appropriate and DEFINITION is
- nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero,
- we need a result. Otherwise, we are just elaborating this for
- side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging
- purposes even if it isn't needed for code generation. */
-
-static tree
-elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
- tree gnu_name, bool definition, bool need_value,
- bool need_debug)
-{
- tree gnu_expr;
-
- /* If we already elaborated this expression (e.g., it was involved
- in the definition of a private type), use the old value. */
- if (present_gnu_tree (gnat_expr))
- return get_gnu_tree (gnat_expr);
-
- /* If we don't need a value and this is static or a discriminant, we
- don't need to do anything. */
- else if (!need_value
- && (Is_OK_Static_Expression (gnat_expr)
- || (Nkind (gnat_expr) == N_Identifier
- && Ekind (Entity (gnat_expr)) == E_Discriminant)))
- return 0;
-
- /* Otherwise, convert this tree to its GCC equivalent. */
- gnu_expr
- = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
- gnu_name, definition, need_debug);
-
- /* Save the expression in case we try to elaborate this entity again. Since
- this is not a DECL, don't check it. Don't save if it's a discriminant. */
- if (!CONTAINS_PLACEHOLDER_P (gnu_expr))
- save_gnu_tree (gnat_expr, gnu_expr, true);
-
- return need_value ? gnu_expr : error_mark_node;
-}
-
-/* Similar, but take a GNU expression. */
-
-static tree
-elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
- tree gnu_expr, tree gnu_name, bool definition,
- bool need_debug)
-{
- tree gnu_decl = NULL_TREE;
- /* Skip any conversions and simple arithmetics to see if the expression
- is a read-only variable.
- ??? This really should remain read-only, but we have to think about
- the typing of the tree here. */
- tree gnu_inner_expr
- = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
- bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
- bool expr_variable;
-
- /* In most cases, we won't see a naked FIELD_DECL here because a
- discriminant reference will have been replaced with a COMPONENT_REF
- when the type is being elaborated. However, there are some cases
- involving child types where we will. So convert it to a COMPONENT_REF
- here. We have to hope it will be at the highest level of the
- expression in these cases. */
- if (TREE_CODE (gnu_expr) == FIELD_DECL)
- gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
- build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
- gnu_expr, NULL_TREE);
-
- /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
- that is read-only, make a variable that is initialized to contain the
- bound when the package containing the definition is elaborated. If
- this entity is defined at top level and a bound or discriminant value
- isn't a constant or a reference to a discriminant, replace the bound
- by the variable; otherwise use a SAVE_EXPR if needed. Note that we
- rely here on the fact that an expression cannot contain both the
- discriminant and some other variable. */
-
- expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
- && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
- && (TREE_READONLY (gnu_inner_expr)
- || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
- && !CONTAINS_PLACEHOLDER_P (gnu_expr));
-
- /* If this is a static expression or contains a discriminant, we don't
- need the variable for debugging (and can't elaborate anyway if a
- discriminant). */
- if (need_debug
- && (Is_OK_Static_Expression (gnat_expr)
- || CONTAINS_PLACEHOLDER_P (gnu_expr)))
- need_debug = false;
-
- /* Now create the variable if we need it. */
- if (need_debug || (expr_variable && expr_global))
- gnu_decl
- = create_var_decl (create_concat_name (gnat_entity,
- IDENTIFIER_POINTER (gnu_name)),
- NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
- !need_debug, Is_Public (gnat_entity),
- !definition, false, NULL, gnat_entity);
-
- /* We only need to use this variable if we are in global context since GCC
- can do the right thing in the local case. */
- if (expr_global && expr_variable)
- return gnu_decl;
- else if (!expr_variable)
- return gnu_expr;
- else
- return maybe_variable (gnu_expr);
-}
-\f
-/* 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. */
-
-tree
-make_aligning_type (tree type, unsigned int align, tree size,
- unsigned int base_align, int room)
-{
- /* We will be crafting a record type with one field at a position set to be
- the next multiple of ALIGN past record'address + room bytes. We use a
- record placeholder to express record'address. */
-
- tree record_type = make_node (RECORD_TYPE);
- tree record = build0 (PLACEHOLDER_EXPR, record_type);
-
- tree record_addr_st
- = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record));
-
- /* The diagram below summarizes the shape of what we manipulate:
-
- <--------- pos ---------->
- { +------------+-------------+-----------------+
- record =>{ |############| ... | field (type) |
- { +------------+-------------+-----------------+
- |<-- room -->|<- voffset ->|<---- size ----->|
- o o
- | |
- record_addr vblock_addr
-
- Every length is in sizetype bytes there, except "pos" which has to be
- set as a bit position in the GCC tree for the record. */
-
- tree room_st = size_int (room);
- tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st);
- tree voffset_st, pos, field;
-
- tree name = TYPE_NAME (type);
-
- if (TREE_CODE (name) == TYPE_DECL)
- name = DECL_NAME (name);
-
- TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
-
- /* Compute VOFFSET and then POS. The next byte position multiple of some
- alignment after some address is obtained by "and"ing the alignment minus
- 1 with the two's complement of the address. */
-
- voffset_st = size_binop (BIT_AND_EXPR,
- size_diffop (size_zero_node, vblock_addr_st),
- ssize_int ((align / BITS_PER_UNIT) - 1));
-
- /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */
-
- pos = size_binop (MULT_EXPR,
- convert (bitsizetype,
- size_binop (PLUS_EXPR, room_st, voffset_st)),
- bitsize_unit_node);
-
- /* Craft the GCC record representation. We exceptionally do everything
- manually here because 1) our generic circuitry is not quite ready to
- handle the complex position/size expressions we are setting up, 2) we
- have a strong simplifying factor at hand: we know the maximum possible
- value of voffset, and 3) we have to set/reset at least the sizes in
- accordance with this maximum value anyway, as we need them to convey
- what should be "alloc"ated for this type.
-
- Use -1 as the 'addressable' indication for the field to prevent the
- creation of a bitfield. We don't need one, it would have damaging
- consequences on the alignment computation, and create_field_decl would
- make one without this special argument, for instance because of the
- complex position expression. */
-
- field = create_field_decl (get_identifier ("F"), type, record_type,
- 1, size, pos, -1);
- TYPE_FIELDS (record_type) = field;
-
- TYPE_ALIGN (record_type) = base_align;
- TYPE_USER_ALIGN (record_type) = 1;
-
- TYPE_SIZE (record_type)
- = size_binop (PLUS_EXPR,
- size_binop (MULT_EXPR, convert (bitsizetype, size),
- bitsize_unit_node),
- bitsize_int (align + room * BITS_PER_UNIT));
- TYPE_SIZE_UNIT (record_type)
- = size_binop (PLUS_EXPR, size,
- size_int (room + align / BITS_PER_UNIT));
-
- TYPE_MODE (record_type) = BLKmode;
-
- copy_alias_set (record_type, type);
- return record_type;
-}
-\f
-/* Return the result of rounding T up to ALIGN. */
-
-static inline unsigned HOST_WIDE_INT
-round_up_to_align (unsigned HOST_WIDE_INT t, unsigned int align)
-{
- t += align - 1;
- t /= align;
- t *= align;
- return t;
-}
-
-/* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
- as the field type of a packed record if IN_RECORD is true, or as the
- component type of a packed array if IN_RECORD is false. See if we can
- rewrite it either as a type that has a non-BLKmode, which we can pack
- tighter in the packed record case, or as a smaller type with BLKmode.
- If so, return the new type. If not, return the original type. */
-
-static tree
-make_packable_type (tree type, bool in_record)
-{
- unsigned HOST_WIDE_INT size = tree_low_cst (TYPE_SIZE (type), 1);
- unsigned HOST_WIDE_INT new_size;
- tree new_type, old_field, field_list = NULL_TREE;
-
- /* No point in doing anything if the size is zero. */
- if (size == 0)
- return type;
-
- new_type = make_node (TREE_CODE (type));
-
- /* Copy the name and flags from the old type to that of the new.
- Note that we rely on the pointer equality created here for
- TYPE_NAME to look through conversions in various places. */
- TYPE_NAME (new_type) = TYPE_NAME (type);
- TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
- TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
- if (TREE_CODE (type) == RECORD_TYPE)
- TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
-
- /* If we are in a record and have a small size, set the alignment to
- try for an integral mode. Otherwise set it to try for a smaller
- type with BLKmode. */
- if (in_record && size <= MAX_FIXED_MODE_SIZE)
- {
- TYPE_ALIGN (new_type) = ceil_alignment (size);
- new_size = round_up_to_align (size, TYPE_ALIGN (new_type));
- }
- else
- {
- unsigned HOST_WIDE_INT align;
-
- /* Do not try to shrink the size if the RM size is not constant. */
- if (TYPE_CONTAINS_TEMPLATE_P (type)
- || !host_integerp (TYPE_ADA_SIZE (type), 1))
- return type;
-
- /* Round the RM size up to a unit boundary to get the minimal size
- for a BLKmode record. Give up if it's already the size. */
- new_size = TREE_INT_CST_LOW (TYPE_ADA_SIZE (type));
- new_size = round_up_to_align (new_size, BITS_PER_UNIT);
- if (new_size == size)
- return type;
-
- align = new_size & -new_size;
- TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
- }
-
- TYPE_USER_ALIGN (new_type) = 1;
-
- /* Now copy the fields, keeping the position and size as we don't want
- to change the layout by propagating the packedness downwards. */
- for (old_field = TYPE_FIELDS (type); old_field;
- old_field = TREE_CHAIN (old_field))
- {
- tree new_field_type = TREE_TYPE (old_field);
- tree new_field, new_size;
-
- if (TYPE_MODE (new_field_type) == BLKmode
- && (TREE_CODE (new_field_type) == RECORD_TYPE
- || TREE_CODE (new_field_type) == UNION_TYPE
- || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
- && host_integerp (TYPE_SIZE (new_field_type), 1))
- new_field_type = make_packable_type (new_field_type, true);
-
- /* However, for the last field in a not already packed record type
- that is of an aggregate type, we need to use the RM_Size in the
- packable version of the record type, see finish_record_type. */
- if (!TREE_CHAIN (old_field)
- && !TYPE_PACKED (type)
- && (TREE_CODE (new_field_type) == RECORD_TYPE
- || TREE_CODE (new_field_type) == UNION_TYPE
- || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (new_field_type)
- && !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
- && TYPE_ADA_SIZE (new_field_type))
- new_size = TYPE_ADA_SIZE (new_field_type);
- else
- new_size = DECL_SIZE (old_field);
-
- new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
- new_type, TYPE_PACKED (type), new_size,
- bit_position (old_field),
- !DECL_NONADDRESSABLE_P (old_field));
-
- DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
- SET_DECL_ORIGINAL_FIELD
- (new_field, (DECL_ORIGINAL_FIELD (old_field)
- ? DECL_ORIGINAL_FIELD (old_field) : old_field));
-
- if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
- DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
-
- TREE_CHAIN (new_field) = field_list;
- field_list = new_field;
- }
-
- finish_record_type (new_type, nreverse (field_list), 2, true);
- copy_alias_set (new_type, type);
-
- /* If this is a padding record, we never want to make the size smaller
- than what was specified. For QUAL_UNION_TYPE, also copy the size. */
- if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
- || TREE_CODE (type) == QUAL_UNION_TYPE)
- {
- TYPE_SIZE (new_type) = TYPE_SIZE (type);
- TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
- }
- else
- {
- TYPE_SIZE (new_type) = bitsize_int (new_size);
- TYPE_SIZE_UNIT (new_type)
- = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
- }
-
- if (!TYPE_CONTAINS_TEMPLATE_P (type))
- SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type));
-
- compute_record_mode (new_type);
-
- /* Try harder to get a packable type if necessary, for example
- in case the record itself contains a BLKmode field. */
- if (in_record && TYPE_MODE (new_type) == BLKmode)
- TYPE_MODE (new_type)
- = mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1);
-
- /* If neither the mode nor the size has shrunk, return the old type. */
- if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
- return type;
-
- return new_type;
-}
-\f
-/* 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 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 SIZE too; otherwise, it's set to the RM_Size of the original type. */
-
-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)
-{
- tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
- tree orig_size = TYPE_SIZE (type);
- unsigned int orig_align = align;
- tree record, field;
-
- /* If TYPE is a padded type, see if it agrees with any size and alignment
- we were given. If so, return the original type. Otherwise, strip
- off the padding, since we will either be returning the inner type
- or repadding it. If no size or alignment is specified, use that of
- the original padded type. */
- if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
- {
- if ((!size
- || operand_equal_p (round_up (size,
- MAX (align, TYPE_ALIGN (type))),
- round_up (TYPE_SIZE (type),
- MAX (align, TYPE_ALIGN (type))),
- 0))
- && (align == 0 || align == TYPE_ALIGN (type)))
- return type;
-
- if (!size)
- size = TYPE_SIZE (type);
- if (align == 0)
- align = TYPE_ALIGN (type);
-
- type = TREE_TYPE (TYPE_FIELDS (type));
- orig_size = TYPE_SIZE (type);
- }
-
- /* If the size is either not being changed or is being made smaller (which
- is not done here (and is only valid for bitfields anyway), show the size
- isn't changing. Likewise, clear the alignment if it isn't being
- changed. Then return if we aren't doing anything. */
- if (size
- && (operand_equal_p (size, orig_size, 0)
- || (TREE_CODE (orig_size) == INTEGER_CST
- && tree_int_cst_lt (size, orig_size))))
- size = NULL_TREE;
-
- if (align == TYPE_ALIGN (type))
- align = 0;
-
- if (align == 0 && !size)
- return type;
-
- /* If requested, complete the original type and give it a name. */
- if (is_user_type)
- create_type_decl (get_entity_name (gnat_entity), type,
- NULL, !Comes_From_Source (gnat_entity),
- !(TYPE_NAME (type)
- && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
- && DECL_IGNORED_P (TYPE_NAME (type))),
- gnat_entity);
-
- /* We used to modify the record in place in some cases, but that could
- generate incorrect debugging information. So make a new record
- type and name. */
- record = make_node (RECORD_TYPE);
- TYPE_IS_PADDING_P (record) = 1;
-
- if (Present (gnat_entity))
- TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
-
- TYPE_VOLATILE (record)
- = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
-
- TYPE_ALIGN (record) = align;
- if (orig_align)
- TYPE_USER_ALIGN (record) = align;
-
- TYPE_SIZE (record) = size ? size : orig_size;
- TYPE_SIZE_UNIT (record)
- = convert (sizetype,
- size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
- bitsize_unit_node));
-
- /* If we are changing the alignment and the input type is a record with
- BLKmode and a small constant size, try to make a form that has an
- integral mode. This might allow the padding record to also have an
- integral mode, which will be much more efficient. There is no point
- in doing so if a size is specified unless it is also a small constant
- size and it is incorrect to do so if we cannot guarantee that the mode
- will be naturally aligned since the field must always be addressable.
-
- ??? This might not always be a win when done for a stand-alone object:
- since the nominal and the effective type of the object will now have
- different modes, a VIEW_CONVERT_EXPR will be required for converting
- between them and it might be hard to overcome afterwards, including
- at the RTL level when the stand-alone object is accessed as a whole. */
- if (align != 0
- && TREE_CODE (type) == RECORD_TYPE
- && TYPE_MODE (type) == BLKmode
- && TREE_CODE (orig_size) == INTEGER_CST
- && !TREE_CONSTANT_OVERFLOW (orig_size)
- && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
- && (!size
- || (TREE_CODE (size) == INTEGER_CST
- && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0)))
- {
- tree packable_type = make_packable_type (type, true);
- if (TYPE_MODE (packable_type) != BLKmode
- && align >= TYPE_ALIGN (packable_type))
- type = packable_type;
- }
-
- /* Now create the field with the original size. */
- field = create_field_decl (get_identifier ("F"), type, record, 0,
- orig_size, bitsize_zero_node, 1);
- DECL_INTERNAL_P (field) = 1;
-
- /* Do not finalize it until after the auxiliary record is built. */
- finish_record_type (record, field, 1, true);
-
- /* Set the same size for its RM_size if requested; otherwise reuse
- the RM_size of the original type. */
- SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
-
- /* Unless debugging information isn't being written for the input type,
- write a record that shows what we are a subtype of and also make a
- variable that indicates our size, if still variable. */
- if (TYPE_NAME (record)
- && AGGREGATE_TYPE_P (type)
- && TREE_CODE (orig_size) != INTEGER_CST
- && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
- && DECL_IGNORED_P (TYPE_NAME (type))))
- {
- tree marker = make_node (RECORD_TYPE);
- tree name = TYPE_NAME (record);
- tree orig_name = TYPE_NAME (type);
-
- if (TREE_CODE (name) == TYPE_DECL)
- name = DECL_NAME (name);
-
- if (TREE_CODE (orig_name) == TYPE_DECL)
- orig_name = DECL_NAME (orig_name);
-
- TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
- finish_record_type (marker,
- create_field_decl (orig_name, integer_type_node,
- marker, 0, NULL_TREE, NULL_TREE,
- 0),
- 0, false);
-
- add_parallel_type (TYPE_STUB_DECL (record), marker);
-
- if (size && TREE_CODE (size) != INTEGER_CST && definition)
- create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
- bitsizetype, TYPE_SIZE (record), false, false, false,
- false, NULL, gnat_entity);
- }
-
- rest_of_record_type_compilation (record);
-
- /* If the size was widened explicitly, maybe give a warning. Take the
- original size as the maximum size of the input if there was an
- unconstrained record involved and round it up to the specified alignment,
- if one was specified. */
- if (CONTAINS_PLACEHOLDER_P (orig_size))
- orig_size = max_size (orig_size, true);
-
- if (align)
- orig_size = round_up (orig_size, align);
-
- if (size && Present (gnat_entity)
- && !operand_equal_p (size, orig_size, 0)
- && !(TREE_CODE (size) == INTEGER_CST
- && TREE_CODE (orig_size) == INTEGER_CST
- && tree_int_cst_lt (size, orig_size)))
- {
- Node_Id gnat_error_node = Empty;
-
- if (Is_Packed_Array_Type (gnat_entity))
- gnat_entity = Original_Array_Type (gnat_entity);
-
- if ((Ekind (gnat_entity) == E_Component
- || Ekind (gnat_entity) == E_Discriminant)
- && Present (Component_Clause (gnat_entity)))
- gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
- else if (Present (Size_Clause (gnat_entity)))
- gnat_error_node = Expression (Size_Clause (gnat_entity));
-
- /* Generate message only for entities that come from source, since
- if we have an entity created by expansion, the message will be
- generated for some other corresponding source entity. */
- if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
- post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
- gnat_entity,
- size_diffop (size, orig_size));
-
- else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
- post_error_ne_tree ("component of& padded{ by ^ bits}?",
- gnat_entity, gnat_entity,
- size_diffop (size, orig_size));
- }
-
- return record;
-}
-\f
-/* Given a GNU tree and a GNAT list of choices, generate an expression to test
- the value passed against the list of choices. */
-
-tree
-choices_to_gnu (tree operand, Node_Id choices)
-{
- Node_Id choice;
- Node_Id gnat_temp;
- tree result = integer_zero_node;
- tree this_test, low = 0, high = 0, single = 0;
-
- for (choice = First (choices); Present (choice); choice = Next (choice))
- {
- switch (Nkind (choice))
- {
- case N_Range:
- low = gnat_to_gnu (Low_Bound (choice));
- high = gnat_to_gnu (High_Bound (choice));
-
- /* There's no good type to use here, so we might as well use
- integer_type_node. */
- this_test
- = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
- build_binary_op (GE_EXPR, integer_type_node,
- operand, low),
- build_binary_op (LE_EXPR, integer_type_node,
- operand, high));
-
- break;
-
- case N_Subtype_Indication:
- gnat_temp = Range_Expression (Constraint (choice));
- low = gnat_to_gnu (Low_Bound (gnat_temp));
- high = gnat_to_gnu (High_Bound (gnat_temp));
-
- this_test
- = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
- build_binary_op (GE_EXPR, integer_type_node,
- operand, low),
- build_binary_op (LE_EXPR, integer_type_node,
- operand, high));
- break;
-
- case N_Identifier:
- case N_Expanded_Name:
- /* This represents either a subtype range, an enumeration
- literal, or a constant Ekind says which. If an enumeration
- literal or constant, fall through to the next case. */
- if (Ekind (Entity (choice)) != E_Enumeration_Literal
- && Ekind (Entity (choice)) != E_Constant)
- {
- tree type = gnat_to_gnu_type (Entity (choice));
-
- low = TYPE_MIN_VALUE (type);
- high = TYPE_MAX_VALUE (type);
-
- this_test
- = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
- build_binary_op (GE_EXPR, integer_type_node,
- operand, low),
- build_binary_op (LE_EXPR, integer_type_node,
- operand, high));
- break;
- }
- /* ... fall through ... */
- case N_Character_Literal:
- case N_Integer_Literal:
- single = gnat_to_gnu (choice);
- this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
- single);
- break;
-
- case N_Others_Choice:
- this_test = integer_one_node;
- break;
-
- default:
- gcc_unreachable ();
- }
-
- result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
- result, this_test);
- }
-
- return result;
-}
-\f
-/* Adjust PACKED setting as passed to gnat_to_gnu_field for a field of
- type FIELD_TYPE to be placed in RECORD_TYPE. Return the result. */
-
-static int
-adjust_packed (tree field_type, tree record_type, int packed)
-{
- /* If the field contains an item of variable size, we cannot pack it
- because we cannot create temporaries of non-fixed size in case
- we need to take the address of the field. See addressable_p and
- the notes on the addressability issues for further details. */
- if (is_variable_size (field_type))
- return 0;
-
- /* If the alignment of the record is specified and the field type
- is over-aligned, request Storage_Unit alignment for the field. */
- if (packed == -2)
- {
- if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type))
- return -1;
- else
- return 0;
- }
-
- return packed;
-}
-
-/* Return a GCC tree for a field corresponding to GNAT_FIELD to be
- placed in GNU_RECORD_TYPE.
-
- PACKED is 1 if the enclosing record is packed, -1 if the enclosing
- record has Component_Alignment of Storage_Unit, -2 if the enclosing
- record has a specified alignment.
-
- DEFINITION is true if this field is for a record being defined. */
-
-static tree
-gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
- bool definition)
-{
- tree gnu_field_id = get_entity_name (gnat_field);
- tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
- tree gnu_field, gnu_size, gnu_pos;
- bool needs_strict_alignment
- = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
- || Treat_As_Volatile (gnat_field));
-
- /* If this field requires strict alignment, we cannot pack it because
- it would very likely be under-aligned in the record. */
- if (needs_strict_alignment)
- packed = 0;
- else
- packed = adjust_packed (gnu_field_type, gnu_record_type, packed);
-
- /* If a size is specified, use it. Otherwise, if the record type is packed,
- use the official RM size. See "Handling of Type'Size Values" in Einfo
- for further details. */
- if (Known_Static_Esize (gnat_field))
- gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
- gnat_field, FIELD_DECL, false, true);
- else if (packed == 1)
- gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
- gnat_field, FIELD_DECL, false, true);
- else
- gnu_size = NULL_TREE;
-
- /* If we have a specified size that's smaller than that of the field type,
- or a position is specified, and the field type is also a record that's
- BLKmode, see if we can get either an integral mode form of the type or
- a smaller BLKmode form. If we can, show a size was specified for the
- field if there wasn't one already, so we know to make this a bitfield
- and avoid making things wider.
-
- Doing this is first useful if the record is packed because we may then
- place the field at a non-byte-aligned position and so achieve tighter
- packing.
-
- This is in addition *required* if the field shares a byte with another
- field and the front-end lets the back-end handle the references, because
- GCC does not handle BLKmode bitfields properly.
-
- We avoid the transformation if it is not required or potentially useful,
- as it might entail an increase of the field's alignment and have ripple
- effects on the outer record type. A typical case is a field known to be
- byte aligned and not to share a byte with another field.
-
- Besides, we don't even look the possibility of a transformation in cases
- known to be in error already, for instance when an invalid size results
- from a component clause. */
-
- if (TREE_CODE (gnu_field_type) == RECORD_TYPE
- && TYPE_MODE (gnu_field_type) == BLKmode
- && host_integerp (TYPE_SIZE (gnu_field_type), 1)
- && (packed == 1
- || (gnu_size
- && (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
- || Present (Component_Clause (gnat_field))))))
- {
- /* See what the alternate type and size would be. */
- tree gnu_packable_type = make_packable_type (gnu_field_type, true);
-
- bool has_byte_aligned_clause
- = Present (Component_Clause (gnat_field))
- && (UI_To_Int (Component_Bit_Offset (gnat_field))
- % BITS_PER_UNIT == 0);
-
- /* Compute whether we should avoid the substitution. */
- bool reject
- /* There is no point substituting if there is no change... */
- = (gnu_packable_type == gnu_field_type)
- /* ... nor when the field is known to be byte aligned and not to
- share a byte with another field. */
- || (has_byte_aligned_clause
- && value_factor_p (gnu_size, BITS_PER_UNIT))
- /* The size of an aliased field must be an exact multiple of the
- type's alignment, which the substitution might increase. Reject
- substitutions that would so invalidate a component clause when the
- specified position is byte aligned, as the change would have no
- real benefit from the packing standpoint anyway. */
- || (Is_Aliased (gnat_field)
- && has_byte_aligned_clause
- && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
-
- /* Substitute unless told otherwise. */
- if (!reject)
- {
- gnu_field_type = gnu_packable_type;
-
- if (!gnu_size)
- gnu_size = rm_size (gnu_field_type);
- }
- }
-
- /* If we are packing the record and the field is BLKmode, round the
- size up to a byte boundary. */
- if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
- gnu_size = round_up (gnu_size, BITS_PER_UNIT);
-
- if (Present (Component_Clause (gnat_field)))
- {
- gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
- gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
- gnat_field, FIELD_DECL, false, true);
-
- /* Ensure the position does not overlap with the parent subtype,
- if there is one. */
- if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
- {
- tree gnu_parent
- = gnat_to_gnu_type (Parent_Subtype
- (Underlying_Type (Scope (gnat_field))));
-
- if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
- && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
- {
- post_error_ne_tree
- ("offset of& must be beyond parent{, minimum allowed is ^}",
- First_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_SIZE_UNIT (gnu_parent));
- }
- }
-
- /* If this field needs strict alignment, ensure the record is
- sufficiently aligned and that that position and size are
- consistent with the alignment. */
- if (needs_strict_alignment)
- {
- TYPE_ALIGN (gnu_record_type)
- = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
-
- if (gnu_size
- && !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
- {
- if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
- post_error_ne_tree
- ("atomic field& must be natural size of type{ (^)}",
- Last_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_SIZE (gnu_field_type));
-
- else if (Is_Aliased (gnat_field))
- post_error_ne_tree
- ("size of aliased field& must be ^ bits",
- Last_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_SIZE (gnu_field_type));
-
- else if (Strict_Alignment (Etype (gnat_field)))
- post_error_ne_tree
- ("size of & with aliased or tagged components not ^ bits",
- Last_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_SIZE (gnu_field_type));
-
- gnu_size = NULL_TREE;
- }
-
- if (!integer_zerop (size_binop
- (TRUNC_MOD_EXPR, gnu_pos,
- bitsize_int (TYPE_ALIGN (gnu_field_type)))))
- {
- if (Is_Aliased (gnat_field))
- post_error_ne_num
- ("position of aliased field& must be multiple of ^ bits",
- First_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_ALIGN (gnu_field_type));
-
- else if (Treat_As_Volatile (gnat_field))
- post_error_ne_num
- ("position of volatile field& must be multiple of ^ bits",
- First_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_ALIGN (gnu_field_type));
-
- else if (Strict_Alignment (Etype (gnat_field)))
- post_error_ne_num
- ("position of & with aliased or tagged components not multiple of ^ bits",
- First_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_ALIGN (gnu_field_type));
-
- else
- gcc_unreachable ();
-
- gnu_pos = NULL_TREE;
- }
- }
-
- if (Is_Atomic (gnat_field))
- check_ok_for_atomic (gnu_field_type, gnat_field, false);
- }
-
- /* If the record has rep clauses and this is the tag field, make a rep
- clause for it as well. */
- else if (Has_Specified_Layout (Scope (gnat_field))
- && Chars (gnat_field) == Name_uTag)
- {
- gnu_pos = bitsize_zero_node;
- gnu_size = TYPE_SIZE (gnu_field_type);
- }
-
- else
- gnu_pos = NULL_TREE;
-
- /* We need to make the size the maximum for the type if it is
- self-referential and an unconstrained type. In that case, we can't
- pack the field since we can't make a copy to align it. */
- if (TREE_CODE (gnu_field_type) == RECORD_TYPE
- && !gnu_size
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
- && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
- {
- gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
- packed = 0;
- }
-
- /* If a size is specified, adjust the field's type to it. */
- if (gnu_size)
- {
- /* If the field's type is justified modular, we would need to remove
- the wrapper to (better) meet the layout requirements. However we
- can do so only if the field is not aliased to preserve the unique
- layout and if the prescribed size is not greater than that of the
- packed array to preserve the justification. */
- if (!needs_strict_alignment
- && TREE_CODE (gnu_field_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
- && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
- <= 0)
- gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
-
- gnu_field_type
- = make_type_from_size (gnu_field_type, gnu_size,
- Has_Biased_Representation (gnat_field));
- gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
- "PAD", false, definition, true);
- }
-
- /* Otherwise (or if there was an error), don't specify a position. */
- else
- gnu_pos = NULL_TREE;
-
- gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
- || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
-
- /* Now create the decl for the field. */
- gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
- packed, gnu_size, gnu_pos,
- Is_Aliased (gnat_field));
- Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
- TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
-
- if (Ekind (gnat_field) == E_Discriminant)
- DECL_DISCRIMINANT_NUMBER (gnu_field)
- = UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
-
- return gnu_field;
-}
-\f
-/* Return true if TYPE is a type with variable size, a padding type with a
- field of variable size or is a record that has a field such a field. */
-
-static bool
-is_variable_size (tree type)
-{
- tree field;
-
- if (!TREE_CONSTANT (TYPE_SIZE (type)))
- return true;
-
- if (TREE_CODE (type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (type)
- && !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
- return true;
-
- if (TREE_CODE (type) != RECORD_TYPE
- && TREE_CODE (type) != UNION_TYPE
- && TREE_CODE (type) != QUAL_UNION_TYPE)
- return false;
-
- for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
- if (is_variable_size (TREE_TYPE (field)))
- return true;
-
- return false;
-}
-\f
-/* qsort comparer for the bit positions of two record components. */
-
-static int
-compare_field_bitpos (const PTR rt1, const PTR rt2)
-{
- const_tree const field1 = * (const_tree const *) rt1;
- const_tree const field2 = * (const_tree const *) rt2;
- 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 GCC tree for a record type given a GNAT Component_List and a chain
- of GCC trees for fields that are in the record and have already been
- processed. When called from gnat_to_gnu_entity during the processing of a
- record type definition, the GCC nodes for the discriminants will be on
- the chain. The other calls to this function are recursive calls from
- itself for the Component_List of a variant and the chain is empty.
-
- PACKED is 1 if this is for a packed record, -1 if this is for a record
- with Component_Alignment of Storage_Unit, -2 if this is for a record
- with a specified alignment.
-
- DEFINITION is true if we are defining this record.
-
- P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
- with a rep clause is to be added. If it is nonzero, that is all that
- should be done with such fields.
-
- CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
- laying out the record. This means the alignment only serves to force fields
- to be bitfields, but not require the record to be that aligned. This is
- used for variants.
-
- ALL_REP, if true, means a rep clause was found for all the fields. This
- simplifies the logic since we know we're not in the mixed case.
-
- DO_NOT_FINALIZE, if true, means that the record type is expected to be
- modified afterwards so it will not be sent to the back-end for finalization.
-
- UNCHECKED_UNION, if true, means that we are building a type for a record
- with a Pragma Unchecked_Union.
-
- The processing of the component list fills in the chain with all of the
- fields of the record and then the record type is finished. */
-
-static void
-components_to_record (tree gnu_record_type, Node_Id component_list,
- tree gnu_field_list, int packed, bool definition,
- tree *p_gnu_rep_list, bool cancel_alignment,
- bool all_rep, bool do_not_finalize, bool unchecked_union)
-{
- Node_Id component_decl;
- Entity_Id gnat_field;
- Node_Id variant_part;
- tree gnu_our_rep_list = NULL_TREE;
- tree gnu_field, gnu_last;
- bool layout_with_rep = false;
- bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
-
- /* For each variable within each component declaration create a GCC field
- and add it to the list, skipping any pragmas in the list. */
- if (Present (Component_Items (component_list)))
- for (component_decl = First_Non_Pragma (Component_Items (component_list));
- Present (component_decl);
- component_decl = Next_Non_Pragma (component_decl))
- {
- gnat_field = Defining_Entity (component_decl);
-
- if (Chars (gnat_field) == Name_uParent)
- gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
- else
- {
- gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
- packed, definition);
-
- /* If this is the _Tag field, put it before any discriminants,
- instead of after them as is the case for all other fields.
- Ignore field of void type if only annotating. */
- if (Chars (gnat_field) == Name_uTag)
- gnu_field_list = chainon (gnu_field_list, gnu_field);
- else
- {
- TREE_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- }
- }
-
- save_gnu_tree (gnat_field, gnu_field, false);
- }
-
- /* At the end of the component list there may be a variant part. */
- variant_part = Variant_Part (component_list);
-
- /* We create a QUAL_UNION_TYPE for the variant part since the variants are
- mutually exclusive and should go in the same memory. To do this we need
- to treat each variant as a record whose elements are created from the
- component list for the variant. So here we create the records from the
- lists for the variants and put them all into the QUAL_UNION_TYPE.
- If this is an Unchecked_Union, we make a UNION_TYPE instead or
- use GNU_RECORD_TYPE if there are no fields so far. */
- if (Present (variant_part))
- {
- tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
- Node_Id variant;
- tree gnu_name = TYPE_NAME (gnu_record_type);
- tree gnu_var_name
- = concat_id_with_name (get_identifier (Get_Name_String
- (Chars (Name (variant_part)))),
- "XVN");
- tree gnu_union_type;
- tree gnu_union_name;
- tree gnu_union_field;
- tree gnu_variant_list = NULL_TREE;
-
- if (TREE_CODE (gnu_name) == TYPE_DECL)
- gnu_name = DECL_NAME (gnu_name);
-
- gnu_union_name = concat_id_with_name (gnu_name,
- IDENTIFIER_POINTER (gnu_var_name));
-
- /* Reuse an enclosing union if all fields are in the variant part
- and there is no representation clause on the record, to match
- the layout of C unions. There is an associated check below. */
- if (!gnu_field_list
- && TREE_CODE (gnu_record_type) == UNION_TYPE
- && !TYPE_PACKED (gnu_record_type))
- gnu_union_type = gnu_record_type;
- else
- {
- gnu_union_type
- = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
-
- TYPE_NAME (gnu_union_type) = gnu_union_name;
- TYPE_ALIGN (gnu_union_type) = 0;
- TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
- }
-
- for (variant = First_Non_Pragma (Variants (variant_part));
- Present (variant);
- variant = Next_Non_Pragma (variant))
- {
- tree gnu_variant_type = make_node (RECORD_TYPE);
- tree gnu_inner_name;
- tree gnu_qual;
-
- Get_Variant_Encoding (variant);
- gnu_inner_name = get_identifier (Name_Buffer);
- TYPE_NAME (gnu_variant_type)
- = concat_id_with_name (gnu_union_name,
- IDENTIFIER_POINTER (gnu_inner_name));
-
- /* Set the alignment of the inner type in case we need to make
- inner objects into bitfields, but then clear it out
- so the record actually gets only the alignment required. */
- TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
- TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
-
- /* Similarly, if the outer record has a size specified and all fields
- have record rep clauses, we can propagate the size into the
- variant part. */
- if (all_rep_and_size)
- {
- TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
- TYPE_SIZE_UNIT (gnu_variant_type)
- = TYPE_SIZE_UNIT (gnu_record_type);
- }
-
- /* Create the record type for the variant. Note that we defer
- finalizing it until after we are sure to actually use it. */
- components_to_record (gnu_variant_type, Component_List (variant),
- NULL_TREE, packed, definition,
- &gnu_our_rep_list, !all_rep_and_size, all_rep,
- true, unchecked_union);
-
- gnu_qual = choices_to_gnu (gnu_discriminant,
- Discrete_Choices (variant));
-
- Set_Present_Expr (variant, annotate_value (gnu_qual));
-
- /* If this is an Unchecked_Union and we have exactly one field,
- use this field directly to match the layout of C unions. */
- if (unchecked_union
- && TYPE_FIELDS (gnu_variant_type)
- && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
- gnu_field = TYPE_FIELDS (gnu_variant_type);
- else
- {
- /* Deal with packedness like in gnat_to_gnu_field. */
- int field_packed
- = adjust_packed (gnu_variant_type, gnu_record_type, packed);
-
- /* Finalize the record type now. We used to throw away
- empty records but we no longer do that because we need
- them to generate complete debug info for the variant;
- otherwise, the union type definition will be lacking
- the fields associated with these empty variants. */
- rest_of_record_type_compilation (gnu_variant_type);
-
- gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
- gnu_union_type, field_packed,
- (all_rep_and_size
- ? TYPE_SIZE (gnu_variant_type)
- : 0),
- (all_rep_and_size
- ? bitsize_zero_node : 0),
- 0);
-
- DECL_INTERNAL_P (gnu_field) = 1;
-
- if (!unchecked_union)
- DECL_QUALIFIER (gnu_field) = gnu_qual;
- }
-
- TREE_CHAIN (gnu_field) = gnu_variant_list;
- gnu_variant_list = gnu_field;
- }
-
- /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
- if (gnu_variant_list)
- {
- int union_field_packed;
-
- if (all_rep_and_size)
- {
- TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
- TYPE_SIZE_UNIT (gnu_union_type)
- = TYPE_SIZE_UNIT (gnu_record_type);
- }
-
- finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
- all_rep_and_size ? 1 : 0, false);
-
- /* If GNU_UNION_TYPE is our record type, it means we must have an
- Unchecked_Union with no fields. Verify that and, if so, just
- return. */
- if (gnu_union_type == gnu_record_type)
- {
- gcc_assert (unchecked_union
- && !gnu_field_list
- && !gnu_our_rep_list);
- return;
- }
-
- /* Deal with packedness like in gnat_to_gnu_field. */
- union_field_packed
- = adjust_packed (gnu_union_type, gnu_record_type, packed);
-
- gnu_union_field
- = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
- union_field_packed,
- all_rep ? TYPE_SIZE (gnu_union_type) : 0,
- all_rep ? bitsize_zero_node : 0, 0);
-
- DECL_INTERNAL_P (gnu_union_field) = 1;
- TREE_CHAIN (gnu_union_field) = gnu_field_list;
- gnu_field_list = gnu_union_field;
- }
- }
-
- /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
- do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this
- in a separate pass since we want to handle the discriminants but can't
- play with them until we've used them in debugging data above.
-
- ??? Note: if we then reorder them, debugging information will be wrong,
- but there's nothing that can be done about this at the moment. */
- for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
- {
- if (DECL_FIELD_OFFSET (gnu_field))
- {
- tree gnu_next = TREE_CHAIN (gnu_field);
-
- if (!gnu_last)
- gnu_field_list = gnu_next;
- else
- TREE_CHAIN (gnu_last) = gnu_next;
-
- TREE_CHAIN (gnu_field) = gnu_our_rep_list;
- gnu_our_rep_list = gnu_field;
- gnu_field = gnu_next;
- }
- else
- {
- gnu_last = gnu_field;
- gnu_field = TREE_CHAIN (gnu_field);
- }
- }
-
- /* If we have any items in our rep'ed field list, it is not the case that all
- the fields in the record have rep clauses, and P_REP_LIST is nonzero,
- set it and ignore the items. */
- if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
- *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
- else if (gnu_our_rep_list)
- {
- /* Otherwise, sort the fields by bit position and put them into their
- own record if we have any fields without rep clauses. */
- tree gnu_rep_type
- = (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
- int len = list_length (gnu_our_rep_list);
- tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
- int i;
-
- for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
- gnu_field = TREE_CHAIN (gnu_field), i++)
- gnu_arr[i] = gnu_field;
-
- qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
-
- /* Put the fields in the list in order of increasing position, which
- means we start from the end. */
- gnu_our_rep_list = NULL_TREE;
- for (i = len - 1; i >= 0; i--)
- {
- TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
- gnu_our_rep_list = gnu_arr[i];
- DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
- }
-
- if (gnu_field_list)
- {
- finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
- gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
- gnu_record_type, 0, 0, 0, 1);
- DECL_INTERNAL_P (gnu_field) = 1;
- gnu_field_list = chainon (gnu_field_list, gnu_field);
- }
- else
- {
- layout_with_rep = true;
- gnu_field_list = nreverse (gnu_our_rep_list);
- }
- }
-
- if (cancel_alignment)
- TYPE_ALIGN (gnu_record_type) = 0;
-
- finish_record_type (gnu_record_type, nreverse (gnu_field_list),
- layout_with_rep ? 1 : 0, do_not_finalize);
-}
-\f
-/* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
- placed into an Esize, Component_Bit_Offset, or Component_Size value
- in the GNAT tree. */
-
-static Uint
-annotate_value (tree gnu_size)
-{
- int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
- TCode tcode;
- Node_Ref_Or_Val ops[3], ret;
- int i;
- int size;
- struct tree_int_map **h = NULL;
-
- /* See if we've already saved the value for this node. */
- if (EXPR_P (gnu_size))
- {
- struct tree_int_map in;
- if (!annotate_value_cache)
- annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
- tree_int_map_eq, 0);
- in.base.from = gnu_size;
- h = (struct tree_int_map **)
- htab_find_slot (annotate_value_cache, &in, INSERT);
-
- if (*h)
- return (Node_Ref_Or_Val) (*h)->to;
- }
-
- /* If we do not return inside this switch, TCODE will be set to the
- code to use for a Create_Node operand and LEN (set above) will be
- the number of recursive calls for us to make. */
-
- switch (TREE_CODE (gnu_size))
- {
- case INTEGER_CST:
- if (TREE_OVERFLOW (gnu_size))
- return No_Uint;
-
- /* This may have come from a conversion from some smaller type,
- so ensure this is in bitsizetype. */
- gnu_size = convert (bitsizetype, gnu_size);
-
- /* For negative values, use NEGATE_EXPR of the supplied value. */
- if (tree_int_cst_sgn (gnu_size) < 0)
- {
- /* The ridiculous code below is to handle the case of the largest
- negative integer. */
- tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
- bool adjust = false;
- tree temp;
-
- if (TREE_OVERFLOW (negative_size))
- {
- negative_size
- = size_binop (MINUS_EXPR, bitsize_zero_node,
- size_binop (PLUS_EXPR, gnu_size,
- bitsize_one_node));
- adjust = true;
- }
-
- temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
- if (adjust)
- temp = build2 (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
-
- return annotate_value (temp);
- }
-
- if (!host_integerp (gnu_size, 1))
- return No_Uint;
-
- size = tree_low_cst (gnu_size, 1);
-
- /* This peculiar test is to make sure that the size fits in an int
- on machines where HOST_WIDE_INT is not "int". */
- if (tree_low_cst (gnu_size, 1) == size)
- return UI_From_Int (size);
- else
- return No_Uint;
-
- case COMPONENT_REF:
- /* The only case we handle here is a simple discriminant reference. */
- if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
- && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
- && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
- return Create_Node (Discrim_Val,
- annotate_value (DECL_DISCRIMINANT_NUMBER
- (TREE_OPERAND (gnu_size, 1))),
- No_Uint, No_Uint);
- else
- return No_Uint;
-
- CASE_CONVERT: case NON_LVALUE_EXPR:
- return annotate_value (TREE_OPERAND (gnu_size, 0));
-
- /* Now just list the operations we handle. */
- case COND_EXPR: tcode = Cond_Expr; break;
- case PLUS_EXPR: tcode = Plus_Expr; break;
- case MINUS_EXPR: tcode = Minus_Expr; break;
- case MULT_EXPR: tcode = Mult_Expr; break;
- case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
- case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
- case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
- case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
- case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
- case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
- case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
- case NEGATE_EXPR: tcode = Negate_Expr; break;
- case MIN_EXPR: tcode = Min_Expr; break;
- case MAX_EXPR: tcode = Max_Expr; break;
- case ABS_EXPR: tcode = Abs_Expr; break;
- case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
- case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
- case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
- case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
- case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
- case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
- case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
- case LT_EXPR: tcode = Lt_Expr; break;
- case LE_EXPR: tcode = Le_Expr; break;
- case GT_EXPR: tcode = Gt_Expr; break;
- case GE_EXPR: tcode = Ge_Expr; break;
- case EQ_EXPR: tcode = Eq_Expr; break;
- case NE_EXPR: tcode = Ne_Expr; break;
-
- default:
- return No_Uint;
- }
-
- /* Now get each of the operands that's relevant for this code. If any
- cannot be expressed as a repinfo node, say we can't. */
- for (i = 0; i < 3; i++)
- ops[i] = No_Uint;
-
- for (i = 0; i < len; i++)
- {
- ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
- if (ops[i] == No_Uint)
- return No_Uint;
- }
-
- ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
-
- /* Save the result in the cache. */
- if (h)
- {
- *h = GGC_NEW (struct tree_int_map);
- (*h)->base.from = gnu_size;
- (*h)->to = ret;
- }
-
- return ret;
-}
-
-/* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
- GCC type, set Component_Bit_Offset and Esize to the position and size
- used by Gigi. */
-
-static void
-annotate_rep (Entity_Id gnat_entity, tree gnu_type)
-{
- tree gnu_list;
- tree gnu_entry;
- Entity_Id gnat_field;
-
- /* We operate by first making a list of all fields and their positions
- (we can get the sizes easily at any time) by a recursive call
- and then update all the sizes into the tree. */
- gnu_list = compute_field_positions (gnu_type, NULL_TREE,
- size_zero_node, bitsize_zero_node,
- BIGGEST_ALIGNMENT);
-
- for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
- gnat_field = Next_Entity (gnat_field))
- if ((Ekind (gnat_field) == E_Component
- || (Ekind (gnat_field) == E_Discriminant
- && !Is_Unchecked_Union (Scope (gnat_field)))))
- {
- tree parent_offset = bitsize_zero_node;
-
- gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
- gnu_list);
-
- if (gnu_entry)
- {
- if (type_annotate_only && Is_Tagged_Type (gnat_entity))
- {
- /* In this mode the tag and parent components have not been
- generated, so we add the appropriate offset to each
- component. For a component appearing in the current
- extension, the offset is the size of the parent. */
- if (Is_Derived_Type (gnat_entity)
- && Original_Record_Component (gnat_field) == gnat_field)
- parent_offset
- = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
- bitsizetype);
- else
- parent_offset = bitsize_int (POINTER_SIZE);
- }
-
- Set_Component_Bit_Offset
- (gnat_field,
- annotate_value
- (size_binop (PLUS_EXPR,
- bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
- TREE_VALUE (TREE_VALUE
- (TREE_VALUE (gnu_entry)))),
- parent_offset)));
-
- Set_Esize (gnat_field,
- annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
- }
- else if (Is_Tagged_Type (gnat_entity)
- && Is_Derived_Type (gnat_entity))
- {
- /* If there is no gnu_entry, this is an inherited component whose
- position is the same as in the parent type. */
- Set_Component_Bit_Offset
- (gnat_field,
- Component_Bit_Offset (Original_Record_Component (gnat_field)));
- Set_Esize (gnat_field,
- Esize (Original_Record_Component (gnat_field)));
- }
- }
-}
-
-/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
- FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
- position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
- placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
- to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
- the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
- so far. */
-
-static tree
-compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
- tree gnu_bitpos, unsigned int offset_align)
-{
- tree gnu_field;
- tree gnu_result = gnu_list;
-
- for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
- gnu_field = TREE_CHAIN (gnu_field))
- {
- tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
- DECL_FIELD_BIT_OFFSET (gnu_field));
- tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos,
- DECL_FIELD_OFFSET (gnu_field));
- unsigned int our_offset_align
- = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
-
- gnu_result
- = tree_cons (gnu_field,
- tree_cons (gnu_our_offset,
- tree_cons (size_int (our_offset_align),
- gnu_our_bitpos, NULL_TREE),
- NULL_TREE),
- gnu_result);
-
- if (DECL_INTERNAL_P (gnu_field))
- gnu_result
- = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
- gnu_our_offset, gnu_our_bitpos,
- our_offset_align);
- }
-
- return gnu_result;
-}
-\f
-/* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
- corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
- to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
- the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
- for the size of a field. COMPONENT_P is true if we are being called
- to process the Component_Size of GNAT_OBJECT. This is used for error
- message handling and to indicate to use the object size of GNU_TYPE.
- ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
- it means that a size of zero should be treated as an unspecified size. */
-
-static tree
-validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
- enum tree_code kind, bool component_p, bool zero_ok)
-{
- Node_Id gnat_error_node;
- tree type_size, size;
-
- if (kind == VAR_DECL
- /* If a type needs strict alignment, a component of this type in
- a packed record cannot be packed and thus uses the type size. */
- || (kind == TYPE_DECL && Strict_Alignment (gnat_object)))
- type_size = TYPE_SIZE (gnu_type);
- else
- type_size = rm_size (gnu_type);
-
- /* Find the node to use for errors. */
- if ((Ekind (gnat_object) == E_Component
- || Ekind (gnat_object) == E_Discriminant)
- && Present (Component_Clause (gnat_object)))
- gnat_error_node = Last_Bit (Component_Clause (gnat_object));
- else if (Present (Size_Clause (gnat_object)))
- gnat_error_node = Expression (Size_Clause (gnat_object));
- else
- gnat_error_node = gnat_object;
-
- /* Return 0 if no size was specified, either because Esize was not Present or
- the specified size was zero. */
- if (No (uint_size) || uint_size == No_Uint)
- return NULL_TREE;
-
- /* Get the size as a tree. Give an error if a size was specified, but cannot
- be represented as in sizetype. */
- size = UI_To_gnu (uint_size, bitsizetype);
- if (TREE_OVERFLOW (size))
- {
- post_error_ne (component_p ? "component size of & is too large"
- : "size of & is too large",
- gnat_error_node, gnat_object);
- return NULL_TREE;
- }
-
- /* Ignore a negative size since that corresponds to our back-annotation.
- Also ignore a zero size unless a size clause exists. */
- else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
- return NULL_TREE;
-
- /* The size of objects is always a multiple of a byte. */
- if (kind == VAR_DECL
- && !integer_zerop (size_binop (TRUNC_MOD_EXPR, size, bitsize_unit_node)))
- {
- if (component_p)
- post_error_ne ("component size for& is not a multiple of Storage_Unit",
- gnat_error_node, gnat_object);
- else
- post_error_ne ("size for& is not a multiple of Storage_Unit",
- gnat_error_node, gnat_object);
- return NULL_TREE;
- }
-
- /* If this is an integral type or a packed array type, the front-end has
- verified the size, so we need not do it here (which would entail
- checking against the bounds). However, if this is an aliased object, it
- may not be smaller than the type of the object. */
- if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
- && !(kind == VAR_DECL && Is_Aliased (gnat_object)))
- return size;
-
- /* If the object is a record that contains a template, add the size of
- the template to the specified size. */
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
-
- /* Modify the size of the type to be that of the maximum size if it has a
- discriminant. */
- if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
- type_size = max_size (type_size, true);
-
- /* If this is an access type or a fat pointer, the minimum size is that given
- by the smallest integral mode that's valid for pointers. */
- if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
- {
- enum machine_mode p_mode;
-
- for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
- !targetm.valid_pointer_mode (p_mode);
- p_mode = GET_MODE_WIDER_MODE (p_mode))
- ;
-
- type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
- }
-
- /* If the size of the object is a constant, the new size must not be
- smaller. */
- if (TREE_CODE (type_size) != INTEGER_CST
- || TREE_OVERFLOW (type_size)
- || tree_int_cst_lt (size, type_size))
- {
- if (component_p)
- post_error_ne_tree
- ("component size for& too small{, minimum allowed is ^}",
- gnat_error_node, gnat_object, type_size);
- else
- post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
- gnat_error_node, gnat_object, type_size);
-
- if (kind == VAR_DECL && !component_p
- && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
- && !tree_int_cst_lt (size, rm_size (gnu_type)))
- post_error_ne_tree_2
- ("\\size of ^ is not a multiple of alignment (^ bits)",
- gnat_error_node, gnat_object, rm_size (gnu_type),
- TYPE_ALIGN (gnu_type));
-
- else if (INTEGRAL_TYPE_P (gnu_type))
- post_error_ne ("\\size would be legal if & were not aliased!",
- gnat_error_node, gnat_object);
-
- return NULL_TREE;
- }
-
- return size;
-}
-\f
-/* Similarly, but both validate and process a value of RM_Size. This
- routine is only called for types. */
-
-static void
-set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
-{
- /* Only give an error if a Value_Size clause was explicitly given.
- Otherwise, we'd be duplicating an error on the Size clause. */
- Node_Id gnat_attr_node
- = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
- tree old_size = rm_size (gnu_type);
- tree size;
-
- /* Get the size as a tree. Do nothing if none was specified, either
- because RM_Size was not Present or if the specified size was zero.
- Give an error if a size was specified, but cannot be represented as
- in sizetype. */
- if (No (uint_size) || uint_size == No_Uint)
- return;
-
- size = UI_To_gnu (uint_size, bitsizetype);
- if (TREE_OVERFLOW (size))
- {
- if (Present (gnat_attr_node))
- post_error_ne ("Value_Size of & is too large", gnat_attr_node,
- gnat_entity);
-
- return;
- }
-
- /* Ignore a negative size since that corresponds to our back-annotation.
- Also ignore a zero size unless a size clause exists, a Value_Size
- clause exists, or this is an integer type, in which case the
- front end will have always set it. */
- else if (tree_int_cst_sgn (size) < 0
- || (integer_zerop (size) && No (gnat_attr_node)
- && !Has_Size_Clause (gnat_entity)
- && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
- return;
-
- /* If the old size is self-referential, get the maximum size. */
- if (CONTAINS_PLACEHOLDER_P (old_size))
- old_size = max_size (old_size, true);
-
- /* If the size of the object is a constant, the new size must not be
- smaller (the front end checks this for scalar types). */
- if (TREE_CODE (old_size) != INTEGER_CST
- || TREE_OVERFLOW (old_size)
- || (AGGREGATE_TYPE_P (gnu_type)
- && tree_int_cst_lt (size, old_size)))
- {
- if (Present (gnat_attr_node))
- post_error_ne_tree
- ("Value_Size for& too small{, minimum allowed is ^}",
- gnat_attr_node, gnat_entity, old_size);
-
- return;
- }
-
- /* Otherwise, set the RM_Size. */
- if (TREE_CODE (gnu_type) == INTEGER_TYPE
- && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
- TYPE_RM_SIZE_NUM (gnu_type) = size;
- else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
- TYPE_RM_SIZE_NUM (gnu_type) = size;
- else if ((TREE_CODE (gnu_type) == RECORD_TYPE
- || TREE_CODE (gnu_type) == UNION_TYPE
- || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (gnu_type))
- SET_TYPE_ADA_SIZE (gnu_type, size);
-}
-\f
-/* Given a type TYPE, return a new type whose size is appropriate for SIZE.
- If TYPE is the best type, return it. Otherwise, make a new type. We
- only support new integral and pointer types. FOR_BIASED is nonzero if
- we are making a biased type. */
-
-static tree
-make_type_from_size (tree type, tree size_tree, bool for_biased)
-{
- unsigned HOST_WIDE_INT size;
- bool biased_p;
- tree new_type;
-
- /* If size indicates an error, just return TYPE to avoid propagating
- the error. Likewise if it's too large to represent. */
- if (!size_tree || !host_integerp (size_tree, 1))
- return type;
-
- size = tree_low_cst (size_tree, 1);
-
- switch (TREE_CODE (type))
- {
- case INTEGER_TYPE:
- case ENUMERAL_TYPE:
- biased_p = (TREE_CODE (type) == INTEGER_TYPE
- && TYPE_BIASED_REPRESENTATION_P (type));
-
- /* Only do something if the type is not a packed array type and
- doesn't already have the proper size. */
- if (TYPE_PACKED_ARRAY_TYPE_P (type)
- || (TYPE_PRECISION (type) == size && biased_p == for_biased))
- break;
-
- biased_p |= for_biased;
- size = MIN (size, LONG_LONG_TYPE_SIZE);
-
- if (TYPE_UNSIGNED (type) || biased_p)
- new_type = make_unsigned_type (size);
- else
- new_type = make_signed_type (size);
- TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
- TYPE_MIN_VALUE (new_type)
- = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
- TYPE_MAX_VALUE (new_type)
- = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
- TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
- TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
- return new_type;
-
- case RECORD_TYPE:
- /* Do something if this is a fat pointer, in which case we
- may need to return the thin pointer. */
- if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
- return
- build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
- break;
-
- case POINTER_TYPE:
- /* Only do something if this is a thin pointer, in which case we
- may need to return the fat pointer. */
- if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
- return
- build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
- break;
-
- default:
- break;
- }
-
- return type;
-}
-\f
-/* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY,
- a type or object whose present alignment is ALIGN. If this alignment is
- valid, return it. Otherwise, give an error and return ALIGN. */
-
-static unsigned int
-validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align)
-{
- unsigned int max_allowed_alignment = get_target_maximum_allowed_alignment ();
- unsigned int new_align;
- Node_Id gnat_error_node;
-
- /* Don't worry about checking alignment if alignment was not specified
- by the source program and we already posted an error for this entity. */
- if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
- return align;
-
- /* Post the error on the alignment clause if any. */
- if (Present (Alignment_Clause (gnat_entity)))
- gnat_error_node = Expression (Alignment_Clause (gnat_entity));
- else
- gnat_error_node = gnat_entity;
-
- /* Within GCC, an alignment is an integer, so we must make sure a value is
- specified that fits in that range. Also, there is an upper bound to
- alignments we can support/allow. */
- if (!UI_Is_In_Int_Range (alignment)
- || ((new_align = UI_To_Int (alignment)) > max_allowed_alignment))
- post_error_ne_num ("largest supported alignment for& is ^",
- gnat_error_node, gnat_entity, max_allowed_alignment);
- else if (!(Present (Alignment_Clause (gnat_entity))
- && From_At_Mod (Alignment_Clause (gnat_entity)))
- && new_align * BITS_PER_UNIT < align)
- post_error_ne_num ("alignment for& must be at least ^",
- gnat_error_node, gnat_entity,
- align / BITS_PER_UNIT);
- else
- {
- new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
- if (new_align > align)
- align = new_align;
- }
-
- return align;
-}
-
-/* Return the smallest alignment not less than SIZE. */
-
-static unsigned int
-ceil_alignment (unsigned HOST_WIDE_INT size)
-{
- return (unsigned int) 1 << (floor_log2 (size - 1) + 1);
-}
-\f
-/* Verify that OBJECT, a type or decl, is something we can implement
- atomically. If not, give an error for GNAT_ENTITY. COMP_P is true
- if we require atomic components. */
-
-static void
-check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p)
-{
- Node_Id gnat_error_point = gnat_entity;
- Node_Id gnat_node;
- enum machine_mode mode;
- unsigned int align;
- tree size;
-
- /* There are three case of what OBJECT can be. It can be a type, in which
- case we take the size, alignment and mode from the type. It can be a
- declaration that was indirect, in which case the relevant values are
- that of the type being pointed to, or it can be a normal declaration,
- in which case the values are of the decl. The code below assumes that
- OBJECT is either a type or a decl. */
- if (TYPE_P (object))
- {
- mode = TYPE_MODE (object);
- align = TYPE_ALIGN (object);
- size = TYPE_SIZE (object);
- }
- else if (DECL_BY_REF_P (object))
- {
- mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
- align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
- size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
- }
- else
- {
- mode = DECL_MODE (object);
- align = DECL_ALIGN (object);
- size = DECL_SIZE (object);
- }
-
- /* Consider all floating-point types atomic and any types that that are
- represented by integers no wider than a machine word. */
- if (GET_MODE_CLASS (mode) == MODE_FLOAT
- || ((GET_MODE_CLASS (mode) == MODE_INT
- || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
- && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
- return;
-
- /* For the moment, also allow anything that has an alignment equal
- to its size and which is smaller than a word. */
- if (size && TREE_CODE (size) == INTEGER_CST
- && compare_tree_int (size, align) == 0
- && align <= BITS_PER_WORD)
- return;
-
- for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
- gnat_node = Next_Rep_Item (gnat_node))
- {
- if (!comp_p && Nkind (gnat_node) == N_Pragma
- && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
- == Pragma_Atomic))
- gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
- else if (comp_p && Nkind (gnat_node) == N_Pragma
- && (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)))
- == Pragma_Atomic_Components))
- gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
- }
-
- if (comp_p)
- post_error_ne ("atomic access to component of & cannot be guaranteed",
- gnat_error_point, gnat_entity);
- else
- post_error_ne ("atomic access to & cannot be guaranteed",
- gnat_error_point, gnat_entity);
-}
-\f
-/* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
- have compatible signatures so that a call using one type may be safely
- issued if the actual target function type is the other. Return 1 if it is
- the case, 0 otherwise, and post errors on the incompatibilities.
-
- This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
- that calls to the subprogram will have arguments suitable for the later
- underlying builtin expansion. */
-
-static int
-compatible_signatures_p (tree ftype1, tree ftype2)
-{
- /* As of now, we only perform very trivial tests and consider it's the
- programmer's responsibility to ensure the type correctness in the Ada
- declaration, as in the regular Import cases.
-
- Mismatches typically result in either error messages from the builtin
- expander, internal compiler errors, or in a real call sequence. This
- should be refined to issue diagnostics helping error detection and
- correction. */
-
- /* Almost fake test, ensuring a use of each argument. */
- if (ftype1 == ftype2)
- return 1;
-
- return 1;
-}
-\f
-/* 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. */
-
-tree
-substitute_in_type (tree t, tree f, tree r)
-{
- tree new = t;
- tree tem;
-
- switch (TREE_CODE (t))
- {
- case INTEGER_TYPE:
- case ENUMERAL_TYPE:
- case BOOLEAN_TYPE:
- if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
- || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
- {
- tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
- tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
-
- if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
- return t;
-
- new = build_range_type (TREE_TYPE (t), low, high);
- if (TYPE_INDEX_TYPE (t))
- SET_TYPE_INDEX_TYPE
- (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
- return new;
- }
-
- return t;
-
- case REAL_TYPE:
- if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
- || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
- {
- tree low = NULL_TREE, high = NULL_TREE;
-
- if (TYPE_MIN_VALUE (t))
- low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
- if (TYPE_MAX_VALUE (t))
- high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
-
- if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
- return t;
-
- t = copy_type (t);
- TYPE_MIN_VALUE (t) = low;
- TYPE_MAX_VALUE (t) = high;
- }
- return t;
-
- case COMPLEX_TYPE:
- tem = substitute_in_type (TREE_TYPE (t), f, r);
- if (tem == TREE_TYPE (t))
- return t;
-
- return build_complex_type (tem);
-
- case OFFSET_TYPE:
- case METHOD_TYPE:
- case FUNCTION_TYPE:
- case LANG_TYPE:
- /* Don't know how to do these yet. */
- gcc_unreachable ();
-
- case ARRAY_TYPE:
- {
- tree component = substitute_in_type (TREE_TYPE (t), f, r);
- tree domain = substitute_in_type (TYPE_DOMAIN (t), f, r);
-
- if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
- return t;
-
- new = build_array_type (component, domain);
- TYPE_SIZE (new) = 0;
- TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
- TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
- layout_type (new);
- TYPE_ALIGN (new) = TYPE_ALIGN (t);
- TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
-
- /* If we had bounded the sizes of T by a constant, bound the sizes of
- NEW by the same constant. */
- if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
- TYPE_SIZE (new)
- = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
- TYPE_SIZE (new));
- if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
- TYPE_SIZE_UNIT (new)
- = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
- TYPE_SIZE_UNIT (new));
- return new;
- }
-
- case RECORD_TYPE:
- case UNION_TYPE:
- case QUAL_UNION_TYPE:
- {
- tree field;
- bool changed_field
- = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
- bool field_has_rep = false;
- tree last_field = NULL_TREE;
-
- tree new = copy_type (t);
-
- /* Start out with no fields, make new fields, and chain them
- in. If we haven't actually changed the type of any field,
- discard everything we've done and return the old type. */
-
- TYPE_FIELDS (new) = NULL_TREE;
- TYPE_SIZE (new) = NULL_TREE;
-
- for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
- {
- tree new_field = copy_node (field);
-
- TREE_TYPE (new_field)
- = substitute_in_type (TREE_TYPE (new_field), f, r);
-
- if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
- field_has_rep = true;
- else if (TREE_TYPE (new_field) != TREE_TYPE (field))
- changed_field = true;
-
- /* If this is an internal field and the type of this field is
- a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
- the type just has one element, treat that as the field.
- But don't do this if we are processing a QUAL_UNION_TYPE. */
- if (TREE_CODE (t) != QUAL_UNION_TYPE
- && DECL_INTERNAL_P (new_field)
- && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
- || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
- {
- if (!TYPE_FIELDS (TREE_TYPE (new_field)))
- continue;
-
- if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
- {
- tree next_new_field
- = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
-
- /* Make sure omitting the union doesn't change
- the layout. */
- DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
- new_field = next_new_field;
- }
- }
-
- DECL_CONTEXT (new_field) = new;
- SET_DECL_ORIGINAL_FIELD (new_field,
- (DECL_ORIGINAL_FIELD (field)
- ? DECL_ORIGINAL_FIELD (field) : field));
-
- /* If the size of the old field was set at a constant,
- propagate the size in case the type's size was variable.
- (This occurs in the case of a variant or discriminated
- record with a default size used as a field of another
- record.) */
- DECL_SIZE (new_field)
- = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
- ? DECL_SIZE (field) : NULL_TREE;
- DECL_SIZE_UNIT (new_field)
- = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
- ? DECL_SIZE_UNIT (field) : NULL_TREE;
-
- if (TREE_CODE (t) == QUAL_UNION_TYPE)
- {
- tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
-
- if (new_q != DECL_QUALIFIER (new_field))
- changed_field = true;
-
- /* Do the substitution inside the qualifier and if we find
- that this field will not be present, omit it. */
- DECL_QUALIFIER (new_field) = new_q;
-
- if (integer_zerop (DECL_QUALIFIER (new_field)))
- continue;
- }
-
- if (!last_field)
- TYPE_FIELDS (new) = new_field;
- else
- TREE_CHAIN (last_field) = new_field;
-
- last_field = new_field;
-
- /* If this is a qualified type and this field will always be
- present, we are done. */
- if (TREE_CODE (t) == QUAL_UNION_TYPE
- && integer_onep (DECL_QUALIFIER (new_field)))
- break;
- }
-
- /* If this used to be a qualified union type, but we now know what
- field will be present, make this a normal union. */
- if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
- && (!TYPE_FIELDS (new)
- || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
- TREE_SET_CODE (new, UNION_TYPE);
- else if (!changed_field)
- return t;
-
- gcc_assert (!field_has_rep);
- layout_type (new);
-
- /* If the size was originally a constant use it. */
- if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
- {
- TYPE_SIZE (new) = TYPE_SIZE (t);
- TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
- SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
- }
-
- return new;
- }
-
- default:
- return t;
- }
-}
-\f
-/* Return the "RM size" of GNU_TYPE. This is the actual number of bits
- needed to represent the object. */
-
-tree
-rm_size (tree gnu_type)
-{
- /* For integer types, this is the precision. For record types, we store
- the size explicitly. For other types, this is just the size. */
-
- if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
- return TYPE_RM_SIZE (gnu_type);
- else if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- /* Return the rm_size of the actual data plus the size of the template. */
- return
- size_binop (PLUS_EXPR,
- rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
- DECL_SIZE (TYPE_FIELDS (gnu_type)));
- else if ((TREE_CODE (gnu_type) == RECORD_TYPE
- || TREE_CODE (gnu_type) == UNION_TYPE
- || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (gnu_type)
- && TYPE_ADA_SIZE (gnu_type))
- return TYPE_ADA_SIZE (gnu_type);
- else
- return TYPE_SIZE (gnu_type);
-}
-\f
-/* Return an identifier representing the external name to be used for
- GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
- and the specified suffix. */
-
-tree
-create_concat_name (Entity_Id gnat_entity, const char *suffix)
-{
- Entity_Kind kind = Ekind (gnat_entity);
-
- const char *str = (!suffix ? "" : suffix);
- String_Template temp = {1, strlen (str)};
- Fat_Pointer fp = {str, &temp};
-
- Get_External_Name_With_Suffix (gnat_entity, fp);
-
- /* A variable using the Stdcall convention (meaning we are running
- on a Windows box) live in a DLL. Here we adjust its name to use
- the jump-table, the _imp__NAME contains the address for the NAME
- variable. */
- if ((kind == E_Variable || kind == E_Constant)
- && Has_Stdcall_Convention (gnat_entity))
- {
- const char *prefix = "_imp__";
- int k, plen = strlen (prefix);
-
- for (k = 0; k <= Name_Len; k++)
- Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
- strncpy (Name_Buffer, prefix, plen);
- }
-
- return get_identifier (Name_Buffer);
-}
-
-/* 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. */
-
-tree
-get_entity_name (Entity_Id gnat_entity)
-{
- Get_Encoded_Name (gnat_entity);
- return get_identifier (Name_Buffer);
-}
-
-/* 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. */
-
-tree
-concat_id_with_name (tree gnu_id, const char *suffix)
-{
- int len = IDENTIFIER_LENGTH (gnu_id);
-
- strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), len);
- strncpy (Name_Buffer + len, "___", 3);
- len += 3;
- strcpy (Name_Buffer + len, suffix);
- return get_identifier (Name_Buffer);
-}
-
-#include "gt-ada-decl.h"
+++ /dev/null
-/****************************************************************************
- * *
- * 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;
+++ /dev/null
-/****************************************************************************
- * *
- * 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"
-\f
-/* 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);
+++ /dev/null
-/****************************************************************************
- * *
- * 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},
+++ /dev/null
-; 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.
+++ /dev/null
-/****************************************************************************
- * *
- * 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;
-
-\f
-/* 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 ();
-}
-\f
-/* 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);
-}
-\f
-/* 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 ();
-}
+++ /dev/null
-/****************************************************************************
- * *
- * 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;
-}
+++ /dev/null
-/****************************************************************************
- * *
- * GNAT COMPILER COMPONENTS *
- * *
- * T R A N S *
- * *
- * 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. *
- * *
- * 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 "real.h"
-#include "flags.h"
-#include "toplev.h"
-#include "rtl.h"
-#include "expr.h"
-#include "ggc.h"
-#include "cgraph.h"
-#include "function.h"
-#include "except.h"
-#include "debug.h"
-#include "output.h"
-#include "tree-iterator.h"
-#include "gimple.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"
-#include "adadecode.h"
-
-#include "dwarf2.h"
-#include "dwarf2out.h"
-
-/* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
- for fear of running out of stack space. If we need more, we use xmalloc
- instead. */
-#define ALLOCA_THRESHOLD 1000
-
-/* Let code below know whether we are targetting VMS without need of
- intrusive preprocessor directives. */
-#ifndef TARGET_ABI_OPEN_VMS
-#define TARGET_ABI_OPEN_VMS 0
-#endif
-
-extern char *__gnat_to_canonical_file_spec (char *);
-
-int max_gnat_nodes;
-int number_names;
-int number_files;
-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 *String_Chars_Ptr;
-struct List_Header *List_Headers_Ptr;
-
-/* Current filename without path. */
-const char *ref_filename;
-
-/* 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. */
-bool type_annotate_only;
-
-/* When not optimizing, we cache the 'First, 'Last and 'Length attributes
- of unconstrained array IN parameters to avoid emitting a great deal of
- redundant instructions to recompute them each time. */
-struct parm_attr GTY (())
-{
- int id; /* GTY doesn't like Entity_Id. */
- int dim;
- tree first;
- tree last;
- tree length;
-};
-
-typedef struct parm_attr *parm_attr;
-
-DEF_VEC_P(parm_attr);
-DEF_VEC_ALLOC_P(parm_attr,gc);
-
-struct language_function GTY(())
-{
- VEC(parm_attr,gc) *parm_attr_cache;
-};
-
-#define f_parm_attr_cache \
- DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
-
-/* A structure used to gather together information about a statement group.
- We use this to gather related statements, for example the "then" part
- of a IF. In the case where it represents a lexical scope, we may also
- have a BLOCK node corresponding to it and/or cleanups. */
-
-struct stmt_group GTY((chain_next ("%h.previous"))) {
- struct stmt_group *previous; /* Previous code group. */
- tree stmt_list; /* List of statements for this code group. */
- tree block; /* BLOCK for this code group, if any. */
- tree cleanups; /* Cleanups for this code group, if any. */
-};
-
-static GTY(()) struct stmt_group *current_stmt_group;
-
-/* List of unused struct stmt_group nodes. */
-static GTY((deletable)) struct stmt_group *stmt_group_free_list;
-
-/* A structure used to record information on elaboration procedures
- we've made and need to process.
-
- ??? gnat_node should be Node_Id, but gengtype gets confused. */
-
-struct elab_info GTY((chain_next ("%h.next"))) {
- struct elab_info *next; /* Pointer to next in chain. */
- tree elab_proc; /* Elaboration procedure. */
- int gnat_node; /* The N_Compilation_Unit. */
-};
-
-static GTY(()) struct elab_info *elab_info_list;
-
-/* Free list of TREE_LIST nodes used for stacks. */
-static GTY((deletable)) tree gnu_stack_free_list;
-
-/* List of TREE_LIST nodes representing a stack of exception pointer
- variables. TREE_VALUE is the VAR_DECL that stores the address of
- the raised exception. Nonzero means we are in an exception
- handler. Not used in the zero-cost case. */
-static GTY(()) tree gnu_except_ptr_stack;
-
-/* List of TREE_LIST nodes used to store the current elaboration procedure
- decl. TREE_VALUE is the decl. */
-static GTY(()) tree gnu_elab_proc_stack;
-
-/* Variable that stores a list of labels to be used as a goto target instead of
- a return in some functions. See processing for N_Subprogram_Body. */
-static GTY(()) tree gnu_return_label_stack;
-
-/* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
- TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */
-static GTY(()) tree gnu_loop_label_stack;
-
-/* List of TREE_LIST nodes representing labels for switch statements.
- TREE_VALUE of each entry is the label at the end of the switch. */
-static GTY(()) tree gnu_switch_label_stack;
-
-/* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */
-static GTY(()) tree gnu_constraint_error_label_stack;
-static GTY(()) tree gnu_storage_error_label_stack;
-static GTY(()) tree gnu_program_error_label_stack;
-
-/* Map GNAT tree codes to GCC tree codes for simple expressions. */
-static enum tree_code gnu_codes[Number_Node_Kinds];
-
-/* Current node being treated, in case abort called. */
-Node_Id error_gnat_node;
-
-static void init_code_table (void);
-static void Compilation_Unit_to_gnu (Node_Id);
-static void record_code_position (Node_Id);
-static void insert_code_for (Node_Id);
-static void add_cleanup (tree, Node_Id);
-static tree unshare_save_expr (tree *, int *, void *);
-static void add_stmt_list (List_Id);
-static void push_exception_label_stack (tree *, Entity_Id);
-static tree build_stmt_group (List_Id, bool);
-static void push_stack (tree *, tree, tree);
-static void pop_stack (tree *);
-static enum gimplify_status gnat_gimplify_stmt (tree *);
-static void elaborate_all_entities (Node_Id);
-static void process_freeze_entity (Node_Id);
-static void process_inlined_subprograms (Node_Id);
-static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
-static tree emit_range_check (tree, Node_Id);
-static tree emit_index_check (tree, tree, tree, tree);
-static tree emit_check (tree, tree, int);
-static tree convert_with_check (Entity_Id, tree, bool, bool, bool);
-static bool smaller_packable_type_p (tree, tree);
-static bool addressable_p (tree, tree);
-static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
-static tree extract_values (tree, tree);
-static tree pos_to_constructor (Node_Id, tree, Entity_Id);
-static tree maybe_implicit_deref (tree);
-static tree gnat_stabilize_reference (tree, bool);
-static tree gnat_stabilize_reference_1 (tree, bool);
-static void set_expr_location_from_node (tree, Node_Id);
-static int lvalue_required_p (Node_Id, tree, int);
-
-/* Hooks for debug info back-ends, only supported and used in a restricted set
- of configurations. */
-static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED;
-static const char *decode_name (const char *) ATTRIBUTE_UNUSED;
-\f
-/* This is the main program of the back-end. It sets up all the table
- structures and then generates code. */
-
-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 *string_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)
-{
- tree gnu_standard_long_long_float;
- tree gnu_standard_exception_type;
- struct elab_info *info;
- int i;
-
- max_gnat_nodes = max_gnat_node;
- number_names = number_name;
- number_files = number_file;
- Nodes_Ptr = nodes_ptr;
- Next_Node_Ptr = next_node_ptr;
- Prev_Node_Ptr = prev_node_ptr;
- Elists_Ptr = elists_ptr;
- Elmts_Ptr = elmts_ptr;
- Strings_Ptr = strings_ptr;
- String_Chars_Ptr = string_chars_ptr;
- List_Headers_Ptr = list_headers_ptr;
-
- type_annotate_only = (gigi_operating_mode == 1);
-
- for (i = 0; i < number_files; i++)
- {
- /* Use the identifier table to make a permanent copy of the filename as
- the name table gets reallocated after Gigi returns but before all the
- debugging information is output. The __gnat_to_canonical_file_spec
- call translates filenames from pragmas Source_Reference that contain
- host style syntax not understood by gdb. */
- const char *filename
- = IDENTIFIER_POINTER
- (get_identifier
- (__gnat_to_canonical_file_spec
- (Get_Name_String (file_info_ptr[i].File_Name))));
-
- /* We rely on the order isomorphism between files and line maps. */
- gcc_assert ((int) line_table->used == i);
-
- /* We create the line map for a source file at once, with a fixed number
- of columns chosen to avoid jumping over the next power of 2. */
- linemap_add (line_table, LC_ENTER, 0, filename, 1);
- linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
- linemap_position_for_column (line_table, 252 - 1);
- linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
- }
-
- /* Initialize ourselves. */
- init_code_table ();
- init_gnat_to_gnu ();
- gnat_compute_largest_alignment ();
- init_dummy_type ();
-
- /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
- errors. */
- if (type_annotate_only)
- {
- TYPE_SIZE (void_type_node) = bitsize_zero_node;
- TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
- }
-
- /* If the GNU type extensions to DWARF are available, setup the hooks. */
-#if defined (DWARF2_DEBUGGING_INFO) && defined (DWARF2_GNU_TYPE_EXTENSIONS)
- /* We condition the name demangling and the generation of type encoding
- strings on -gdwarf+ and always set descriptive types on. */
- if (use_gnu_debug_info_extensions)
- {
- dwarf2out_set_type_encoding_func (extract_encoding);
- dwarf2out_set_demangle_name_func (decode_name);
- }
- dwarf2out_set_descriptive_type_func (get_parallel_type);
-#endif
-
- /* Enable GNAT stack checking method if needed */
- if (!Stack_Check_Probes_On_Target)
- set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
-
- /* Give names and make TYPE_DECLs for common types. */
- create_type_decl (get_identifier (SIZE_TYPE), sizetype,
- NULL, false, true, Empty);
- create_type_decl (get_identifier ("integer"), integer_type_node,
- NULL, false, true, Empty);
- create_type_decl (get_identifier ("unsigned char"), char_type_node,
- NULL, false, true, Empty);
- create_type_decl (get_identifier ("long integer"), long_integer_type_node,
- NULL, false, true, Empty);
-
- /* Save the type we made for integer as the type for Standard.Integer.
- Then make the rest of the standard types. Note that some of these
- may be subtypes. */
- save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
- false);
-
- gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
- gnu_constraint_error_label_stack
- = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
- gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
- gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
-
- gnu_standard_long_long_float
- = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
- gnu_standard_exception_type
- = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
-
- init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type);
-
- /* Process any Pragma Ident for the main unit. */
-#ifdef ASM_OUTPUT_IDENT
- if (Present (Ident_String (Main_Unit)))
- ASM_OUTPUT_IDENT
- (asm_out_file,
- TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
-#endif
-
- /* If we are using the GCC exception mechanism, let GCC know. */
- if (Exception_Mechanism == Back_End_Exceptions)
- gnat_init_gcc_eh ();
-
- gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
- start_stmt_group ();
- Compilation_Unit_to_gnu (gnat_root);
-
- /* Now see if we have any elaboration procedures to deal with. */
- for (info = elab_info_list; info; info = info->next)
- {
- tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
-
- /* Unshare SAVE_EXPRs between subprograms. These are not unshared by
- the gimplifier for obvious reasons, but it turns out that we need to
- unshare them for the global level because of SAVE_EXPRs made around
- checks for global objects and around allocators for global objects
- of variable size, in order to prevent node sharing in the underlying
- expression. Note that this implicitly assumes that the SAVE_EXPR
- nodes themselves are not shared between subprograms, which would be
- an upstream bug for which we would not change the outcome. */
- walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
-
- /* Process the function as others, but for indicating this is an
- elab proc, to be discarded if empty, then propagate the status
- up to the GNAT tree node. */
- begin_subprog_body (info->elab_proc);
- end_subprog_body (gnu_body, true);
-
- if (empty_body_p (gimple_body (info->elab_proc)))
- Set_Has_No_Elaboration_Code (info->gnat_node, 1);
- }
-
- /* We cannot track the location of errors past this point. */
- error_gnat_node = Empty;
-}
-\f
-/* Return a positive value if an lvalue is required for GNAT_NODE.
- GNU_TYPE is the type that will be used for GNAT_NODE in the
- translated GNU tree. ALIASED indicates whether the underlying
- object represented by GNAT_NODE is aliased in the Ada sense.
-
- The function climbs up the GNAT tree starting from the node and
- returns 1 upon encountering a node that effectively requires an
- lvalue downstream. It returns int instead of bool to facilitate
- usage in non purely binary logic contexts. */
-
-static int
-lvalue_required_p (Node_Id gnat_node, tree gnu_type, int aliased)
-{
- Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
-
- switch (Nkind (gnat_parent))
- {
- case N_Reference:
- return 1;
-
- case N_Attribute_Reference:
- {
- unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_parent));
- return id == Attr_Address
- || id == Attr_Access
- || id == Attr_Unchecked_Access
- || id == Attr_Unrestricted_Access;
- }
-
- case N_Parameter_Association:
- case N_Function_Call:
- case N_Procedure_Call_Statement:
- return (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type));
-
- case N_Indexed_Component:
- /* Only the array expression can require an lvalue. */
- if (Prefix (gnat_parent) != gnat_node)
- return 0;
-
- /* ??? Consider that referencing an indexed component with a
- non-constant index forces the whole aggregate to memory.
- Note that N_Integer_Literal is conservative, any static
- expression in the RM sense could probably be accepted. */
- for (gnat_temp = First (Expressions (gnat_parent));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- if (Nkind (gnat_temp) != N_Integer_Literal)
- return 1;
-
- /* ... fall through ... */
-
- case N_Slice:
- /* Only the array expression can require an lvalue. */
- if (Prefix (gnat_parent) != gnat_node)
- return 0;
-
- aliased |= Has_Aliased_Components (Etype (gnat_node));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
-
- case N_Selected_Component:
- aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
-
- case N_Object_Renaming_Declaration:
- /* We need to make a real renaming only if the constant object is
- aliased or if we may use a renaming pointer; otherwise we can
- optimize and return the rvalue. We make an exception if the object
- is an identifier since in this case the rvalue can be propagated
- attached to the CONST_DECL. */
- return (aliased != 0
- /* This should match the constant case of the renaming code. */
- || Is_Composite_Type (Etype (Name (gnat_parent)))
- || Nkind (Name (gnat_parent)) == N_Identifier);
-
- default:
- return 0;
- }
-
- gcc_unreachable ();
-}
-
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
- to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
- to where we should place the result type. */
-
-static tree
-Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
-{
- Node_Id gnat_temp, gnat_temp_type;
- tree gnu_result, gnu_result_type;
-
- /* Whether we should require an lvalue for GNAT_NODE. Needed in
- specific circumstances only, so evaluated lazily. < 0 means
- unknown, > 0 means known true, 0 means known false. */
- int require_lvalue = -1;
-
- /* If GNAT_NODE is a constant, whether we should use the initialization
- value instead of the constant entity, typically for scalars with an
- address clause when the parent doesn't require an lvalue. */
- bool use_constant_initializer = false;
-
- /* If the Etype of this node does not equal the Etype of the Entity,
- something is wrong with the entity map, probably in generic
- instantiation. However, this does not apply to types. Since we sometime
- have strange Ekind's, just do this test for objects. Also, if the Etype of
- the Entity is private, the Etype of the N_Identifier is allowed to be the
- full type and also we consider a packed array type to be the same as the
- original type. Similarly, a class-wide type is equivalent to a subtype of
- itself. Finally, if the types are Itypes, one may be a copy of the other,
- which is also legal. */
- gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
- ? gnat_node : Entity (gnat_node));
- gnat_temp_type = Etype (gnat_temp);
-
- gcc_assert (Etype (gnat_node) == gnat_temp_type
- || (Is_Packed (gnat_temp_type)
- && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
- || (Is_Class_Wide_Type (Etype (gnat_node)))
- || (IN (Ekind (gnat_temp_type), Private_Kind)
- && Present (Full_View (gnat_temp_type))
- && ((Etype (gnat_node) == Full_View (gnat_temp_type))
- || (Is_Packed (Full_View (gnat_temp_type))
- && (Etype (gnat_node)
- == Packed_Array_Type (Full_View
- (gnat_temp_type))))))
- || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
- || !(Ekind (gnat_temp) == E_Variable
- || Ekind (gnat_temp) == E_Component
- || Ekind (gnat_temp) == E_Constant
- || Ekind (gnat_temp) == E_Loop_Parameter
- || IN (Ekind (gnat_temp), Formal_Kind)));
-
- /* If this is a reference to a deferred constant whose partial view is an
- unconstrained private type, the proper type is on the full view of the
- constant, not on the full view of the type, which may be unconstrained.
-
- This may be a reference to a type, for example in the prefix of the
- attribute Position, generated for dispatching code (see Make_DT in
- exp_disp,adb). In that case we need the type itself, not is parent,
- in particular if it is a derived type */
- if (Is_Private_Type (gnat_temp_type)
- && Has_Unknown_Discriminants (gnat_temp_type)
- && Ekind (gnat_temp) == E_Constant
- && Present (Full_View (gnat_temp)))
- {
- gnat_temp = Full_View (gnat_temp);
- gnat_temp_type = Etype (gnat_temp);
- }
- else
- {
- /* We want to use the Actual_Subtype if it has already been elaborated,
- otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
- simplify things. */
- if ((Ekind (gnat_temp) == E_Constant
- || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
- && !(Is_Array_Type (Etype (gnat_temp))
- && Present (Packed_Array_Type (Etype (gnat_temp))))
- && Present (Actual_Subtype (gnat_temp))
- && present_gnu_tree (Actual_Subtype (gnat_temp)))
- gnat_temp_type = Actual_Subtype (gnat_temp);
- else
- gnat_temp_type = Etype (gnat_node);
- }
-
- /* Expand the type of this identifier first, in case it is an enumeral
- literal, which only get made when the type is expanded. There is no
- order-of-elaboration issue here. */
- gnu_result_type = get_unpadded_type (gnat_temp_type);
-
- /* If this is a non-imported scalar constant with an address clause,
- retrieve the value instead of a pointer to be dereferenced unless
- an lvalue is required. This is generally more efficient and actually
- required if this is a static expression because it might be used
- in a context where a dereference is inappropriate, such as a case
- statement alternative or a record discriminant. There is no possible
- volatile-ness short-circuit here since Volatile constants must be imported
- per C.6. */
- if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type)
- && !Is_Imported (gnat_temp)
- && Present (Address_Clause (gnat_temp)))
- {
- require_lvalue = lvalue_required_p (gnat_node, gnu_result_type,
- Is_Aliased (gnat_temp));
- use_constant_initializer = !require_lvalue;
- }
-
- if (use_constant_initializer)
- {
- /* If this is a deferred constant, the initializer is attached to
- the full view. */
- if (Present (Full_View (gnat_temp)))
- gnat_temp = Full_View (gnat_temp);
-
- gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
- }
- else
- gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
-
- /* If we are in an exception handler, force this variable into memory to
- ensure optimization does not remove stores that appear redundant but are
- actually needed in case an exception occurs.
-
- ??? Note that we need not do this if the variable is declared within the
- handler, only if it is referenced in the handler and declared in an
- enclosing block, but we have no way of testing that right now.
-
- ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
- here, but it can now be removed by the Tree aliasing machinery if the
- address of the variable is never taken. All we can do is to make the
- variable volatile, which might incur the generation of temporaries just
- to access the memory in some circumstances. This can be avoided for
- variables of non-constant size because they are automatically allocated
- to memory. There might be no way of allocating a proper temporary for
- them in any case. We only do this for SJLJ though. */
- if (TREE_VALUE (gnu_except_ptr_stack)
- && TREE_CODE (gnu_result) == VAR_DECL
- && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
- TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
-
- /* Some objects (such as parameters passed by reference, globals of
- variable size, and renamed objects) actually represent the address
- of the object. In that case, we must do the dereference. Likewise,
- deal with parameters to foreign convention subprograms. */
- if (DECL_P (gnu_result)
- && (DECL_BY_REF_P (gnu_result)
- || (TREE_CODE (gnu_result) == PARM_DECL
- && DECL_BY_COMPONENT_PTR_P (gnu_result))))
- {
- bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
- tree renamed_obj;
-
- if (TREE_CODE (gnu_result) == PARM_DECL
- && DECL_BY_COMPONENT_PTR_P (gnu_result))
- gnu_result
- = build_unary_op (INDIRECT_REF, NULL_TREE,
- convert (build_pointer_type (gnu_result_type),
- gnu_result));
-
- /* If it's a renaming pointer and we are at the right binding level,
- we can reference the renamed object directly, since the renamed
- expression has been protected against multiple evaluations. */
- else if (TREE_CODE (gnu_result) == VAR_DECL
- && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
- && (! DECL_RENAMING_GLOBAL_P (gnu_result)
- || global_bindings_p ()))
- gnu_result = renamed_obj;
-
- /* Return the underlying CST for a CONST_DECL like a few lines below,
- after dereferencing in this case. */
- else if (TREE_CODE (gnu_result) == CONST_DECL)
- gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
- DECL_INITIAL (gnu_result));
-
- else
- gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
-
- TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
- }
-
- /* The GNAT tree has the type of a function as the type of its result. Also
- use the type of the result if the Etype is a subtype which is nominally
- unconstrained. But remove any padding from the resulting type. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
- || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
- {
- gnu_result_type = TREE_TYPE (gnu_result);
- if (TREE_CODE (gnu_result_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_result_type))
- gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
- }
-
- /* If we have a constant declaration and its initializer at hand,
- try to return the latter to avoid the need to call fold in lots
- of places and the need of elaboration code if this Id is used as
- an initializer itself. */
- if (TREE_CONSTANT (gnu_result)
- && DECL_P (gnu_result)
- && DECL_INITIAL (gnu_result))
- {
- tree object
- = (TREE_CODE (gnu_result) == CONST_DECL
- ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result);
-
- /* If there is a corresponding variable, we only want to return
- the CST value if an lvalue is not required. Evaluate this
- now if we have not already done so. */
- if (object && require_lvalue < 0)
- require_lvalue = lvalue_required_p (gnat_node, gnu_result_type,
- Is_Aliased (gnat_temp));
-
- if (!object || !require_lvalue)
- gnu_result = unshare_expr (DECL_INITIAL (gnu_result));
- }
-
- *gnu_result_type_p = gnu_result_type;
- return gnu_result;
-}
-\f
-/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
- any statements we generate. */
-
-static tree
-Pragma_to_gnu (Node_Id gnat_node)
-{
- Node_Id gnat_temp;
- tree gnu_result = alloc_stmt_list ();
-
- /* Check for (and ignore) unrecognized pragma and do nothing if we are just
- annotating types. */
- if (type_annotate_only
- || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
- return gnu_result;
-
- switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))))
- {
- case Pragma_Inspection_Point:
- /* Do nothing at top level: all such variables are already viewable. */
- if (global_bindings_p ())
- break;
-
- for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next (gnat_temp))
- {
- Node_Id gnat_expr = Expression (gnat_temp);
- tree gnu_expr = gnat_to_gnu (gnat_expr);
- int use_address;
- enum machine_mode mode;
- tree asm_constraint = NULL_TREE;
-#ifdef ASM_COMMENT_START
- char *comment;
-#endif
-
- if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
- gnu_expr = TREE_OPERAND (gnu_expr, 0);
-
- /* Use the value only if it fits into a normal register,
- otherwise use the address. */
- mode = TYPE_MODE (TREE_TYPE (gnu_expr));
- use_address = ((GET_MODE_CLASS (mode) != MODE_INT
- && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
- || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
-
- if (use_address)
- gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
-
-#ifdef ASM_COMMENT_START
- comment = concat (ASM_COMMENT_START,
- " inspection point: ",
- Get_Name_String (Chars (gnat_expr)),
- use_address ? " address" : "",
- " is in %0",
- NULL);
- asm_constraint = build_string (strlen (comment), comment);
- free (comment);
-#endif
- gnu_expr = build4 (ASM_EXPR, void_type_node,
- asm_constraint,
- NULL_TREE,
- tree_cons
- (build_tree_list (NULL_TREE,
- build_string (1, "g")),
- gnu_expr, NULL_TREE),
- NULL_TREE);
- ASM_VOLATILE_P (gnu_expr) = 1;
- set_expr_location_from_node (gnu_expr, gnat_node);
- append_to_statement_list (gnu_expr, &gnu_result);
- }
- break;
-
- case Pragma_Optimize:
- switch (Chars (Expression
- (First (Pragma_Argument_Associations (gnat_node)))))
- {
- case Name_Time: case Name_Space:
- if (optimize == 0)
- post_error ("insufficient -O value?", gnat_node);
- break;
-
- case Name_Off:
- if (optimize != 0)
- post_error ("must specify -O0?", gnat_node);
- break;
-
- default:
- gcc_unreachable ();
- }
- break;
-
- case Pragma_Reviewable:
- if (write_symbols == NO_DEBUG)
- post_error ("must specify -g?", gnat_node);
- break;
- }
-
- return gnu_result;
-}
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
- to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
- where we should place the result type. ATTRIBUTE is the attribute ID. */
-
-static tree
-Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
-{
- tree gnu_result = error_mark_node;
- tree gnu_result_type;
- tree gnu_expr;
- bool prefix_unused = false;
- tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
- tree gnu_type = TREE_TYPE (gnu_prefix);
-
- /* If the input is a NULL_EXPR, make a new one. */
- if (TREE_CODE (gnu_prefix) == NULL_EXPR)
- {
- *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
- return build1 (NULL_EXPR, *gnu_result_type_p,
- TREE_OPERAND (gnu_prefix, 0));
- }
-
- switch (attribute)
- {
- case Attr_Pos:
- case Attr_Val:
- /* These are just conversions until since representation clauses for
- enumerations are handled in the front end. */
- {
- bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
-
- gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
- checkp, checkp, true);
- }
- break;
-
- case Attr_Pred:
- case Attr_Succ:
- /* These just add or subject the constant 1. Representation clauses for
- enumerations are handled in the front-end. */
- gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- if (Do_Range_Check (First (Expressions (gnat_node))))
- {
- gnu_expr = protect_multiple_eval (gnu_expr);
- gnu_expr
- = emit_check
- (build_binary_op (EQ_EXPR, integer_type_node,
- gnu_expr,
- attribute == Attr_Pred
- ? TYPE_MIN_VALUE (gnu_result_type)
- : TYPE_MAX_VALUE (gnu_result_type)),
- gnu_expr, CE_Range_Check_Failed);
- }
-
- gnu_result
- = build_binary_op (attribute == Attr_Pred
- ? MINUS_EXPR : PLUS_EXPR,
- gnu_result_type, gnu_expr,
- convert (gnu_result_type, integer_one_node));
- break;
-
- case Attr_Address:
- case Attr_Unrestricted_Access:
- /* Conversions don't change something's address but can cause us to miss
- the COMPONENT_REF case below, so strip them off. */
- gnu_prefix = remove_conversions (gnu_prefix,
- !Must_Be_Byte_Aligned (gnat_node));
-
- /* If we are taking 'Address of an unconstrained object, this is the
- pointer to the underlying array. */
- if (attribute == Attr_Address)
- gnu_prefix = maybe_unconstrained_array (gnu_prefix);
-
- /* If we are building a static dispatch table, we have to honor
- TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
- with the C++ ABI. We do it in the non-static case as well,
- see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
- else if (TARGET_VTABLE_USES_DESCRIPTORS
- && Is_Dispatch_Table_Entity (Etype (gnat_node)))
- {
- tree gnu_field, gnu_list = NULL_TREE, t;
- /* Descriptors can only be built here for top-level functions. */
- bool build_descriptor = (global_bindings_p () != 0);
- int i;
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* If we're not going to build the descriptor, we have to retrieve
- the one which will be built by the linker (or by the compiler
- later if a static chain is requested). */
- if (!build_descriptor)
- {
- gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
- gnu_result = fold_convert (build_pointer_type (gnu_result_type),
- gnu_result);
- gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
- }
-
- for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
- i < TARGET_VTABLE_USES_DESCRIPTORS;
- gnu_field = TREE_CHAIN (gnu_field), i++)
- {
- if (build_descriptor)
- {
- t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
- build_int_cst (NULL_TREE, i));
- TREE_CONSTANT (t) = 1;
- }
- else
- t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
- gnu_field, NULL_TREE);
-
- gnu_list = tree_cons (gnu_field, t, gnu_list);
- }
-
- gnu_result = gnat_build_constructor (gnu_result_type, gnu_list);
- break;
- }
-
- /* ... fall through ... */
-
- case Attr_Access:
- case Attr_Unchecked_Access:
- case Attr_Code_Address:
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result
- = build_unary_op (((attribute == Attr_Address
- || attribute == Attr_Unrestricted_Access)
- && !Must_Be_Byte_Aligned (gnat_node))
- ? ATTR_ADDR_EXPR : ADDR_EXPR,
- gnu_result_type, gnu_prefix);
-
- /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
- don't try to build a trampoline. */
- if (attribute == Attr_Code_Address)
- {
- for (gnu_expr = gnu_result;
- CONVERT_EXPR_P (gnu_expr);
- gnu_expr = TREE_OPERAND (gnu_expr, 0))
- TREE_CONSTANT (gnu_expr) = 1;
-
- if (TREE_CODE (gnu_expr) == ADDR_EXPR)
- TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
- }
-
- /* For other address attributes applied to a nested function,
- find an inner ADDR_EXPR and annotate it so that we can issue
- a useful warning with -Wtrampolines. */
- else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE)
- {
- for (gnu_expr = gnu_result;
- CONVERT_EXPR_P (gnu_expr);
- gnu_expr = TREE_OPERAND (gnu_expr, 0))
- ;
-
- if (TREE_CODE (gnu_expr) == ADDR_EXPR
- && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
- {
- set_expr_location_from_node (gnu_expr, gnat_node);
-
- /* Check that we're not violating the No_Implicit_Dynamic_Code
- restriction. Be conservative if we don't know anything
- about the trampoline strategy for the target. */
- Check_Implicit_Dynamic_Code_Allowed (gnat_node);
- }
- }
- break;
-
- case Attr_Pool_Address:
- {
- tree gnu_obj_type;
- tree gnu_ptr = gnu_prefix;
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* If this is an unconstrained array, we know the object must have been
- allocated with the template in front of the object. So compute the
- template address.*/
- if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
- gnu_ptr
- = convert (build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE
- (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
- gnu_ptr);
-
- gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
- if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
- {
- tree gnu_char_ptr_type = build_pointer_type (char_type_node);
- tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
- tree gnu_byte_offset
- = convert (sizetype,
- size_diffop (size_zero_node, gnu_pos));
- gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
-
- gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
- gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
- gnu_ptr, gnu_byte_offset);
- }
-
- gnu_result = convert (gnu_result_type, gnu_ptr);
- }
- break;
-
- case Attr_Size:
- case Attr_Object_Size:
- case Attr_Value_Size:
- case Attr_Max_Size_In_Storage_Elements:
- gnu_expr = gnu_prefix;
-
- /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
- We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
- while (TREE_CODE (gnu_expr) == NOP_EXPR)
- gnu_expr = TREE_OPERAND (gnu_expr, 0);
-
- gnu_prefix = remove_conversions (gnu_prefix, true);
- prefix_unused = true;
- gnu_type = TREE_TYPE (gnu_prefix);
-
- /* Replace an unconstrained array type with the type of the underlying
- array. We can't do this with a call to maybe_unconstrained_array
- since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
- use the record type that will be used to allocate the object and its
- template. */
- if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
- if (attribute != Attr_Max_Size_In_Storage_Elements)
- gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
- }
-
- /* If we're looking for the size of a field, return the field size.
- Otherwise, if the prefix is an object, or if 'Object_Size or
- 'Max_Size_In_Storage_Elements has been specified, the result is the
- GCC size of the type. Otherwise, the result is the RM_Size of the
- type. */
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
- gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
- else if (TREE_CODE (gnu_prefix) != TYPE_DECL
- || attribute == Attr_Object_Size
- || attribute == Attr_Max_Size_In_Storage_Elements)
- {
- /* If this is a padded type, the GCC size isn't relevant to the
- programmer. Normally, what we want is the RM_Size, which was set
- from the specified size, but if it was not set, we want the size
- of the relevant field. Using the MAX of those two produces the
- right result in all case. Don't use the size of the field if it's
- a self-referential type, since that's never what's wanted. */
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type)
- && TREE_CODE (gnu_expr) == COMPONENT_REF)
- {
- gnu_result = rm_size (gnu_type);
- if (!(CONTAINS_PLACEHOLDER_P
- (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
- gnu_result
- = size_binop (MAX_EXPR, gnu_result,
- DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
- }
- else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
- {
- Node_Id gnat_deref = Prefix (gnat_node);
- Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
- tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
- if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
- && Present (gnat_actual_subtype))
- {
- tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
- gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
- gnu_actual_obj_type, get_identifier ("SIZE"));
- }
-
- gnu_result = TYPE_SIZE (gnu_type);
- }
- else
- gnu_result = TYPE_SIZE (gnu_type);
- }
- else
- gnu_result = rm_size (gnu_type);
-
- gcc_assert (gnu_result);
-
- /* Deal with a self-referential size by returning the maximum size for a
- type and by qualifying the size with the object for 'Size of an
- object. */
- if (CONTAINS_PLACEHOLDER_P (gnu_result))
- {
- if (TREE_CODE (gnu_prefix) != TYPE_DECL)
- gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
- else
- gnu_result = max_size (gnu_result, true);
- }
-
- /* If the type contains a template, subtract its size. */
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- gnu_result = size_binop (MINUS_EXPR, gnu_result,
- DECL_SIZE (TYPE_FIELDS (gnu_type)));
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* Always perform division using unsigned arithmetic as the size cannot
- be negative, but may be an overflowed positive value. This provides
- correct results for sizes up to 512 MB.
-
- ??? Size should be calculated in storage elements directly. */
-
- if (attribute == Attr_Max_Size_In_Storage_Elements)
- gnu_result = convert (sizetype,
- fold_build2 (CEIL_DIV_EXPR, bitsizetype,
- gnu_result, bitsize_unit_node));
- break;
-
- case Attr_Alignment:
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
- gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
-
- gnu_type = TREE_TYPE (gnu_prefix);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- prefix_unused = true;
-
- gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF
- ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))
- : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT);
- break;
-
- case Attr_First:
- case Attr_Last:
- case Attr_Range_Length:
- prefix_unused = true;
-
- if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
- {
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- if (attribute == Attr_First)
- gnu_result = TYPE_MIN_VALUE (gnu_type);
- else if (attribute == Attr_Last)
- gnu_result = TYPE_MAX_VALUE (gnu_type);
- else
- gnu_result
- = build_binary_op
- (MAX_EXPR, get_base_type (gnu_result_type),
- build_binary_op
- (PLUS_EXPR, get_base_type (gnu_result_type),
- build_binary_op (MINUS_EXPR,
- get_base_type (gnu_result_type),
- convert (gnu_result_type,
- TYPE_MAX_VALUE (gnu_type)),
- convert (gnu_result_type,
- TYPE_MIN_VALUE (gnu_type))),
- convert (gnu_result_type, integer_one_node)),
- convert (gnu_result_type, integer_zero_node));
-
- break;
- }
-
- /* ... fall through ... */
-
- case Attr_Length:
- {
- int Dimension = (Present (Expressions (gnat_node))
- ? UI_To_Int (Intval (First (Expressions (gnat_node))))
- : 1), i;
- struct parm_attr *pa = NULL;
- Entity_Id gnat_param = Empty;
-
- /* Make sure any implicit dereference gets done. */
- gnu_prefix = maybe_implicit_deref (gnu_prefix);
- gnu_prefix = maybe_unconstrained_array (gnu_prefix);
- /* We treat unconstrained array In parameters specially. */
- if (Nkind (Prefix (gnat_node)) == N_Identifier
- && !Is_Constrained (Etype (Prefix (gnat_node)))
- && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
- gnat_param = Entity (Prefix (gnat_node));
- gnu_type = TREE_TYPE (gnu_prefix);
- prefix_unused = true;
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
- {
- int ndim;
- tree gnu_type_temp;
-
- for (ndim = 1, gnu_type_temp = gnu_type;
- TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
- ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
- ;
-
- Dimension = ndim + 1 - Dimension;
- }
-
- for (i = 1; i < Dimension; i++)
- gnu_type = TREE_TYPE (gnu_type);
-
- gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
-
- /* When not optimizing, look up the slot associated with the parameter
- and the dimension in the cache and create a new one on failure. */
- if (!optimize && Present (gnat_param))
- {
- for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
- if (pa->id == gnat_param && pa->dim == Dimension)
- break;
-
- if (!pa)
- {
- pa = GGC_CNEW (struct parm_attr);
- pa->id = gnat_param;
- pa->dim = Dimension;
- VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
- }
- }
-
- /* Return the cached expression or build a new one. */
- if (attribute == Attr_First)
- {
- if (pa && pa->first)
- {
- gnu_result = pa->first;
- break;
- }
-
- gnu_result
- = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
- }
-
- else if (attribute == Attr_Last)
- {
- if (pa && pa->last)
- {
- gnu_result = pa->last;
- break;
- }
-
- gnu_result
- = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
- }
-
- else /* attribute == Attr_Range_Length || attribute == Attr_Length */
- {
- if (pa && pa->length)
- {
- gnu_result = pa->length;
- break;
- }
- else
- {
- /* We used to compute the length as max (hb - lb + 1, 0),
- which could overflow for some cases of empty arrays, e.g.
- when lb == index_type'first. We now compute the length as
- (hb < lb) ? 0 : hb - lb + 1, which would only overflow in
- much rarer cases, for extremely large arrays we expect
- never to encounter in practice. In addition, the former
- computation required the use of potentially constraining
- signed arithmetic while the latter doesn't. */
-
- tree gnu_compute_type = get_base_type (gnu_result_type);
-
- tree index_type
- = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
- tree lb
- = convert (gnu_compute_type, TYPE_MIN_VALUE (index_type));
- tree hb
- = convert (gnu_compute_type, TYPE_MAX_VALUE (index_type));
-
- gnu_result
- = build3
- (COND_EXPR, gnu_compute_type,
- build_binary_op (LT_EXPR, gnu_compute_type, hb, lb),
- convert (gnu_compute_type, integer_zero_node),
- build_binary_op
- (PLUS_EXPR, gnu_compute_type,
- build_binary_op (MINUS_EXPR, gnu_compute_type, hb, lb),
- convert (gnu_compute_type, integer_one_node)));
- }
- }
-
- /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
- handling. Note that these attributes could not have been used on
- an unconstrained array type. */
- gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
- gnu_prefix);
-
- /* Cache the expression we have just computed. Since we want to do it
- at runtime, we force the use of a SAVE_EXPR and let the gimplifier
- create the temporary. */
- if (pa)
- {
- gnu_result
- = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
- TREE_SIDE_EFFECTS (gnu_result) = 1;
- if (attribute == Attr_First)
- pa->first = gnu_result;
- else if (attribute == Attr_Last)
- pa->last = gnu_result;
- else
- pa->length = gnu_result;
- }
- break;
- }
-
- case Attr_Bit_Position:
- case Attr_Position:
- case Attr_First_Bit:
- case Attr_Last_Bit:
- case Attr_Bit:
- {
- HOST_WIDE_INT bitsize;
- HOST_WIDE_INT bitpos;
- tree gnu_offset;
- tree gnu_field_bitpos;
- tree gnu_field_offset;
- tree gnu_inner;
- enum machine_mode mode;
- int unsignedp, volatilep;
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_prefix = remove_conversions (gnu_prefix, true);
- prefix_unused = true;
-
- /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
- the result is 0. Don't allow 'Bit on a bare component, though. */
- if (attribute == Attr_Bit
- && TREE_CODE (gnu_prefix) != COMPONENT_REF
- && TREE_CODE (gnu_prefix) != FIELD_DECL)
- {
- gnu_result = integer_zero_node;
- break;
- }
-
- else
- gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
- || (attribute == Attr_Bit_Position
- && TREE_CODE (gnu_prefix) == FIELD_DECL));
-
- get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
- &mode, &unsignedp, &volatilep, false);
-
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
- {
- gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
- gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
-
- for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
- TREE_CODE (gnu_inner) == COMPONENT_REF
- && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
- gnu_inner = TREE_OPERAND (gnu_inner, 0))
- {
- gnu_field_bitpos
- = size_binop (PLUS_EXPR, gnu_field_bitpos,
- bit_position (TREE_OPERAND (gnu_inner, 1)));
- gnu_field_offset
- = size_binop (PLUS_EXPR, gnu_field_offset,
- byte_position (TREE_OPERAND (gnu_inner, 1)));
- }
- }
- else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
- {
- gnu_field_bitpos = bit_position (gnu_prefix);
- gnu_field_offset = byte_position (gnu_prefix);
- }
- else
- {
- gnu_field_bitpos = bitsize_zero_node;
- gnu_field_offset = size_zero_node;
- }
-
- switch (attribute)
- {
- case Attr_Position:
- gnu_result = gnu_field_offset;
- break;
-
- case Attr_First_Bit:
- case Attr_Bit:
- gnu_result = size_int (bitpos % BITS_PER_UNIT);
- break;
-
- case Attr_Last_Bit:
- gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
- gnu_result = size_binop (PLUS_EXPR, gnu_result,
- TYPE_SIZE (TREE_TYPE (gnu_prefix)));
- gnu_result = size_binop (MINUS_EXPR, gnu_result,
- bitsize_one_node);
- break;
-
- case Attr_Bit_Position:
- gnu_result = gnu_field_bitpos;
- break;
- }
-
- /* If this has a PLACEHOLDER_EXPR, qualify it by the object
- we are handling. */
- gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
- break;
- }
-
- case Attr_Min:
- case Attr_Max:
- {
- tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
- tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = build_binary_op (attribute == Attr_Min
- ? MIN_EXPR : MAX_EXPR,
- gnu_result_type, gnu_lhs, gnu_rhs);
- }
- break;
-
- case Attr_Passed_By_Reference:
- gnu_result = size_int (default_pass_by_ref (gnu_type)
- || must_pass_by_ref (gnu_type));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- break;
-
- case Attr_Component_Size:
- if (TREE_CODE (gnu_prefix) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
- gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
-
- gnu_prefix = maybe_implicit_deref (gnu_prefix);
- gnu_type = TREE_TYPE (gnu_prefix);
-
- if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
- gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
-
- while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
- gnu_type = TREE_TYPE (gnu_type);
-
- gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
-
- /* Note this size cannot be self-referential. */
- gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- prefix_unused = true;
- break;
-
- case Attr_Null_Parameter:
- /* This is just a zero cast to the pointer type for
- our prefix and dereferenced. */
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result
- = build_unary_op (INDIRECT_REF, NULL_TREE,
- convert (build_pointer_type (gnu_result_type),
- integer_zero_node));
- TREE_PRIVATE (gnu_result) = 1;
- break;
-
- case Attr_Mechanism_Code:
- {
- int code;
- Entity_Id gnat_obj = Entity (Prefix (gnat_node));
-
- prefix_unused = true;
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- if (Present (Expressions (gnat_node)))
- {
- int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
-
- for (gnat_obj = First_Formal (gnat_obj); i > 1;
- i--, gnat_obj = Next_Formal (gnat_obj))
- ;
- }
-
- code = Mechanism (gnat_obj);
- if (code == Default)
- code = ((present_gnu_tree (gnat_obj)
- && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
- || ((TREE_CODE (get_gnu_tree (gnat_obj))
- == PARM_DECL)
- && (DECL_BY_COMPONENT_PTR_P
- (get_gnu_tree (gnat_obj))))))
- ? By_Reference : By_Copy);
- gnu_result = convert (gnu_result_type, size_int (- code));
- }
- break;
-
- default:
- /* Say we have an unimplemented attribute. Then set the value to be
- returned to be a zero and hope that's something we can convert to the
- type of this attribute. */
- post_error ("unimplemented attribute", gnat_node);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = integer_zero_node;
- break;
- }
-
- /* If this is an attribute where the prefix was unused, force a use of it if
- it has a side-effect. But don't do it if the prefix is just an entity
- name. However, if an access check is needed, we must do it. See second
- example in AARM 11.6(5.e). */
- if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
- && !Is_Entity_Name (Prefix (gnat_node)))
- gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
- gnu_prefix, gnu_result);
-
- *gnu_result_type_p = gnu_result_type;
- return gnu_result;
-}
-\f
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
- to a GCC tree, which is returned. */
-
-static tree
-Case_Statement_to_gnu (Node_Id gnat_node)
-{
- tree gnu_result;
- tree gnu_expr;
- Node_Id gnat_when;
-
- gnu_expr = gnat_to_gnu (Expression (gnat_node));
- gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
-
- /* The range of values in a case statement is determined by the rules in
- RM 5.4(7-9). In almost all cases, this range is represented by the Etype
- of the expression. One exception arises in the case of a simple name that
- is parenthesized. This still has the Etype of the name, but since it is
- not a name, para 7 does not apply, and we need to go to the base type.
- This is the only case where parenthesization affects the dynamic
- semantics (i.e. the range of possible values at runtime that is covered
- by the others alternative.
-
- Another exception is if the subtype of the expression is non-static. In
- that case, we also have to use the base type. */
- if (Paren_Count (Expression (gnat_node)) != 0
- || !Is_OK_Static_Subtype (Underlying_Type
- (Etype (Expression (gnat_node)))))
- gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
-
- /* We build a SWITCH_EXPR that contains the code with interspersed
- CASE_LABEL_EXPRs for each label. */
-
- push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ());
- start_stmt_group ();
- for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
- Present (gnat_when);
- gnat_when = Next_Non_Pragma (gnat_when))
- {
- Node_Id gnat_choice;
- int choices_added = 0;
-
- /* First compile all the different case choices for the current WHEN
- alternative. */
- for (gnat_choice = First (Discrete_Choices (gnat_when));
- Present (gnat_choice); gnat_choice = Next (gnat_choice))
- {
- tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
-
- switch (Nkind (gnat_choice))
- {
- case N_Range:
- gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
- gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
- break;
-
- case N_Subtype_Indication:
- gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
- (Constraint (gnat_choice))));
- gnu_high = gnat_to_gnu (High_Bound (Range_Expression
- (Constraint (gnat_choice))));
- break;
-
- case N_Identifier:
- case N_Expanded_Name:
- /* This represents either a subtype range or a static value of
- some kind; Ekind says which. */
- if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
- {
- tree gnu_type = get_unpadded_type (Entity (gnat_choice));
-
- gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
- gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
- break;
- }
-
- /* ... fall through ... */
-
- case N_Character_Literal:
- case N_Integer_Literal:
- gnu_low = gnat_to_gnu (gnat_choice);
- break;
-
- case N_Others_Choice:
- break;
-
- default:
- gcc_unreachable ();
- }
-
- /* If the case value is a subtype that raises Constraint_Error at
- run-time because of a wrong bound, then gnu_low or gnu_high is
- not transtaleted into an INTEGER_CST. In such a case, we need
- to ensure that the when statement is not added in the tree,
- otherwise it will crash the gimplifier. */
- if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
- && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
- {
- add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
- gnu_low, gnu_high,
- create_artificial_label ()),
- gnat_choice);
- choices_added++;
- }
- }
-
- /* Push a binding level here in case variables are declared as we want
- them to be local to this set of statements instead of to the block
- containing the Case statement. */
- if (choices_added > 0)
- {
- add_stmt (build_stmt_group (Statements (gnat_when), true));
- add_stmt (build1 (GOTO_EXPR, void_type_node,
- TREE_VALUE (gnu_switch_label_stack)));
- }
- }
-
- /* Now emit a definition of the label all the cases branched to. */
- add_stmt (build1 (LABEL_EXPR, void_type_node,
- TREE_VALUE (gnu_switch_label_stack)));
- gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
- end_stmt_group (), NULL_TREE);
- pop_stack (&gnu_switch_label_stack);
-
- return gnu_result;
-}
-\f
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
- to a GCC tree, which is returned. */
-
-static tree
-Loop_Statement_to_gnu (Node_Id gnat_node)
-{
- /* ??? It would be nice to use "build" here, but there's no build5. */
- tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, NULL_TREE);
- tree gnu_loop_var = NULL_TREE;
- Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
- tree gnu_cond_expr = NULL_TREE;
- tree gnu_result;
-
- TREE_TYPE (gnu_loop_stmt) = void_type_node;
- TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
- LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
- set_expr_location_from_node (gnu_loop_stmt, gnat_node);
- Sloc_to_locus (Sloc (End_Label (gnat_node)),
- &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt)));
-
- /* Save the end label of this LOOP_STMT in a stack so that the corresponding
- N_Exit_Statement can find it. */
- push_stack (&gnu_loop_label_stack, NULL_TREE,
- LOOP_STMT_LABEL (gnu_loop_stmt));
-
- /* Set the condition that under which the loop should continue.
- For "LOOP .... END LOOP;" the condition is always true. */
- if (No (gnat_iter_scheme))
- ;
- /* The case "WHILE condition LOOP ..... END LOOP;" */
- else if (Present (Condition (gnat_iter_scheme)))
- LOOP_STMT_TOP_COND (gnu_loop_stmt)
- = gnat_to_gnu (Condition (gnat_iter_scheme));
- else
- {
- /* We have an iteration scheme. */
- Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
- Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
- Entity_Id gnat_type = Etype (gnat_loop_var);
- tree gnu_type = get_unpadded_type (gnat_type);
- tree gnu_low = TYPE_MIN_VALUE (gnu_type);
- tree gnu_high = TYPE_MAX_VALUE (gnu_type);
- bool reversep = Reverse_Present (gnat_loop_spec);
- tree gnu_first = reversep ? gnu_high : gnu_low;
- tree gnu_last = reversep ? gnu_low : gnu_high;
- enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
- tree gnu_base_type = get_base_type (gnu_type);
- tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
- : TYPE_MAX_VALUE (gnu_base_type));
-
- /* We know the loop variable will not overflow if GNU_LAST is a constant
- and is not equal to GNU_LIMIT. If it might overflow, we have to move
- the limit test to the end of the loop. In that case, we have to test
- for an empty loop outside the loop. */
- if (TREE_CODE (gnu_last) != INTEGER_CST
- || TREE_CODE (gnu_limit) != INTEGER_CST
- || tree_int_cst_equal (gnu_last, gnu_limit))
- {
- gnu_cond_expr
- = build3 (COND_EXPR, void_type_node,
- build_binary_op (LE_EXPR, integer_type_node,
- gnu_low, gnu_high),
- NULL_TREE, alloc_stmt_list ());
- set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec);
- }
-
- /* Open a new nesting level that will surround the loop to declare the
- loop index variable. */
- start_stmt_group ();
- gnat_pushlevel ();
-
- /* Declare the loop index and set it to its initial value. */
- gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
- if (DECL_BY_REF_P (gnu_loop_var))
- gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
-
- /* The loop variable might be a padded type, so use `convert' to get a
- reference to the inner variable if so. */
- gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
-
- /* Set either the top or bottom exit condition as appropriate depending
- on whether or not we know an overflow cannot occur. */
- if (gnu_cond_expr)
- LOOP_STMT_BOT_COND (gnu_loop_stmt)
- = build_binary_op (NE_EXPR, integer_type_node,
- gnu_loop_var, gnu_last);
- else
- LOOP_STMT_TOP_COND (gnu_loop_stmt)
- = build_binary_op (end_code, integer_type_node,
- gnu_loop_var, gnu_last);
-
- LOOP_STMT_UPDATE (gnu_loop_stmt)
- = build_binary_op (reversep ? PREDECREMENT_EXPR
- : PREINCREMENT_EXPR,
- TREE_TYPE (gnu_loop_var),
- gnu_loop_var,
- convert (TREE_TYPE (gnu_loop_var),
- integer_one_node));
- set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
- gnat_iter_scheme);
- }
-
- /* If the loop was named, have the name point to this loop. In this case,
- the association is not a ..._DECL node, but the end label from this
- LOOP_STMT. */
- if (Present (Identifier (gnat_node)))
- save_gnu_tree (Entity (Identifier (gnat_node)),
- LOOP_STMT_LABEL (gnu_loop_stmt), true);
-
- /* Make the loop body into its own block, so any allocated storage will be
- released every iteration. This is needed for stack allocation. */
- LOOP_STMT_BODY (gnu_loop_stmt)
- = build_stmt_group (Statements (gnat_node), true);
-
- /* If we declared a variable, then we are in a statement group for that
- declaration. Add the LOOP_STMT to it and make that the "loop". */
- if (gnu_loop_var)
- {
- add_stmt (gnu_loop_stmt);
- gnat_poplevel ();
- gnu_loop_stmt = end_stmt_group ();
- }
-
- /* If we have an outer COND_EXPR, that's our result and this loop is its
- "true" statement. Otherwise, the result is the LOOP_STMT. */
- if (gnu_cond_expr)
- {
- COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
- gnu_result = gnu_cond_expr;
- recalculate_side_effects (gnu_cond_expr);
- }
- else
- gnu_result = gnu_loop_stmt;
-
- pop_stack (&gnu_loop_label_stack);
-
- return gnu_result;
-}
-\f
-/* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
- handler for the current function. */
-
-/* This is implemented by issuing a call to the appropriate VMS specific
- builtin. To avoid having VMS specific sections in the global gigi decls
- array, we maintain the decls of interest here. We can't declare them
- inside the function because we must mark them never to be GC'd, which we
- can only do at the global level. */
-
-static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
-static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
-
-static void
-establish_gnat_vms_condition_handler (void)
-{
- tree establish_stmt;
-
- /* Elaborate the required decls on the first call. Check on the decl for
- the gnat condition handler to decide, as this is one we create so we are
- sure that it will be non null on subsequent calls. The builtin decl is
- looked up so remains null on targets where it is not implemented yet. */
- if (gnat_vms_condition_handler_decl == NULL_TREE)
- {
- vms_builtin_establish_handler_decl
- = builtin_decl_for
- (get_identifier ("__builtin_establish_vms_condition_handler"));
-
- gnat_vms_condition_handler_decl
- = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
- NULL_TREE,
- build_function_type_list (integer_type_node,
- ptr_void_type_node,
- ptr_void_type_node,
- NULL_TREE),
- NULL_TREE, 0, 1, 1, 0, Empty);
- }
-
- /* Do nothing if the establish builtin is not available, which might happen
- on targets where the facility is not implemented. */
- if (vms_builtin_establish_handler_decl == NULL_TREE)
- return;
-
- establish_stmt
- = build_call_1_expr (vms_builtin_establish_handler_decl,
- build_unary_op
- (ADDR_EXPR, NULL_TREE,
- gnat_vms_condition_handler_decl));
-
- add_stmt (establish_stmt);
-}
-\f
-/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
- don't return anything. */
-
-static void
-Subprogram_Body_to_gnu (Node_Id gnat_node)
-{
- /* Defining identifier of a parameter to the subprogram. */
- Entity_Id gnat_param;
- /* The defining identifier for the subprogram body. Note that if a
- specification has appeared before for this body, then the identifier
- occurring in that specification will also be a defining identifier and all
- the calls to this subprogram will point to that specification. */
- Entity_Id gnat_subprog_id
- = (Present (Corresponding_Spec (gnat_node))
- ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
- /* The FUNCTION_DECL node corresponding to the subprogram spec. */
- tree gnu_subprog_decl;
- /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
- tree gnu_subprog_type;
- tree gnu_cico_list;
- tree gnu_result;
- VEC(parm_attr,gc) *cache;
-
- /* If this is a generic object or if it has been eliminated,
- ignore it. */
- if (Ekind (gnat_subprog_id) == E_Generic_Procedure
- || Ekind (gnat_subprog_id) == E_Generic_Function
- || Is_Eliminated (gnat_subprog_id))
- return;
-
- /* If this subprogram acts as its own spec, define it. Otherwise, just get
- the already-elaborated tree node. However, if this subprogram had its
- elaboration deferred, we will already have made a tree node for it. So
- treat it as not being defined in that case. Such a subprogram cannot
- have an address clause or a freeze node, so this test is safe, though it
- does disable some otherwise-useful error checking. */
- gnu_subprog_decl
- = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
- Acts_As_Spec (gnat_node)
- && !present_gnu_tree (gnat_subprog_id));
-
- gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
-
- /* Propagate the debug mode. */
- if (!Needs_Debug_Info (gnat_subprog_id))
- DECL_IGNORED_P (gnu_subprog_decl) = 1;
-
- /* Set the line number in the decl to correspond to that of the body so that
- the line number notes are written correctly. */
- Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
-
- /* Initialize the information structure for the function. */
- allocate_struct_function (gnu_subprog_decl, false);
- DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
- = GGC_CNEW (struct language_function);
-
- begin_subprog_body (gnu_subprog_decl);
- gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
-
- /* If there are Out parameters, we need to ensure that the return statement
- properly copies them out. We do this by making a new block and converting
- any inner return into a goto to a label at the end of the block. */
- push_stack (&gnu_return_label_stack, NULL_TREE,
- gnu_cico_list ? create_artificial_label () : NULL_TREE);
-
- /* Get a tree corresponding to the code for the subprogram. */
- start_stmt_group ();
- gnat_pushlevel ();
-
- /* See if there are any parameters for which we don't yet have GCC entities.
- These must be for Out parameters for which we will be making VAR_DECL
- nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
- entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
- the order of the parameters. */
- for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
- Present (gnat_param);
- gnat_param = Next_Formal_With_Extras (gnat_param))
- if (!present_gnu_tree (gnat_param))
- {
- /* Skip any entries that have been already filled in; they must
- correspond to In Out parameters. */
- for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
- gnu_cico_list = TREE_CHAIN (gnu_cico_list))
- ;
-
- /* Do any needed references for padded types. */
- TREE_VALUE (gnu_cico_list)
- = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
- gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
- }
-
- /* On VMS, establish our condition handler to possibly turn a condition into
- the corresponding exception if the subprogram has a foreign convention or
- is exported.
-
- To ensure proper execution of local finalizations on condition instances,
- we must turn a condition into the corresponding exception even if there
- is no applicable Ada handler, and need at least one condition handler per
- possible call chain involving GNAT code. OTOH, establishing the handler
- has a cost so we want to minimize the number of subprograms into which
- this happens. The foreign or exported condition is expected to satisfy
- all the constraints. */
- if (TARGET_ABI_OPEN_VMS
- && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
- establish_gnat_vms_condition_handler ();
-
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
-
- /* Generate the code of the subprogram itself. A return statement will be
- present and any Out parameters will be handled there. */
- add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
-
- /* If we populated the parameter attributes cache, we need to make sure
- that the cached expressions are evaluated on all possible paths. */
- cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
- if (cache)
- {
- struct parm_attr *pa;
- int i;
-
- start_stmt_group ();
-
- for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
- {
- if (pa->first)
- add_stmt (pa->first);
- if (pa->last)
- add_stmt (pa->last);
- if (pa->length)
- add_stmt (pa->length);
- }
-
- add_stmt (gnu_result);
- gnu_result = end_stmt_group ();
- }
-
- /* If we made a special return label, we need to make a block that contains
- the definition of that label and the copying to the return value. That
- block first contains the function, then the label and copy statement. */
- if (TREE_VALUE (gnu_return_label_stack))
- {
- tree gnu_retval;
-
- start_stmt_group ();
- gnat_pushlevel ();
- add_stmt (gnu_result);
- add_stmt (build1 (LABEL_EXPR, void_type_node,
- TREE_VALUE (gnu_return_label_stack)));
-
- gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
- if (list_length (gnu_cico_list) == 1)
- gnu_retval = TREE_VALUE (gnu_cico_list);
- else
- gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
- gnu_cico_list);
-
- if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
- gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
-
- add_stmt_with_node
- (build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval),
- gnat_node);
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
- }
-
- pop_stack (&gnu_return_label_stack);
-
- /* Set the end location. */
- Sloc_to_locus
- ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
- ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
- : Sloc (gnat_node)),
- &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
-
- end_subprog_body (gnu_result, false);
-
- /* Disconnect the trees for parameters that we made variables for from the
- GNAT entities since these are unusable after we end the function. */
- for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
- Present (gnat_param);
- gnat_param = Next_Formal_With_Extras (gnat_param))
- if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
- save_gnu_tree (gnat_param, NULL_TREE, false);
-
- if (DECL_FUNCTION_STUB (gnu_subprog_decl))
- build_function_stub (gnu_subprog_decl, gnat_subprog_id);
-
- mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
-}
-\f
-/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
- or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
- GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
- If GNU_TARGET is non-null, this must be a function call and the result
- of the call is to be placed into that object. */
-
-static tree
-call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
-{
- tree gnu_result;
- /* The GCC node corresponding to the GNAT subprogram name. This can either
- be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
- or an indirect reference expression (an INDIRECT_REF node) pointing to a
- subprogram. */
- tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
- /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
- tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
- tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_subprog_node);
- Entity_Id gnat_formal;
- Node_Id gnat_actual;
- tree gnu_actual_list = NULL_TREE;
- tree gnu_name_list = NULL_TREE;
- tree gnu_before_list = NULL_TREE;
- tree gnu_after_list = NULL_TREE;
- tree gnu_subprog_call;
-
- switch (Nkind (Name (gnat_node)))
- {
- case N_Identifier:
- case N_Operator_Symbol:
- case N_Expanded_Name:
- case N_Attribute_Reference:
- if (Is_Eliminated (Entity (Name (gnat_node))))
- Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
- }
-
- gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
-
- /* If we are calling a stubbed function, make this into a raise of
- Program_Error. Elaborate all our args first. */
- if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
- && DECL_STUBBED_P (gnu_subprog_node))
- {
- for (gnat_actual = First_Actual (gnat_node);
- Present (gnat_actual);
- gnat_actual = Next_Actual (gnat_actual))
- add_stmt (gnat_to_gnu (gnat_actual));
-
- {
- tree call_expr
- = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node,
- N_Raise_Program_Error);
-
- if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
- {
- *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
- return build1 (NULL_EXPR, *gnu_result_type_p, call_expr);
- }
- else
- return call_expr;
- }
- }
-
- /* If we are calling by supplying a pointer to a target, set up that
- pointer as the first argument. Use GNU_TARGET if one was passed;
- otherwise, make a target by building a variable of the maximum size
- of the type. */
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
- {
- tree gnu_real_ret_type
- = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
-
- if (!gnu_target)
- {
- tree gnu_obj_type
- = maybe_pad_type (gnu_real_ret_type,
- max_size (TYPE_SIZE (gnu_real_ret_type), true),
- 0, Etype (Name (gnat_node)), "PAD", false,
- false, false);
-
- /* ??? We may be about to create a static temporary if we happen to
- be at the global binding level. That's a regression from what
- the 3.x back-end would generate in the same situation, but we
- don't have a mechanism in Gigi for creating automatic variables
- in the elaboration routines. */
- gnu_target
- = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
- NULL, false, false, false, false, NULL,
- gnat_node);
- }
-
- gnu_actual_list
- = tree_cons (NULL_TREE,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- unchecked_convert (gnu_real_ret_type,
- gnu_target,
- false)),
- NULL_TREE);
-
- }
-
- /* The only way we can be making a call via an access type is if Name is an
- explicit dereference. In that case, get the list of formal args from the
- type the access type is pointing to. Otherwise, get the formals from
- entity being called. */
- if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
- gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
- else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
- /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
- gnat_formal = 0;
- else
- gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
-
- /* Create the list of the actual parameters as GCC expects it, namely a chain
- of TREE_LIST nodes in which the TREE_VALUE field of each node is a
- parameter-expression and the TREE_PURPOSE field is null. Skip Out
- parameters not passed by reference and don't need to be copied in. */
- for (gnat_actual = First_Actual (gnat_node);
- Present (gnat_actual);
- gnat_formal = Next_Formal_With_Extras (gnat_formal),
- gnat_actual = Next_Actual (gnat_actual))
- {
- tree gnu_formal
- = (present_gnu_tree (gnat_formal)
- ? get_gnu_tree (gnat_formal) : NULL_TREE);
- tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
- /* We must suppress conversions that can cause the creation of a
- temporary in the Out or In Out case because we need the real
- object in this case, either to pass its address if it's passed
- by reference or as target of the back copy done after the call
- if it uses the copy-in copy-out mechanism. We do it in the In
- case too, except for an unchecked conversion because it alone
- can cause the actual to be misaligned and the addressability
- test is applied to the real object. */
- bool suppress_type_conversion
- = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
- && Ekind (gnat_formal) != E_In_Parameter)
- || (Nkind (gnat_actual) == N_Type_Conversion
- && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
- Node_Id gnat_name = (suppress_type_conversion
- ? Expression (gnat_actual) : gnat_actual);
- tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
- tree gnu_actual;
-
- /* If it's possible we may need to use this expression twice, make sure
- that any side-effects are handled via SAVE_EXPRs. Likewise if we need
- to force side-effects before the call.
- ??? This is more conservative than we need since we don't need to do
- this for pass-by-ref with no conversion. */
- if (Ekind (gnat_formal) != E_In_Parameter)
- gnu_name = gnat_stabilize_reference (gnu_name, true);
-
- /* If we are passing a non-addressable parameter by reference, pass the
- address of a copy. In the Out or In Out case, set up to copy back
- out after the call. */
- if (gnu_formal
- && (DECL_BY_REF_P (gnu_formal)
- || (TREE_CODE (gnu_formal) == PARM_DECL
- && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
- || (DECL_BY_DESCRIPTOR_P (gnu_formal)))))
- && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
- && !addressable_p (gnu_name, gnu_name_type))
- {
- tree gnu_copy = gnu_name, gnu_temp;
-
- /* If the type is by_reference, a copy is not allowed. */
- if (Is_By_Reference_Type (Etype (gnat_formal)))
- post_error
- ("misaligned actual cannot be passed by reference", gnat_actual);
-
- /* For users of Starlet we issue a warning because the
- interface apparently assumes that by-ref parameters
- outlive the procedure invocation. The code still
- will not work as intended, but we cannot do much
- better since other low-level parts of the back-end
- would allocate temporaries at will because of the
- misalignment if we did not do so here. */
- else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
- {
- post_error
- ("?possible violation of implicit assumption", gnat_actual);
- post_error_ne
- ("?made by pragma Import_Valued_Procedure on &", gnat_actual,
- Entity (Name (gnat_node)));
- post_error_ne ("?because of misalignment of &", gnat_actual,
- gnat_formal);
- }
-
- /* Remove any unpadding from the object and reset the copy. */
- if (TREE_CODE (gnu_name) == COMPONENT_REF
- && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
- gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
-
- /* Otherwise convert to the nominal type of the object if it's
- a record type. There are several cases in which we need to
- make the temporary using this type instead of the actual type
- of the object if they are distinct, because the expectations
- of the callee would otherwise not be met:
- - if it's a justified modular type,
- - if the actual type is a smaller packable version of it. */
- else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
- && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
- || smaller_packable_type_p (TREE_TYPE (gnu_name),
- gnu_name_type)))
- gnu_name = convert (gnu_name_type, gnu_name);
-
- /* Make a SAVE_EXPR to both properly account for potential side
- effects and handle the creation of a temporary copy. Special
- code in gnat_gimplify_expr ensures that the same temporary is
- used as the object and copied back after the call if needed. */
- gnu_name = build1 (SAVE_EXPR, TREE_TYPE (gnu_name), gnu_name);
- TREE_SIDE_EFFECTS (gnu_name) = 1;
-
- /* Set up to move the copy back to the original. */
- if (Ekind (gnat_formal) != E_In_Parameter)
- {
- gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
- gnu_name);
- set_expr_location_from_node (gnu_temp, gnat_actual);
- append_to_statement_list (gnu_temp, &gnu_after_list);
- }
- }
-
- /* Start from the real object and build the actual. */
- gnu_actual = gnu_name;
-
- /* If this was a procedure call, we may not have removed any padding.
- So do it here for the part we will use as an input, if any. */
- if (Ekind (gnat_formal) != E_Out_Parameter
- && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
- gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
- gnu_actual);
-
- /* Do any needed conversions for the actual and make sure that it is
- in range of the formal's type. */
- if (suppress_type_conversion)
- {
- /* Put back the conversion we suppressed above in the computation
- of the real object. Note that we treat a conversion between
- aggregate types as if it is an unchecked conversion here. */
- gnu_actual
- = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
- gnu_actual,
- (Nkind (gnat_actual)
- == N_Unchecked_Type_Conversion)
- && No_Truncation (gnat_actual));
-
- if (Ekind (gnat_formal) != E_Out_Parameter
- && Do_Range_Check (gnat_actual))
- gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
- }
- else
- {
- if (Ekind (gnat_formal) != E_Out_Parameter
- && Do_Range_Check (gnat_actual))
- gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
-
- /* We may have suppressed a conversion to the Etype of the actual
- since the parent is a procedure call. So put it back here.
- ??? We use the reverse order compared to the case above because
- of an awkward interaction with the check and actually don't put
- back the conversion at all if a check is emitted. This is also
- done for the conversion to the formal's type just below. */
- if (TREE_CODE (gnu_actual) != SAVE_EXPR)
- gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
- gnu_actual);
- }
-
- if (TREE_CODE (gnu_actual) != SAVE_EXPR)
- gnu_actual = convert (gnu_formal_type, gnu_actual);
-
- /* Unless this is an In parameter, we must remove any justified modular
- building from GNU_NAME to get an lvalue. */
- if (Ekind (gnat_formal) != E_In_Parameter
- && TREE_CODE (gnu_name) == CONSTRUCTOR
- && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
- gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
- gnu_name);
-
- /* If we have not saved a GCC object for the formal, it means it is an
- Out parameter not passed by reference and that does not need to be
- copied in. Otherwise, look at the PARM_DECL to see if it is passed by
- reference. */
- if (gnu_formal
- && TREE_CODE (gnu_formal) == PARM_DECL
- && DECL_BY_REF_P (gnu_formal))
- {
- if (Ekind (gnat_formal) != E_In_Parameter)
- {
- /* In Out or Out parameters passed by reference don't use the
- copy-in copy-out mechanism so the address of the real object
- must be passed to the function. */
- gnu_actual = gnu_name;
-
- /* If we have a padded type, be sure we've removed padding. */
- if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
- && TREE_CODE (gnu_actual) != SAVE_EXPR)
- gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
- gnu_actual);
-
- /* If we have the constructed subtype of an aliased object
- with an unconstrained nominal subtype, the type of the
- actual includes the template, although it is formally
- constrained. So we need to convert it back to the real
- constructed subtype to retrieve the constrained part
- and takes its address. */
- if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
- && TREE_CODE (gnu_actual) != SAVE_EXPR
- && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
- && Is_Array_Type (Etype (gnat_actual)))
- gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
- gnu_actual);
- }
-
- /* The symmetry of the paths to the type of an entity is broken here
- since arguments don't know that they will be passed by ref. */
- gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
- gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
- }
- else if (gnu_formal
- && TREE_CODE (gnu_formal) == PARM_DECL
- && DECL_BY_COMPONENT_PTR_P (gnu_formal))
- {
- gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
- gnu_actual = maybe_implicit_deref (gnu_actual);
- gnu_actual = maybe_unconstrained_array (gnu_actual);
-
- if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_formal_type))
- {
- gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
- gnu_actual = convert (gnu_formal_type, gnu_actual);
- }
-
- /* Take the address of the object and convert to the proper pointer
- type. We'd like to actually compute the address of the beginning
- of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
- possibility that the ARRAY_REF might return a constant and we'd be
- getting the wrong address. Neither approach is exactly correct,
- but this is the most likely to work in all cases. */
- gnu_actual = convert (gnu_formal_type,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_actual));
- }
- else if (gnu_formal
- && TREE_CODE (gnu_formal) == PARM_DECL
- && DECL_BY_DESCRIPTOR_P (gnu_formal))
- {
- /* If arg is 'Null_Parameter, pass zero descriptor. */
- if ((TREE_CODE (gnu_actual) == INDIRECT_REF
- || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
- && TREE_PRIVATE (gnu_actual))
- gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
- integer_zero_node);
- else
- gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
- fill_vms_descriptor (gnu_actual,
- gnat_formal));
- }
- else
- {
- tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
-
- if (Ekind (gnat_formal) != E_In_Parameter)
- gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
-
- if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL)
- continue;
-
- /* If this is 'Null_Parameter, pass a zero even though we are
- dereferencing it. */
- else if (TREE_CODE (gnu_actual) == INDIRECT_REF
- && TREE_PRIVATE (gnu_actual)
- && host_integerp (gnu_actual_size, 1)
- && 0 >= compare_tree_int (gnu_actual_size,
- BITS_PER_WORD))
- gnu_actual
- = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
- convert (gnat_type_for_size
- (tree_low_cst (gnu_actual_size, 1),
- 1),
- integer_zero_node),
- false);
- else
- gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
- }
-
- gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
- }
-
- gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type),
- gnu_subprog_addr,
- nreverse (gnu_actual_list));
- set_expr_location_from_node (gnu_subprog_call, gnat_node);
-
- /* If we return by passing a target, the result is the target after the
- call. We must not emit the call directly here because this might be
- evaluated as part of an expression with conditions to control whether
- the call should be emitted or not. */
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
- {
- /* Conceptually, what we need is a COMPOUND_EXPR with the call followed
- by the target object converted to the proper type. Doing so would
- potentially be very inefficient, however, as this expression might
- end up wrapped into an outer SAVE_EXPR later on, which would incur a
- pointless temporary copy of the whole object.
-
- What we do instead is build a COMPOUND_EXPR returning the address of
- the target, and then dereference. Wrapping the COMPOUND_EXPR into a
- SAVE_EXPR later on then only incurs a pointer copy. */
-
- tree gnu_result_type
- = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
-
- /* Build and return
- (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target] */
-
- tree gnu_target_address
- = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target);
- set_expr_location_from_node (gnu_target_address, gnat_node);
-
- gnu_result
- = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address),
- gnu_subprog_call, gnu_target_address);
-
- gnu_result
- = unchecked_convert (gnu_result_type,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- gnu_result),
- false);
-
- *gnu_result_type_p = gnu_result_type;
- return gnu_result;
- }
-
- /* If it is a function call, the result is the call expression unless
- a target is specified, in which case we copy the result into the target
- and return the assignment statement. */
- else if (Nkind (gnat_node) == N_Function_Call)
- {
- gnu_result = gnu_subprog_call;
-
- /* If the function returns an unconstrained array or by reference,
- we have to de-dereference the pointer. */
- if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
- || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
- gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
-
- if (gnu_target)
- gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_target, gnu_result);
- else
- *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
-
- return gnu_result;
- }
-
- /* If this is the case where the GNAT tree contains a procedure call
- but the Ada procedure has copy in copy out parameters, the special
- parameter passing mechanism must be used. */
- else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
- {
- /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
- in copy out parameters. */
- tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
- int length = list_length (scalar_return_list);
-
- if (length > 1)
- {
- tree gnu_name;
-
- gnu_subprog_call = save_expr (gnu_subprog_call);
- gnu_name_list = nreverse (gnu_name_list);
-
- /* If any of the names had side-effects, ensure they are all
- evaluated before the call. */
- for (gnu_name = gnu_name_list; gnu_name;
- gnu_name = TREE_CHAIN (gnu_name))
- if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
- append_to_statement_list (TREE_VALUE (gnu_name),
- &gnu_before_list);
- }
-
- if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
- gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
- else
- gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
-
- for (gnat_actual = First_Actual (gnat_node);
- Present (gnat_actual);
- gnat_formal = Next_Formal_With_Extras (gnat_formal),
- gnat_actual = Next_Actual (gnat_actual))
- /* If we are dealing with a copy in copy out parameter, we must
- retrieve its value from the record returned in the call. */
- if (!(present_gnu_tree (gnat_formal)
- && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
- && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
- || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
- && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
- || (DECL_BY_DESCRIPTOR_P
- (get_gnu_tree (gnat_formal))))))))
- && Ekind (gnat_formal) != E_In_Parameter)
- {
- /* Get the value to assign to this Out or In Out parameter. It is
- either the result of the function if there is only a single such
- parameter or the appropriate field from the record returned. */
- tree gnu_result
- = length == 1 ? gnu_subprog_call
- : build_component_ref (gnu_subprog_call, NULL_TREE,
- TREE_PURPOSE (scalar_return_list),
- false);
-
- /* If the actual is a conversion, get the inner expression, which
- will be the real destination, and convert the result to the
- type of the actual parameter. */
- tree gnu_actual
- = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
-
- /* If the result is a padded type, remove the padding. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
- gnu_result = convert (TREE_TYPE (TYPE_FIELDS
- (TREE_TYPE (gnu_result))),
- gnu_result);
-
- /* If the actual is a type conversion, the real target object is
- denoted by the inner Expression and we need to convert the
- result to the associated type.
- We also need to convert our gnu assignment target to this type
- if the corresponding GNU_NAME was constructed from the GNAT
- conversion node and not from the inner Expression. */
- if (Nkind (gnat_actual) == N_Type_Conversion)
- {
- gnu_result
- = convert_with_check
- (Etype (Expression (gnat_actual)), gnu_result,
- Do_Overflow_Check (gnat_actual),
- Do_Range_Check (Expression (gnat_actual)),
- Float_Truncate (gnat_actual));
-
- if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
- gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
- }
-
- /* Unchecked conversions as actuals for Out parameters are not
- allowed in user code because they are not variables, but do
- occur in front-end expansions. The associated GNU_NAME is
- always obtained from the inner expression in such cases. */
- else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
- gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
- gnu_result,
- No_Truncation (gnat_actual));
- else
- {
- if (Do_Range_Check (gnat_actual))
- gnu_result = emit_range_check (gnu_result,
- Etype (gnat_actual));
-
- if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
- && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
- gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
- }
-
- gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_actual, gnu_result);
- set_expr_location_from_node (gnu_result, gnat_actual);
- append_to_statement_list (gnu_result, &gnu_before_list);
- scalar_return_list = TREE_CHAIN (scalar_return_list);
- gnu_name_list = TREE_CHAIN (gnu_name_list);
- }
- }
- else
- append_to_statement_list (gnu_subprog_call, &gnu_before_list);
-
- append_to_statement_list (gnu_after_list, &gnu_before_list);
- return gnu_before_list;
-}
-\f
-/* Subroutine of gnat_to_gnu to translate gnat_node, an
- N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
-
-static tree
-Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
-{
- tree gnu_jmpsave_decl = NULL_TREE;
- tree gnu_jmpbuf_decl = NULL_TREE;
- /* If just annotating, ignore all EH and cleanups. */
- bool gcc_zcx = (!type_annotate_only
- && Present (Exception_Handlers (gnat_node))
- && Exception_Mechanism == Back_End_Exceptions);
- bool setjmp_longjmp
- = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
- && Exception_Mechanism == Setjmp_Longjmp);
- bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
- bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
- tree gnu_inner_block; /* The statement(s) for the block itself. */
- tree gnu_result;
- tree gnu_expr;
- Node_Id gnat_temp;
-
- /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
- and we have our own SJLJ mechanism. To call the GCC mechanism, we call
- add_cleanup, and when we leave the binding, end_stmt_group will create
- the TRY_FINALLY_EXPR.
-
- ??? The region level calls down there have been specifically put in place
- for a ZCX context and currently the order in which things are emitted
- (region/handlers) is different from the SJLJ case. Instead of putting
- other calls with different conditions at other places for the SJLJ case,
- it seems cleaner to reorder things for the SJLJ case and generalize the
- condition to make it not ZCX specific.
-
- If there are any exceptions or cleanup processing involved, we need an
- outer statement group (for Setjmp_Longjmp) and binding level. */
- if (binding_for_block)
- {
- start_stmt_group ();
- gnat_pushlevel ();
- }
-
- /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
- area for address of previous buffer. Do this first since we need to have
- the setjmp buf known for any decls in this block. */
- if (setjmp_longjmp)
- {
- gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
- NULL_TREE, jmpbuf_ptr_type,
- build_call_0_expr (get_jmpbuf_decl),
- false, false, false, false, NULL,
- gnat_node);
- DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
-
- /* The __builtin_setjmp receivers will immediately reinstall it. Now
- because of the unstructured form of EH used by setjmp_longjmp, there
- might be forward edges going to __builtin_setjmp receivers on which
- it is uninitialized, although they will never be actually taken. */
- TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
- gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
- NULL_TREE, jmpbuf_type,
- NULL_TREE, false, false, false, false,
- NULL, gnat_node);
- DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
-
- set_block_jmpbuf_decl (gnu_jmpbuf_decl);
-
- /* When we exit this block, restore the saved value. */
- add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
- End_Label (gnat_node));
- }
-
- /* If we are to call a function when exiting this block, add a cleanup
- to the binding level we made above. Note that add_cleanup is FIFO
- so we must register this cleanup after the EH cleanup just above. */
- if (at_end)
- add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
- End_Label (gnat_node));
-
- /* Now build the tree for the declarations and statements inside this block.
- If this is SJLJ, set our jmp_buf as the current buffer. */
- start_stmt_group ();
-
- if (setjmp_longjmp)
- add_stmt (build_call_1_expr (set_jmpbuf_decl,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_jmpbuf_decl)));
-
- if (Present (First_Real_Statement (gnat_node)))
- process_decls (Statements (gnat_node), Empty,
- First_Real_Statement (gnat_node), true, true);
-
- /* Generate code for each statement in the block. */
- for (gnat_temp = (Present (First_Real_Statement (gnat_node))
- ? First_Real_Statement (gnat_node)
- : First (Statements (gnat_node)));
- Present (gnat_temp); gnat_temp = Next (gnat_temp))
- add_stmt (gnat_to_gnu (gnat_temp));
- gnu_inner_block = end_stmt_group ();
-
- /* Now generate code for the two exception models, if either is relevant for
- this block. */
- if (setjmp_longjmp)
- {
- tree *gnu_else_ptr = 0;
- tree gnu_handler;
-
- /* Make a binding level for the exception handling declarations and code
- and set up gnu_except_ptr_stack for the handlers to use. */
- start_stmt_group ();
- gnat_pushlevel ();
-
- push_stack (&gnu_except_ptr_stack, NULL_TREE,
- create_var_decl (get_identifier ("EXCEPT_PTR"),
- NULL_TREE,
- build_pointer_type (except_type_node),
- build_call_0_expr (get_excptr_decl), false,
- false, false, false, NULL, gnat_node));
-
- /* Generate code for each handler. The N_Exception_Handler case does the
- real work and returns a COND_EXPR for each handler, which we chain
- together here. */
- for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
- Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
- {
- gnu_expr = gnat_to_gnu (gnat_temp);
-
- /* If this is the first one, set it as the outer one. Otherwise,
- point the "else" part of the previous handler to us. Then point
- to our "else" part. */
- if (!gnu_else_ptr)
- add_stmt (gnu_expr);
- else
- *gnu_else_ptr = gnu_expr;
-
- gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
- }
-
- /* If none of the exception handlers did anything, re-raise but do not
- defer abortion. */
- gnu_expr = build_call_1_expr (raise_nodefer_decl,
- TREE_VALUE (gnu_except_ptr_stack));
- set_expr_location_from_node (gnu_expr, gnat_node);
-
- if (gnu_else_ptr)
- *gnu_else_ptr = gnu_expr;
- else
- add_stmt (gnu_expr);
-
- /* End the binding level dedicated to the exception handlers and get the
- whole statement group. */
- pop_stack (&gnu_except_ptr_stack);
- gnat_poplevel ();
- gnu_handler = end_stmt_group ();
-
- /* If the setjmp returns 1, we restore our incoming longjmp value and
- then check the handlers. */
- start_stmt_group ();
- add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
- gnu_jmpsave_decl),
- gnat_node);
- add_stmt (gnu_handler);
- gnu_handler = end_stmt_group ();
-
- /* This block is now "if (setjmp) ... <handlers> else <block>". */
- gnu_result = build3 (COND_EXPR, void_type_node,
- (build_call_1_expr
- (setjmp_decl,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_jmpbuf_decl))),
- gnu_handler, gnu_inner_block);
- }
- else if (gcc_zcx)
- {
- tree gnu_handlers;
-
- /* First make a block containing the handlers. */
- start_stmt_group ();
- for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next_Non_Pragma (gnat_temp))
- add_stmt (gnat_to_gnu (gnat_temp));
- gnu_handlers = end_stmt_group ();
-
- /* Now make the TRY_CATCH_EXPR for the block. */
- gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
- gnu_inner_block, gnu_handlers);
- }
- else
- gnu_result = gnu_inner_block;
-
- /* Now close our outer block, if we had to make one. */
- if (binding_for_block)
- {
- add_stmt (gnu_result);
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
- }
-
- return gnu_result;
-}
-\f
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
- to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
- exception handling. */
-
-static tree
-Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
-{
- /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
- an "if" statement to select the proper exceptions. For "Others", exclude
- exceptions where Handled_By_Others is nonzero unless the All_Others flag
- is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
- tree gnu_choice = integer_zero_node;
- tree gnu_body = build_stmt_group (Statements (gnat_node), false);
- Node_Id gnat_temp;
-
- for (gnat_temp = First (Exception_Choices (gnat_node));
- gnat_temp; gnat_temp = Next (gnat_temp))
- {
- tree this_choice;
-
- if (Nkind (gnat_temp) == N_Others_Choice)
- {
- if (All_Others (gnat_temp))
- this_choice = integer_one_node;
- else
- this_choice
- = build_binary_op
- (EQ_EXPR, integer_type_node,
- convert
- (integer_type_node,
- build_component_ref
- (build_unary_op
- (INDIRECT_REF, NULL_TREE,
- TREE_VALUE (gnu_except_ptr_stack)),
- get_identifier ("not_handled_by_others"), NULL_TREE,
- false)),
- integer_zero_node);
- }
-
- else if (Nkind (gnat_temp) == N_Identifier
- || Nkind (gnat_temp) == N_Expanded_Name)
- {
- Entity_Id gnat_ex_id = Entity (gnat_temp);
- tree gnu_expr;
-
- /* Exception may be a renaming. Recover original exception which is
- the one elaborated and registered. */
- if (Present (Renamed_Object (gnat_ex_id)))
- gnat_ex_id = Renamed_Object (gnat_ex_id);
-
- gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
-
- this_choice
- = build_binary_op
- (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
- convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
- build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
-
- /* If this is the distinguished exception "Non_Ada_Error" (and we are
- in VMS mode), also allow a non-Ada exception (a VMS condition) t
- match. */
- if (Is_Non_Ada_Error (Entity (gnat_temp)))
- {
- tree gnu_comp
- = build_component_ref
- (build_unary_op (INDIRECT_REF, NULL_TREE,
- TREE_VALUE (gnu_except_ptr_stack)),
- get_identifier ("lang"), NULL_TREE, false);
-
- this_choice
- = build_binary_op
- (TRUTH_ORIF_EXPR, integer_type_node,
- build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
- build_int_cst (TREE_TYPE (gnu_comp), 'V')),
- this_choice);
- }
- }
- else
- gcc_unreachable ();
-
- gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
- gnu_choice, this_choice);
- }
-
- return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
-}
-\f
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
- to a GCC tree, which is returned. This is the variant for ZCX. */
-
-static tree
-Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
-{
- tree gnu_etypes_list = NULL_TREE;
- tree gnu_expr;
- tree gnu_etype;
- tree gnu_current_exc_ptr;
- tree gnu_incoming_exc_ptr;
- Node_Id gnat_temp;
-
- /* We build a TREE_LIST of nodes representing what exception types this
- handler can catch, with special cases for others and all others cases.
-
- Each exception type is actually identified by a pointer to the exception
- id, or to a dummy object for "others" and "all others".
-
- Care should be taken to ensure that the control flow impact of "others"
- and "all others" is known to GCC. lang_eh_type_covers is doing the trick
- currently. */
- for (gnat_temp = First (Exception_Choices (gnat_node));
- gnat_temp; gnat_temp = Next (gnat_temp))
- {
- if (Nkind (gnat_temp) == N_Others_Choice)
- {
- tree gnu_expr
- = All_Others (gnat_temp) ? all_others_decl : others_decl;
-
- gnu_etype
- = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
- }
- else if (Nkind (gnat_temp) == N_Identifier
- || Nkind (gnat_temp) == N_Expanded_Name)
- {
- Entity_Id gnat_ex_id = Entity (gnat_temp);
-
- /* Exception may be a renaming. Recover original exception which is
- the one elaborated and registered. */
- if (Present (Renamed_Object (gnat_ex_id)))
- gnat_ex_id = Renamed_Object (gnat_ex_id);
-
- gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
- gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
-
- /* The Non_Ada_Error case for VMS exceptions is handled
- by the personality routine. */
- }
- else
- gcc_unreachable ();
-
- /* The GCC interface expects NULL to be passed for catch all handlers, so
- it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
- is integer_zero_node. It would not work, however, because GCC's
- notion of "catch all" is stronger than our notion of "others". Until
- we correctly use the cleanup interface as well, doing that would
- prevent the "all others" handlers from being seen, because nothing
- can be caught beyond a catch all from GCC's point of view. */
- gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
- }
-
- start_stmt_group ();
- gnat_pushlevel ();
-
- /* Expand a call to the begin_handler hook at the beginning of the handler,
- and arrange for a call to the end_handler hook to occur on every possible
- exit path.
-
- The hooks expect a pointer to the low level occurrence. This is required
- for our stack management scheme because a raise inside the handler pushes
- a new occurrence on top of the stack, which means that this top does not
- necessarily match the occurrence this handler was dealing with.
-
- The EXC_PTR_EXPR object references the exception occurrence being
- propagated. Upon handler entry, this is the exception for which the
- handler is triggered. This might not be the case upon handler exit,
- however, as we might have a new occurrence propagated by the handler's
- body, and the end_handler hook called as a cleanup in this context.
-
- We use a local variable to retrieve the incoming value at handler entry
- time, and reuse it to feed the end_handler hook's argument at exit. */
- gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
- gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
- ptr_type_node, gnu_current_exc_ptr,
- false, false, false, false, NULL,
- gnat_node);
-
- add_stmt_with_node (build_call_1_expr (begin_handler_decl,
- gnu_incoming_exc_ptr),
- gnat_node);
- /* ??? We don't seem to have an End_Label at hand to set the location. */
- add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
- Empty);
- add_stmt_list (Statements (gnat_node));
- gnat_poplevel ();
-
- return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
- end_stmt_group ());
-}
-\f
-/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
-
-static void
-Compilation_Unit_to_gnu (Node_Id gnat_node)
-{
- /* Make the decl for the elaboration procedure. */
- bool body_p = (Defining_Entity (Unit (gnat_node)),
- Nkind (Unit (gnat_node)) == N_Package_Body
- || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
- Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
- tree gnu_elab_proc_decl
- = create_subprog_decl
- (create_concat_name (gnat_unit_entity,
- body_p ? "elabb" : "elabs"),
- NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
- gnat_unit_entity);
- struct elab_info *info;
-
- push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
-
- DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
- allocate_struct_function (gnu_elab_proc_decl, false);
- Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
- set_cfun (NULL);
-
- /* For a body, first process the spec if there is one. */
- if (Nkind (Unit (gnat_node)) == N_Package_Body
- || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
- && !Acts_As_Spec (gnat_node)))
- {
- add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
- finalize_from_with_types ();
- }
-
- process_inlined_subprograms (gnat_node);
-
- if (type_annotate_only && gnat_node == Cunit (Main_Unit))
- {
- elaborate_all_entities (gnat_node);
-
- if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
- || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
- || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
- return;
- }
-
- process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
- true, true);
- add_stmt (gnat_to_gnu (Unit (gnat_node)));
-
- /* Process any pragmas and actions following the unit. */
- add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
- add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
- finalize_from_with_types ();
-
- /* Save away what we've made so far and record this potential elaboration
- procedure. */
- info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
- set_current_block_context (gnu_elab_proc_decl);
- gnat_poplevel ();
- DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
- info->next = elab_info_list;
- info->elab_proc = gnu_elab_proc_decl;
- info->gnat_node = gnat_node;
- elab_info_list = info;
-
- /* Generate elaboration code for this unit, if necessary, and say whether
- we did or not. */
- pop_stack (&gnu_elab_proc_stack);
-
- /* Invalidate the global renaming pointers. This is necessary because
- stabilization of the renamed entities may create SAVE_EXPRs which
- have been tied to a specific elaboration routine just above. */
- invalidate_global_renaming_pointers ();
-}
-\f
-/* This function is the driver of the GNAT to GCC tree transformation
- process. It is the entry point of the tree transformer. GNAT_NODE is the
- root of some GNAT tree. Return the root of the corresponding GCC tree.
- If this is an expression, return the GCC equivalent of the expression. If
- it is a statement, return the statement. In the case when called for a
- statement, it may also add statements to the current statement group, in
- which case anything it returns is to be interpreted as occurring after
- anything `it already added. */
-
-tree
-gnat_to_gnu (Node_Id gnat_node)
-{
- bool went_into_elab_proc = false;
- tree gnu_result = error_mark_node; /* Default to no value. */
- tree gnu_result_type = void_type_node;
- tree gnu_expr;
- tree gnu_lhs, gnu_rhs;
- Node_Id gnat_temp;
-
- /* Save node number for error message and set location information. */
- error_gnat_node = gnat_node;
- Sloc_to_locus (Sloc (gnat_node), &input_location);
-
- if (type_annotate_only
- && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call))
- return alloc_stmt_list ();
-
- /* If this node is a non-static subexpression and we are only
- annotating types, make this into a NULL_EXPR. */
- if (type_annotate_only
- && IN (Nkind (gnat_node), N_Subexpr)
- && Nkind (gnat_node) != N_Identifier
- && !Compile_Time_Known_Value (gnat_node))
- return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
- build_call_raise (CE_Range_Check_Failed, gnat_node,
- N_Raise_Constraint_Error));
-
- /* If this is a Statement and we are at top level, it must be part of the
- elaboration procedure, so mark us as being in that procedure and push our
- context.
-
- If we are in the elaboration procedure, check if we are violating a
- No_Elaboration_Code restriction by having a statement there. */
- if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
- && Nkind (gnat_node) != N_Null_Statement)
- || Nkind (gnat_node) == N_Procedure_Call_Statement
- || Nkind (gnat_node) == N_Label
- || Nkind (gnat_node) == N_Implicit_Label_Declaration
- || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
- || ((Nkind (gnat_node) == N_Raise_Constraint_Error
- || Nkind (gnat_node) == N_Raise_Storage_Error
- || Nkind (gnat_node) == N_Raise_Program_Error)
- && (Ekind (Etype (gnat_node)) == E_Void)))
- {
- if (!current_function_decl)
- {
- current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
- start_stmt_group ();
- gnat_pushlevel ();
- went_into_elab_proc = true;
- }
-
- /* Don't check for a possible No_Elaboration_Code restriction violation
- on N_Handled_Sequence_Of_Statements, as we want to signal an error on
- every nested real statement instead. This also avoids triggering
- spurious errors on dummy (empty) sequences created by the front-end
- for package bodies in some cases. */
-
- if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
- && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
- Check_Elaboration_Code_Allowed (gnat_node);
- }
-
- switch (Nkind (gnat_node))
- {
- /********************************/
- /* Chapter 2: Lexical Elements: */
- /********************************/
-
- case N_Identifier:
- case N_Expanded_Name:
- case N_Operator_Symbol:
- case N_Defining_Identifier:
- gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
- break;
-
- case N_Integer_Literal:
- {
- tree gnu_type;
-
- /* Get the type of the result, looking inside any padding and
- justified modular types. Then get the value in that type. */
- gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
- gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
-
- gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
-
- /* If the result overflows (meaning it doesn't fit in its base type),
- abort. We would like to check that the value is within the range
- of the subtype, but that causes problems with subtypes whose usage
- will raise Constraint_Error and with biased representation, so
- we don't. */
- gcc_assert (!TREE_OVERFLOW (gnu_result));
- }
- break;
-
- case N_Character_Literal:
- /* If a Entity is present, it means that this was one of the
- literals in a user-defined character type. In that case,
- just return the value in the CONST_DECL. Otherwise, use the
- character code. In that case, the base type should be an
- INTEGER_TYPE, but we won't bother checking for that. */
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- if (Present (Entity (gnat_node)))
- gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
- else
- gnu_result
- = build_int_cst_type
- (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
- break;
-
- case N_Real_Literal:
- /* If this is of a fixed-point type, the value we want is the
- value of the corresponding integer. */
- if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
- {
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
- gnu_result_type);
- gcc_assert (!TREE_OVERFLOW (gnu_result));
- }
-
- /* We should never see a Vax_Float type literal, since the front end
- is supposed to transform these using appropriate conversions */
- else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
- gcc_unreachable ();
-
- else
- {
- Ureal ur_realval = Realval (gnat_node);
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* If the real value is zero, so is the result. Otherwise,
- convert it to a machine number if it isn't already. That
- forces BASE to 0 or 2 and simplifies the rest of our logic. */
- if (UR_Is_Zero (ur_realval))
- gnu_result = convert (gnu_result_type, integer_zero_node);
- else
- {
- if (!Is_Machine_Number (gnat_node))
- ur_realval
- = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
- ur_realval, Round_Even, gnat_node);
-
- gnu_result
- = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
-
- /* If we have a base of zero, divide by the denominator.
- Otherwise, the base must be 2 and we scale the value, which
- we know can fit in the mantissa of the type (hence the use
- of that type above). */
- if (No (Rbase (ur_realval)))
- gnu_result
- = build_binary_op (RDIV_EXPR,
- get_base_type (gnu_result_type),
- gnu_result,
- UI_To_gnu (Denominator (ur_realval),
- gnu_result_type));
- else
- {
- REAL_VALUE_TYPE tmp;
-
- gcc_assert (Rbase (ur_realval) == 2);
- real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
- - UI_To_Int (Denominator (ur_realval)));
- gnu_result = build_real (gnu_result_type, tmp);
- }
- }
-
- /* Now see if we need to negate the result. Do it this way to
- properly handle -0. */
- if (UR_Is_Negative (Realval (gnat_node)))
- gnu_result
- = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
- gnu_result);
- }
-
- break;
-
- case N_String_Literal:
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
- {
- String_Id gnat_string = Strval (gnat_node);
- int length = String_Length (gnat_string);
- int i;
- char *string;
- if (length >= ALLOCA_THRESHOLD)
- string = XNEWVEC (char, length + 1); /* in case of large strings */
- else
- string = (char *) alloca (length + 1);
-
- /* Build the string with the characters in the literal. Note
- that Ada strings are 1-origin. */
- for (i = 0; i < length; i++)
- string[i] = Get_String_Char (gnat_string, i + 1);
-
- /* Put a null at the end of the string in case it's in a context
- where GCC will want to treat it as a C string. */
- string[i] = 0;
-
- gnu_result = build_string (length, string);
-
- /* Strings in GCC don't normally have types, but we want
- this to not be converted to the array type. */
- TREE_TYPE (gnu_result) = gnu_result_type;
-
- if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */
- free (string);
- }
- else
- {
- /* Build a list consisting of each character, then make
- the aggregate. */
- String_Id gnat_string = Strval (gnat_node);
- int length = String_Length (gnat_string);
- int i;
- tree gnu_list = NULL_TREE;
- tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
-
- for (i = 0; i < length; i++)
- {
- gnu_list
- = tree_cons (gnu_idx,
- build_int_cst (TREE_TYPE (gnu_result_type),
- Get_String_Char (gnat_string,
- i + 1)),
- gnu_list);
-
- gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
- 0);
- }
-
- gnu_result
- = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
- }
- break;
-
- case N_Pragma:
- gnu_result = Pragma_to_gnu (gnat_node);
- break;
-
- /**************************************/
- /* Chapter 3: Declarations and Types: */
- /**************************************/
-
- case N_Subtype_Declaration:
- case N_Full_Type_Declaration:
- case N_Incomplete_Type_Declaration:
- case N_Private_Type_Declaration:
- case N_Private_Extension_Declaration:
- case N_Task_Type_Declaration:
- process_type (Defining_Entity (gnat_node));
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Object_Declaration:
- case N_Exception_Declaration:
- gnat_temp = Defining_Entity (gnat_node);
- gnu_result = alloc_stmt_list ();
-
- /* If we are just annotating types and this object has an unconstrained
- or task type, don't elaborate it. */
- if (type_annotate_only
- && (((Is_Array_Type (Etype (gnat_temp))
- || Is_Record_Type (Etype (gnat_temp)))
- && !Is_Constrained (Etype (gnat_temp)))
- || Is_Concurrent_Type (Etype (gnat_temp))))
- break;
-
- if (Present (Expression (gnat_node))
- && !(Nkind (gnat_node) == N_Object_Declaration
- && No_Initialization (gnat_node))
- && (!type_annotate_only
- || Compile_Time_Known_Value (Expression (gnat_node))))
- {
- gnu_expr = gnat_to_gnu (Expression (gnat_node));
- if (Do_Range_Check (Expression (gnat_node)))
- gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
-
- /* If this object has its elaboration delayed, we must force
- evaluation of GNU_EXPR right now and save it for when the object
- is frozen. */
- if (Present (Freeze_Node (gnat_temp)))
- {
- if ((Is_Public (gnat_temp) || global_bindings_p ())
- && !TREE_CONSTANT (gnu_expr))
- gnu_expr
- = create_var_decl (create_concat_name (gnat_temp, "init"),
- NULL_TREE, TREE_TYPE (gnu_expr),
- gnu_expr, false, Is_Public (gnat_temp),
- false, false, NULL, gnat_temp);
- else
- gnu_expr = maybe_variable (gnu_expr);
-
- save_gnu_tree (gnat_node, gnu_expr, true);
- }
- }
- else
- gnu_expr = NULL_TREE;
-
- if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
- gnu_expr = NULL_TREE;
-
- if (No (Freeze_Node (gnat_temp)))
- gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
- break;
-
- case N_Object_Renaming_Declaration:
- gnat_temp = Defining_Entity (gnat_node);
-
- /* Don't do anything if this renaming is handled by the front end or if
- we are just annotating types and this object has a composite or task
- type, don't elaborate it. We return the result in case it has any
- SAVE_EXPRs in it that need to be evaluated here. */
- if (!Is_Renaming_Of_Object (gnat_temp)
- && ! (type_annotate_only
- && (Is_Array_Type (Etype (gnat_temp))
- || Is_Record_Type (Etype (gnat_temp))
- || Is_Concurrent_Type (Etype (gnat_temp)))))
- gnu_result
- = gnat_to_gnu_entity (gnat_temp,
- gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
- else
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Implicit_Label_Declaration:
- gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Exception_Renaming_Declaration:
- case N_Number_Declaration:
- case N_Package_Renaming_Declaration:
- case N_Subprogram_Renaming_Declaration:
- /* These are fully handled in the front end. */
- gnu_result = alloc_stmt_list ();
- break;
-
- /*************************************/
- /* Chapter 4: Names and Expressions: */
- /*************************************/
-
- case N_Explicit_Dereference:
- gnu_result = gnat_to_gnu (Prefix (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
- break;
-
- case N_Indexed_Component:
- {
- tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
- tree gnu_type;
- int ndim;
- int i;
- Node_Id *gnat_expr_array;
-
- gnu_array_object = maybe_implicit_deref (gnu_array_object);
- gnu_array_object = maybe_unconstrained_array (gnu_array_object);
-
- /* If we got a padded type, remove it too. */
- if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
- gnu_array_object
- = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
- gnu_array_object);
-
- gnu_result = gnu_array_object;
-
- /* First compute the number of dimensions of the array, then
- fill the expression array, the order depending on whether
- this is a Convention_Fortran array or not. */
- for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
- TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
- ndim++, gnu_type = TREE_TYPE (gnu_type))
- ;
-
- gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
-
- if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
- for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
- i >= 0;
- i--, gnat_temp = Next (gnat_temp))
- gnat_expr_array[i] = gnat_temp;
- else
- for (i = 0, gnat_temp = First (Expressions (gnat_node));
- i < ndim;
- i++, gnat_temp = Next (gnat_temp))
- gnat_expr_array[i] = gnat_temp;
-
- for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
- i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
- {
- gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
- gnat_temp = gnat_expr_array[i];
- gnu_expr = gnat_to_gnu (gnat_temp);
-
- if (Do_Range_Check (gnat_temp))
- gnu_expr
- = emit_index_check
- (gnu_array_object, gnu_expr,
- TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
- TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
-
- gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
- gnu_result, gnu_expr);
- }
- }
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- break;
-
- case N_Slice:
- {
- tree gnu_type;
- Node_Id gnat_range_node = Discrete_Range (gnat_node);
-
- gnu_result = gnat_to_gnu (Prefix (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* Do any implicit dereferences of the prefix and do any needed
- range check. */
- gnu_result = maybe_implicit_deref (gnu_result);
- gnu_result = maybe_unconstrained_array (gnu_result);
- gnu_type = TREE_TYPE (gnu_result);
- if (Do_Range_Check (gnat_range_node))
- {
- /* Get the bounds of the slice. */
- tree gnu_index_type
- = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
- tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
- tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
- /* Get the permitted bounds. */
- tree gnu_base_index_type
- = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
- tree gnu_base_min_expr = TYPE_MIN_VALUE (gnu_base_index_type);
- tree gnu_base_max_expr = TYPE_MAX_VALUE (gnu_base_index_type);
- tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
-
- /* Check to see that the minimum slice value is in range. */
- gnu_expr_l = emit_index_check (gnu_result,
- gnu_min_expr,
- gnu_base_min_expr,
- gnu_base_max_expr);
-
- /* Check to see that the maximum slice value is in range. */
- gnu_expr_h = emit_index_check (gnu_result,
- gnu_max_expr,
- gnu_base_min_expr,
- gnu_base_max_expr);
-
- /* Derive a good type to convert everything to. */
- gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
-
- /* Build a compound expression that does the range checks and
- returns the low bound. */
- gnu_expr = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
- convert (gnu_expr_type, gnu_expr_h),
- convert (gnu_expr_type, gnu_expr_l));
-
- /* Build a conditional expression that does the range check and
- returns the low bound if the slice is not empty (max >= min),
- and returns the naked low bound otherwise (max < min), unless
- it is non-constant and the high bound is; this prevents VRP
- from inferring bogus ranges on the unlikely path. */
- gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
- build_binary_op (GE_EXPR, gnu_expr_type,
- convert (gnu_expr_type,
- gnu_max_expr),
- convert (gnu_expr_type,
- gnu_min_expr)),
- gnu_expr,
- TREE_CODE (gnu_min_expr) != INTEGER_CST
- && TREE_CODE (gnu_max_expr) == INTEGER_CST
- ? gnu_max_expr : gnu_min_expr);
- }
- else
- /* Simply return the naked low bound. */
- gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
-
- gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
- gnu_result, gnu_expr);
- }
- break;
-
- case N_Selected_Component:
- {
- tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
- Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
- Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
- tree gnu_field;
-
- while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
- || IN (Ekind (gnat_pref_type), Access_Kind))
- {
- if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
- gnat_pref_type = Underlying_Type (gnat_pref_type);
- else if (IN (Ekind (gnat_pref_type), Access_Kind))
- gnat_pref_type = Designated_Type (gnat_pref_type);
- }
-
- gnu_prefix = maybe_implicit_deref (gnu_prefix);
-
- /* For discriminant references in tagged types always substitute the
- corresponding discriminant as the actual selected component. */
-
- if (Is_Tagged_Type (gnat_pref_type))
- while (Present (Corresponding_Discriminant (gnat_field)))
- gnat_field = Corresponding_Discriminant (gnat_field);
-
- /* For discriminant references of untagged types always substitute the
- corresponding stored discriminant. */
-
- else if (Present (Corresponding_Discriminant (gnat_field)))
- gnat_field = Original_Record_Component (gnat_field);
-
- /* Handle extracting the real or imaginary part of a complex.
- The real part is the first field and the imaginary the last. */
-
- if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
- gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
- ? REALPART_EXPR : IMAGPART_EXPR,
- NULL_TREE, gnu_prefix);
- else
- {
- gnu_field = gnat_to_gnu_field_decl (gnat_field);
-
- /* If there are discriminants, the prefix might be
- evaluated more than once, which is a problem if it has
- side-effects. */
- if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
- ? Designated_Type (Etype
- (Prefix (gnat_node)))
- : Etype (Prefix (gnat_node))))
- gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
-
- gnu_result
- = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
- (Nkind (Parent (gnat_node))
- == N_Attribute_Reference));
- }
-
- gcc_assert (gnu_result);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- }
- break;
-
- case N_Attribute_Reference:
- {
- /* The attribute designator (like an enumeration value). */
- int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
-
- /* The Elab_Spec and Elab_Body attributes are special in that
- Prefix is a unit, not an object with a GCC equivalent. Similarly
- for Elaborated, since that variable isn't otherwise known. */
- if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
- return (create_subprog_decl
- (create_concat_name (Entity (Prefix (gnat_node)),
- attribute == Attr_Elab_Body
- ? "elabb" : "elabs"),
- NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
- gnat_node));
-
- gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
- }
- break;
-
- case N_Reference:
- /* Like 'Access as far as we are concerned. */
- gnu_result = gnat_to_gnu (Prefix (gnat_node));
- gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- break;
-
- case N_Aggregate:
- case N_Extension_Aggregate:
- {
- tree gnu_aggr_type;
-
- /* ??? It is wrong to evaluate the type now, but there doesn't
- seem to be any other practical way of doing it. */
-
- gcc_assert (!Expansion_Delayed (gnat_node));
-
- gnu_aggr_type = gnu_result_type
- = get_unpadded_type (Etype (gnat_node));
-
- if (TREE_CODE (gnu_result_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
- gnu_aggr_type
- = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
-
- if (Null_Record_Present (gnat_node))
- gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
-
- else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
- || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
- gnu_result
- = assoc_to_constructor (Etype (gnat_node),
- First (Component_Associations (gnat_node)),
- gnu_aggr_type);
- else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
- gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
- gnu_aggr_type,
- Component_Type (Etype (gnat_node)));
- else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
- gnu_result
- = build_binary_op
- (COMPLEX_EXPR, gnu_aggr_type,
- gnat_to_gnu (Expression (First
- (Component_Associations (gnat_node)))),
- gnat_to_gnu (Expression
- (Next
- (First (Component_Associations (gnat_node))))));
- else
- gcc_unreachable ();
-
- gnu_result = convert (gnu_result_type, gnu_result);
- }
- break;
-
- case N_Null:
- if (TARGET_VTABLE_USES_DESCRIPTORS
- && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
- && Is_Dispatch_Table_Entity (Etype (gnat_node)))
- gnu_result = null_fdesc_node;
- else
- gnu_result = null_pointer_node;
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- break;
-
- case N_Type_Conversion:
- case N_Qualified_Expression:
- /* Get the operand expression. */
- gnu_result = gnat_to_gnu (Expression (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- gnu_result
- = convert_with_check (Etype (gnat_node), gnu_result,
- Do_Overflow_Check (gnat_node),
- Do_Range_Check (Expression (gnat_node)),
- Nkind (gnat_node) == N_Type_Conversion
- && Float_Truncate (gnat_node));
- break;
-
- case N_Unchecked_Type_Conversion:
- gnu_result = gnat_to_gnu (Expression (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* If the result is a pointer type, see if we are improperly
- converting to a stricter alignment. */
- if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
- && IN (Ekind (Etype (gnat_node)), Access_Kind))
- {
- unsigned int align = known_alignment (gnu_result);
- tree gnu_obj_type = TREE_TYPE (gnu_result_type);
- unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
-
- if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
- post_error_ne_tree_2
- ("?source alignment (^) '< alignment of & (^)",
- gnat_node, Designated_Type (Etype (gnat_node)),
- size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
- }
-
- /* If we are converting a descriptor to a function pointer, first
- build the pointer. */
- if (TARGET_VTABLE_USES_DESCRIPTORS
- && TREE_TYPE (gnu_result) == fdesc_type_node
- && POINTER_TYPE_P (gnu_result_type))
- gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
-
- gnu_result = unchecked_convert (gnu_result_type, gnu_result,
- No_Truncation (gnat_node));
- break;
-
- case N_In:
- case N_Not_In:
- {
- tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
- Node_Id gnat_range = Right_Opnd (gnat_node);
- tree gnu_low;
- tree gnu_high;
-
- /* GNAT_RANGE is either an N_Range node or an identifier
- denoting a subtype. */
- if (Nkind (gnat_range) == N_Range)
- {
- gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
- gnu_high = gnat_to_gnu (High_Bound (gnat_range));
- }
- else if (Nkind (gnat_range) == N_Identifier
- || Nkind (gnat_range) == N_Expanded_Name)
- {
- tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
-
- gnu_low = TYPE_MIN_VALUE (gnu_range_type);
- gnu_high = TYPE_MAX_VALUE (gnu_range_type);
- }
- else
- gcc_unreachable ();
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* If LOW and HIGH are identical, perform an equality test.
- Otherwise, ensure that GNU_OBJECT is only evaluated once
- and perform a full range test. */
- if (operand_equal_p (gnu_low, gnu_high, 0))
- gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
- gnu_object, gnu_low);
- else
- {
- gnu_object = protect_multiple_eval (gnu_object);
- gnu_result
- = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
- build_binary_op (GE_EXPR, gnu_result_type,
- gnu_object, gnu_low),
- build_binary_op (LE_EXPR, gnu_result_type,
- gnu_object, gnu_high));
- }
-
- if (Nkind (gnat_node) == N_Not_In)
- gnu_result = invert_truthvalue (gnu_result);
- }
- break;
-
- case N_Op_Divide:
- gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
- gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
- ? RDIV_EXPR
- : (Rounded_Result (gnat_node)
- ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
- gnu_result_type, gnu_lhs, gnu_rhs);
- break;
-
- case N_Op_Or: case N_Op_And: case N_Op_Xor:
- /* These can either be operations on booleans or on modular types.
- Fall through for boolean types since that's the way GNU_CODES is
- set up. */
- if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
- Modular_Integer_Kind))
- {
- enum tree_code code
- = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
- : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
- : BIT_XOR_EXPR);
-
- gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
- gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = build_binary_op (code, gnu_result_type,
- gnu_lhs, gnu_rhs);
- break;
- }
-
- /* ... fall through ... */
-
- case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
- case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
- case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
- case N_Op_Mod: case N_Op_Rem:
- case N_Op_Rotate_Left:
- case N_Op_Rotate_Right:
- case N_Op_Shift_Left:
- case N_Op_Shift_Right:
- case N_Op_Shift_Right_Arithmetic:
- case N_And_Then: case N_Or_Else:
- {
- enum tree_code code = gnu_codes[Nkind (gnat_node)];
- bool ignore_lhs_overflow = false;
- tree gnu_type;
-
- gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
- gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
- gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* If this is a comparison operator, convert any references to
- an unconstrained array value into a reference to the
- actual array. */
- if (TREE_CODE_CLASS (code) == tcc_comparison)
- {
- gnu_lhs = maybe_unconstrained_array (gnu_lhs);
- gnu_rhs = maybe_unconstrained_array (gnu_rhs);
- }
-
- /* If the result type is a private type, its full view may be a
- numeric subtype. The representation we need is that of its base
- type, given that it is the result of an arithmetic operation. */
- else if (Is_Private_Type (Etype (gnat_node)))
- gnu_type = gnu_result_type
- = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
-
- /* If this is a shift whose count is not guaranteed to be correct,
- we need to adjust the shift count. */
- if (IN (Nkind (gnat_node), N_Op_Shift)
- && !Shift_Count_OK (gnat_node))
- {
- tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
- tree gnu_max_shift
- = convert (gnu_count_type, TYPE_SIZE (gnu_type));
-
- if (Nkind (gnat_node) == N_Op_Rotate_Left
- || Nkind (gnat_node) == N_Op_Rotate_Right)
- gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
- gnu_rhs, gnu_max_shift);
- else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
- gnu_rhs
- = build_binary_op
- (MIN_EXPR, gnu_count_type,
- build_binary_op (MINUS_EXPR,
- gnu_count_type,
- gnu_max_shift,
- convert (gnu_count_type,
- integer_one_node)),
- gnu_rhs);
- }
-
- /* For right shifts, the type says what kind of shift to do,
- so we may need to choose a different type. In this case,
- we have to ignore integer overflow lest it propagates all
- the way down and causes a CE to be explicitly raised. */
- if (Nkind (gnat_node) == N_Op_Shift_Right
- && !TYPE_UNSIGNED (gnu_type))
- {
- gnu_type = gnat_unsigned_type (gnu_type);
- ignore_lhs_overflow = true;
- }
- else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
- && TYPE_UNSIGNED (gnu_type))
- {
- gnu_type = gnat_signed_type (gnu_type);
- ignore_lhs_overflow = true;
- }
-
- if (gnu_type != gnu_result_type)
- {
- tree gnu_old_lhs = gnu_lhs;
- gnu_lhs = convert (gnu_type, gnu_lhs);
- if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
- TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
- gnu_rhs = convert (gnu_type, gnu_rhs);
- }
-
- gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
-
- /* If this is a logical shift with the shift count not verified,
- we must return zero if it is too large. We cannot compensate
- above in this case. */
- if ((Nkind (gnat_node) == N_Op_Shift_Left
- || Nkind (gnat_node) == N_Op_Shift_Right)
- && !Shift_Count_OK (gnat_node))
- gnu_result
- = build_cond_expr
- (gnu_type,
- build_binary_op (GE_EXPR, integer_type_node,
- gnu_rhs,
- convert (TREE_TYPE (gnu_rhs),
- TYPE_SIZE (gnu_type))),
- convert (gnu_type, integer_zero_node),
- gnu_result);
- }
- break;
-
- case N_Conditional_Expression:
- {
- tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
- tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
- tree gnu_false
- = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = build_cond_expr (gnu_result_type,
- gnat_truthvalue_conversion (gnu_cond),
- gnu_true, gnu_false);
- }
- break;
-
- case N_Op_Plus:
- gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- break;
-
- case N_Op_Not:
- /* This case can apply to a boolean or a modular type.
- Fall through for a boolean operand since GNU_CODES is set
- up to handle this. */
- if (Is_Modular_Integer_Type (Etype (gnat_node))
- || (Ekind (Etype (gnat_node)) == E_Private_Type
- && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
- {
- gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
- gnu_expr);
- break;
- }
-
- /* ... fall through ... */
-
- case N_Op_Minus: case N_Op_Abs:
- gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
-
- if (Ekind (Etype (gnat_node)) != E_Private_Type)
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- else
- gnu_result_type = get_unpadded_type (Base_Type
- (Full_View (Etype (gnat_node))));
-
- gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
- gnu_result_type, gnu_expr);
- break;
-
- case N_Allocator:
- {
- tree gnu_init = 0;
- tree gnu_type;
- bool ignore_init_type = false;
-
- gnat_temp = Expression (gnat_node);
-
- /* The Expression operand can either be an N_Identifier or
- Expanded_Name, which must represent a type, or a
- N_Qualified_Expression, which contains both the object type and an
- initial value for the object. */
- if (Nkind (gnat_temp) == N_Identifier
- || Nkind (gnat_temp) == N_Expanded_Name)
- gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
- else if (Nkind (gnat_temp) == N_Qualified_Expression)
- {
- Entity_Id gnat_desig_type
- = Designated_Type (Underlying_Type (Etype (gnat_node)));
-
- ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
- gnu_init = gnat_to_gnu (Expression (gnat_temp));
-
- gnu_init = maybe_unconstrained_array (gnu_init);
- if (Do_Range_Check (Expression (gnat_temp)))
- gnu_init = emit_range_check (gnu_init, gnat_desig_type);
-
- if (Is_Elementary_Type (gnat_desig_type)
- || Is_Constrained (gnat_desig_type))
- {
- gnu_type = gnat_to_gnu_type (gnat_desig_type);
- gnu_init = convert (gnu_type, gnu_init);
- }
- else
- {
- gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
- if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
- gnu_type = TREE_TYPE (gnu_init);
-
- gnu_init = convert (gnu_type, gnu_init);
- }
- }
- else
- gcc_unreachable ();
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- return build_allocator (gnu_type, gnu_init, gnu_result_type,
- Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node), gnat_node,
- ignore_init_type);
- }
- break;
-
- /***************************/
- /* Chapter 5: Statements: */
- /***************************/
-
- case N_Label:
- gnu_result = build1 (LABEL_EXPR, void_type_node,
- gnat_to_gnu (Identifier (gnat_node)));
- break;
-
- case N_Null_Statement:
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Assignment_Statement:
- /* Get the LHS and RHS of the statement and convert any reference to an
- unconstrained array into a reference to the underlying array.
- If we are not to do range checking and the RHS is an N_Function_Call,
- pass the LHS to the call function. */
- gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
-
- /* If the type has a size that overflows, convert this into raise of
- Storage_Error: execution shouldn't have gotten here anyway. */
- if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
- && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
- gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
- N_Raise_Storage_Error);
- else if (Nkind (Expression (gnat_node)) == N_Function_Call
- && !Do_Range_Check (Expression (gnat_node)))
- gnu_result = call_to_gnu (Expression (gnat_node),
- &gnu_result_type, gnu_lhs);
- else
- {
- gnu_rhs
- = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
-
- /* If range check is needed, emit code to generate it */
- if (Do_Range_Check (Expression (gnat_node)))
- gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
-
- gnu_result
- = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
- }
- break;
-
- case N_If_Statement:
- {
- tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
-
- /* Make the outer COND_EXPR. Avoid non-determinism. */
- gnu_result = build3 (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_node)),
- NULL_TREE, NULL_TREE);
- COND_EXPR_THEN (gnu_result)
- = build_stmt_group (Then_Statements (gnat_node), false);
- TREE_SIDE_EFFECTS (gnu_result) = 1;
- gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
-
- /* Now make a COND_EXPR for each of the "else if" parts. Put each
- into the previous "else" part and point to where to put any
- outer "else". Also avoid non-determinism. */
- if (Present (Elsif_Parts (gnat_node)))
- for (gnat_temp = First (Elsif_Parts (gnat_node));
- Present (gnat_temp); gnat_temp = Next (gnat_temp))
- {
- gnu_expr = build3 (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_temp)),
- NULL_TREE, NULL_TREE);
- COND_EXPR_THEN (gnu_expr)
- = build_stmt_group (Then_Statements (gnat_temp), false);
- TREE_SIDE_EFFECTS (gnu_expr) = 1;
- set_expr_location_from_node (gnu_expr, gnat_temp);
- *gnu_else_ptr = gnu_expr;
- gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
- }
-
- *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
- }
- break;
-
- case N_Case_Statement:
- gnu_result = Case_Statement_to_gnu (gnat_node);
- break;
-
- case N_Loop_Statement:
- gnu_result = Loop_Statement_to_gnu (gnat_node);
- break;
-
- case N_Block_Statement:
- start_stmt_group ();
- gnat_pushlevel ();
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
- add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
-
- if (Present (Identifier (gnat_node)))
- mark_out_of_scope (Entity (Identifier (gnat_node)));
- break;
-
- case N_Exit_Statement:
- gnu_result
- = build2 (EXIT_STMT, void_type_node,
- (Present (Condition (gnat_node))
- ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
- (Present (Name (gnat_node))
- ? get_gnu_tree (Entity (Name (gnat_node)))
- : TREE_VALUE (gnu_loop_label_stack)));
- break;
-
- case N_Return_Statement:
- {
- /* The gnu function type of the subprogram currently processed. */
- tree gnu_subprog_type = TREE_TYPE (current_function_decl);
- /* The return value from the subprogram. */
- tree gnu_ret_val = NULL_TREE;
- /* The place to put the return value. */
- tree gnu_lhs;
-
- /* If we are dealing with a "return;" from an Ada procedure with
- parameters passed by copy in copy out, we need to return a record
- containing the final values of these parameters. If the list
- contains only one entry, return just that entry.
-
- For a full description of the copy in copy out parameter mechanism,
- see the part of the gnat_to_gnu_entity routine dealing with the
- translation of subprograms.
-
- But if we have a return label defined, convert this into
- a branch to that label. */
-
- if (TREE_VALUE (gnu_return_label_stack))
- {
- gnu_result = build1 (GOTO_EXPR, void_type_node,
- TREE_VALUE (gnu_return_label_stack));
- break;
- }
-
- else if (TYPE_CI_CO_LIST (gnu_subprog_type))
- {
- gnu_lhs = DECL_RESULT (current_function_decl);
- if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
- gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
- else
- gnu_ret_val
- = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
- TYPE_CI_CO_LIST (gnu_subprog_type));
- }
-
- /* If the Ada subprogram is a function, we just need to return the
- expression. If the subprogram returns an unconstrained
- array, we have to allocate a new version of the result and
- return it. If we return by reference, return a pointer. */
-
- else if (Present (Expression (gnat_node)))
- {
- /* If the current function returns by target pointer and we
- are doing a call, pass that target to the call. */
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
- && Nkind (Expression (gnat_node)) == N_Function_Call)
- {
- gnu_lhs
- = build_unary_op (INDIRECT_REF, NULL_TREE,
- DECL_ARGUMENTS (current_function_decl));
- gnu_result = call_to_gnu (Expression (gnat_node),
- &gnu_result_type, gnu_lhs);
- }
- else
- {
- gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
-
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
- /* The original return type was unconstrained so dereference
- the TARGET pointer in the actual return value's type. */
- gnu_lhs
- = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
- DECL_ARGUMENTS (current_function_decl));
- else
- gnu_lhs = DECL_RESULT (current_function_decl);
-
- /* Do not remove the padding from GNU_RET_VAL if the inner
- type is self-referential since we want to allocate the fixed
- size in that case. */
- if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
- && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
- == RECORD_TYPE)
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
- gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
-
- if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
- || By_Ref (gnat_node))
- gnu_ret_val
- = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
-
- else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
- {
- gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
- gnu_ret_val
- = build_allocator (TREE_TYPE (gnu_ret_val),
- gnu_ret_val,
- TREE_TYPE (gnu_subprog_type),
- Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node),
- gnat_node, false);
- }
- }
- }
- else
- /* If the Ada subprogram is a regular procedure, just return. */
- gnu_lhs = NULL_TREE;
-
- if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
- {
- if (gnu_ret_val)
- gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
- gnu_lhs, gnu_ret_val);
- add_stmt_with_node (gnu_result, gnat_node);
- gnu_lhs = NULL_TREE;
- }
-
- gnu_result = build_return_expr (gnu_lhs, gnu_ret_val);
- }
- break;
-
- case N_Goto_Statement:
- gnu_result = build1 (GOTO_EXPR, void_type_node,
- gnat_to_gnu (Name (gnat_node)));
- break;
-
- /****************************/
- /* Chapter 6: Subprograms: */
- /****************************/
-
- case N_Subprogram_Declaration:
- /* Unless there is a freeze node, declare the subprogram. We consider
- this a "definition" even though we're not generating code for
- the subprogram because we will be making the corresponding GCC
- node here. */
-
- if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
- gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
- NULL_TREE, 1);
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Abstract_Subprogram_Declaration:
- /* This subprogram doesn't exist for code generation purposes, but we
- have to elaborate the types of any parameters and result, unless
- they are imported types (nothing to generate in this case). */
-
- /* Process the parameter types first. */
-
- for (gnat_temp
- = First_Formal_With_Extras
- (Defining_Entity (Specification (gnat_node)));
- Present (gnat_temp);
- gnat_temp = Next_Formal_With_Extras (gnat_temp))
- if (Is_Itype (Etype (gnat_temp))
- && !From_With_Type (Etype (gnat_temp)))
- gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
-
-
- /* Then the result type, set to Standard_Void_Type for procedures. */
-
- {
- Entity_Id gnat_temp_type
- = Etype (Defining_Entity (Specification (gnat_node)));
-
- if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
- gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
- }
-
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Defining_Program_Unit_Name:
- /* For a child unit identifier go up a level to get the
- specification. We get this when we try to find the spec of
- a child unit package that is the compilation unit being compiled. */
- gnu_result = gnat_to_gnu (Parent (gnat_node));
- break;
-
- case N_Subprogram_Body:
- Subprogram_Body_to_gnu (gnat_node);
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Function_Call:
- case N_Procedure_Call_Statement:
- gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
- break;
-
- /*************************/
- /* Chapter 7: Packages: */
- /*************************/
-
- case N_Package_Declaration:
- gnu_result = gnat_to_gnu (Specification (gnat_node));
- break;
-
- case N_Package_Specification:
-
- start_stmt_group ();
- process_decls (Visible_Declarations (gnat_node),
- Private_Declarations (gnat_node), Empty, true, true);
- gnu_result = end_stmt_group ();
- break;
-
- case N_Package_Body:
-
- /* If this is the body of a generic package - do nothing */
- if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
- {
- gnu_result = alloc_stmt_list ();
- break;
- }
-
- start_stmt_group ();
- process_decls (Declarations (gnat_node), Empty, Empty, true, true);
-
- if (Present (Handled_Statement_Sequence (gnat_node)))
- add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
-
- gnu_result = end_stmt_group ();
- break;
-
- /*********************************/
- /* Chapter 8: Visibility Rules: */
- /*********************************/
-
- case N_Use_Package_Clause:
- case N_Use_Type_Clause:
- /* Nothing to do here - but these may appear in list of declarations */
- gnu_result = alloc_stmt_list ();
- break;
-
- /***********************/
- /* Chapter 9: Tasks: */
- /***********************/
-
- case N_Protected_Type_Declaration:
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Single_Task_Declaration:
- gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
- gnu_result = alloc_stmt_list ();
- break;
-
- /***********************************************************/
- /* Chapter 10: Program Structure and Compilation Issues: */
- /***********************************************************/
-
- case N_Compilation_Unit:
-
- /* This is not called for the main unit, which is handled in function
- gigi above. */
- start_stmt_group ();
- gnat_pushlevel ();
-
- Compilation_Unit_to_gnu (gnat_node);
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Subprogram_Body_Stub:
- case N_Package_Body_Stub:
- case N_Protected_Body_Stub:
- case N_Task_Body_Stub:
- /* Simply process whatever unit is being inserted. */
- gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
- break;
-
- case N_Subunit:
- gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
- break;
-
- /***************************/
- /* Chapter 11: Exceptions: */
- /***************************/
-
- case N_Handled_Sequence_Of_Statements:
- /* If there is an At_End procedure attached to this node, and the EH
- mechanism is SJLJ, we must have at least a corresponding At_End
- handler, unless the No_Exception_Handlers restriction is set. */
- gcc_assert (type_annotate_only
- || Exception_Mechanism != Setjmp_Longjmp
- || No (At_End_Proc (gnat_node))
- || Present (Exception_Handlers (gnat_node))
- || No_Exception_Handlers_Set ());
-
- gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
- break;
-
- case N_Exception_Handler:
- if (Exception_Mechanism == Setjmp_Longjmp)
- gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
- else if (Exception_Mechanism == Back_End_Exceptions)
- gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
- else
- gcc_unreachable ();
-
- break;
-
- case N_Push_Constraint_Error_Label:
- push_exception_label_stack (&gnu_constraint_error_label_stack,
- Exception_Label (gnat_node));
- break;
-
- case N_Push_Storage_Error_Label:
- push_exception_label_stack (&gnu_storage_error_label_stack,
- Exception_Label (gnat_node));
- break;
-
- case N_Push_Program_Error_Label:
- push_exception_label_stack (&gnu_program_error_label_stack,
- Exception_Label (gnat_node));
- break;
-
- case N_Pop_Constraint_Error_Label:
- gnu_constraint_error_label_stack
- = TREE_CHAIN (gnu_constraint_error_label_stack);
- break;
-
- case N_Pop_Storage_Error_Label:
- gnu_storage_error_label_stack
- = TREE_CHAIN (gnu_storage_error_label_stack);
- break;
-
- case N_Pop_Program_Error_Label:
- gnu_program_error_label_stack
- = TREE_CHAIN (gnu_program_error_label_stack);
- break;
-
- /*******************************/
- /* Chapter 12: Generic Units: */
- /*******************************/
-
- case N_Generic_Function_Renaming_Declaration:
- case N_Generic_Package_Renaming_Declaration:
- case N_Generic_Procedure_Renaming_Declaration:
- case N_Generic_Package_Declaration:
- case N_Generic_Subprogram_Declaration:
- case N_Package_Instantiation:
- case N_Procedure_Instantiation:
- case N_Function_Instantiation:
- /* These nodes can appear on a declaration list but there is nothing to
- to be done with them. */
- gnu_result = alloc_stmt_list ();
- break;
-
- /***************************************************/
- /* Chapter 13: Representation Clauses and */
- /* Implementation-Dependent Features: */
- /***************************************************/
-
- case N_Attribute_Definition_Clause:
-
- gnu_result = alloc_stmt_list ();
-
- /* The only one we need deal with is for 'Address. For the others, SEM
- puts the information elsewhere. We need only deal with 'Address
- if the object has a Freeze_Node (which it never will currently). */
- if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
- || No (Freeze_Node (Entity (Name (gnat_node)))))
- break;
-
- /* Get the value to use as the address and save it as the
- equivalent for GNAT_TEMP. When the object is frozen,
- gnat_to_gnu_entity will do the right thing. */
- save_gnu_tree (Entity (Name (gnat_node)),
- gnat_to_gnu (Expression (gnat_node)), true);
- break;
-
- case N_Enumeration_Representation_Clause:
- case N_Record_Representation_Clause:
- case N_At_Clause:
- /* We do nothing with these. SEM puts the information elsewhere. */
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Code_Statement:
- if (!type_annotate_only)
- {
- tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
- tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
- tree gnu_clobbers = NULL_TREE, tail;
- bool allows_mem, allows_reg, fake;
- int ninputs, noutputs, i;
- const char **oconstraints;
- const char *constraint;
- char *clobber;
-
- /* First retrieve the 3 operand lists built by the front-end. */
- Setup_Asm_Outputs (gnat_node);
- while (Present (gnat_temp = Asm_Output_Variable ()))
- {
- tree gnu_value = gnat_to_gnu (gnat_temp);
- tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
- (Asm_Output_Constraint ()));
-
- gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
- Next_Asm_Output ();
- }
-
- Setup_Asm_Inputs (gnat_node);
- while (Present (gnat_temp = Asm_Input_Value ()))
- {
- tree gnu_value = gnat_to_gnu (gnat_temp);
- tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
- (Asm_Input_Constraint ()));
-
- gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
- Next_Asm_Input ();
- }
-
- Clobber_Setup (gnat_node);
- while ((clobber = Clobber_Get_Next ()))
- gnu_clobbers
- = tree_cons (NULL_TREE,
- build_string (strlen (clobber) + 1, clobber),
- gnu_clobbers);
-
- /* Then perform some standard checking and processing on the
- operands. In particular, mark them addressable if needed. */
- gnu_outputs = nreverse (gnu_outputs);
- noutputs = list_length (gnu_outputs);
- gnu_inputs = nreverse (gnu_inputs);
- ninputs = list_length (gnu_inputs);
- oconstraints
- = (const char **) alloca (noutputs * sizeof (const char *));
-
- for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
- {
- tree output = TREE_VALUE (tail);
- constraint
- = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
- oconstraints[i] = constraint;
-
- if (parse_output_constraint (&constraint, i, ninputs, noutputs,
- &allows_mem, &allows_reg, &fake))
- {
- /* If the operand is going to end up in memory,
- mark it addressable. Note that we don't test
- allows_mem like in the input case below; this
- is modelled on the C front-end. */
- if (!allows_reg
- && !gnat_mark_addressable (output))
- output = error_mark_node;
- }
- else
- output = error_mark_node;
-
- TREE_VALUE (tail) = output;
- }
-
- for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
- {
- tree input = TREE_VALUE (tail);
- constraint
- = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
-
- if (parse_input_constraint (&constraint, i, ninputs, noutputs,
- 0, oconstraints,
- &allows_mem, &allows_reg))
- {
- /* If the operand is going to end up in memory,
- mark it addressable. */
- if (!allows_reg && allows_mem
- && !gnat_mark_addressable (input))
- input = error_mark_node;
- }
- else
- input = error_mark_node;
-
- TREE_VALUE (tail) = input;
- }
-
- gnu_result = build4 (ASM_EXPR, void_type_node,
- gnu_template, gnu_outputs,
- gnu_inputs, gnu_clobbers);
- ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
- }
- else
- gnu_result = alloc_stmt_list ();
-
- break;
-
- /***************************************************/
- /* Added Nodes */
- /***************************************************/
-
- case N_Freeze_Entity:
- start_stmt_group ();
- process_freeze_entity (gnat_node);
- process_decls (Actions (gnat_node), Empty, Empty, true, true);
- gnu_result = end_stmt_group ();
- break;
-
- case N_Itype_Reference:
- if (!present_gnu_tree (Itype (gnat_node)))
- process_type (Itype (gnat_node));
-
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Free_Statement:
- if (!type_annotate_only)
- {
- tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
- tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
- tree gnu_obj_type;
- tree gnu_actual_obj_type = 0;
- tree gnu_obj_size;
- unsigned int align;
- unsigned int default_allocator_alignment
- = get_target_default_allocator_alignment () * BITS_PER_UNIT;
-
- /* If this is a thin pointer, we must dereference it to create
- a fat pointer, then go back below to a thin pointer. The
- reason for this is that we need a fat pointer someplace in
- order to properly compute the size. */
- if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
- gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
- build_unary_op (INDIRECT_REF, NULL_TREE,
- gnu_ptr));
-
- /* If this is an unconstrained array, we know the object must
- have been allocated with the template in front of the object.
- So pass the template address, but get the total size. Do this
- by converting to a thin pointer. */
- if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
- gnu_ptr
- = convert (build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE
- (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
- gnu_ptr);
-
- gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
-
- if (Present (Actual_Designated_Subtype (gnat_node)))
- {
- gnu_actual_obj_type
- = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
-
- if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
- gnu_actual_obj_type
- = build_unc_object_type_from_ptr (gnu_ptr_type,
- gnu_actual_obj_type,
- get_identifier ("DEALLOC"));
- }
- else
- gnu_actual_obj_type = gnu_obj_type;
-
- gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
- align = TYPE_ALIGN (gnu_obj_type);
-
- if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
- {
- tree gnu_char_ptr_type = build_pointer_type (char_type_node);
- tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
- tree gnu_byte_offset
- = convert (sizetype,
- size_diffop (size_zero_node, gnu_pos));
- gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
-
- gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
- gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
- gnu_ptr, gnu_byte_offset);
- }
-
- /* If the object was allocated from the default storage pool, the
- alignment was greater than what the allocator provides, and this
- is not a fat or thin pointer, what we have in gnu_ptr here is an
- address dynamically adjusted to match the alignment requirement
- (see build_allocator). What we need to pass to free is the
- initial allocator's return value, which has been stored just in
- front of the block we have. */
-
- if (No (Procedure_To_Call (gnat_node))
- && align > default_allocator_alignment
- && ! TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
- {
- /* We set GNU_PTR
- as * (void **)((void *)GNU_PTR - (void *)sizeof(void *))
- in two steps: */
-
- /* GNU_PTR (void *)
- = (void *)GNU_PTR - (void *)sizeof (void *)) */
- gnu_ptr
- = build_binary_op
- (POINTER_PLUS_EXPR, ptr_void_type_node,
- convert (ptr_void_type_node, gnu_ptr),
- size_int (-POINTER_SIZE/BITS_PER_UNIT));
-
- /* GNU_PTR (void *) = *(void **)GNU_PTR */
- gnu_ptr
- = build_unary_op
- (INDIRECT_REF, NULL_TREE,
- convert (build_pointer_type (ptr_void_type_node),
- gnu_ptr));
- }
-
- gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
- Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node),
- gnat_node);
- }
- break;
-
- case N_Raise_Constraint_Error:
- case N_Raise_Program_Error:
- case N_Raise_Storage_Error:
- if (type_annotate_only)
- {
- gnu_result = alloc_stmt_list ();
- break;
- }
-
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- gnu_result
- = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node,
- Nkind (gnat_node));
-
- /* If the type is VOID, this is a statement, so we need to
- generate the code for the call. Handle a Condition, if there
- is one. */
- if (TREE_CODE (gnu_result_type) == VOID_TYPE)
- {
- set_expr_location_from_node (gnu_result, gnat_node);
-
- if (Present (Condition (gnat_node)))
- gnu_result = build3 (COND_EXPR, void_type_node,
- gnat_to_gnu (Condition (gnat_node)),
- gnu_result, alloc_stmt_list ());
- }
- else
- gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
- break;
-
- case N_Validate_Unchecked_Conversion:
- {
- Entity_Id gnat_target_type = Target_Type (gnat_node);
- tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
- tree gnu_target_type = gnat_to_gnu_type (gnat_target_type);
-
- /* No need for any warning in this case. */
- if (!flag_strict_aliasing)
- ;
-
- /* If the result is a pointer type, see if we are either converting
- from a non-pointer or from a pointer to a type with a different
- alias set and warn if so. If the result is defined in the same
- unit as this unchecked conversion, we can allow this because we
- can know to make the pointer type behave properly. */
- else if (POINTER_TYPE_P (gnu_target_type)
- && !In_Same_Source_Unit (gnat_target_type, gnat_node)
- && !No_Strict_Aliasing (Underlying_Type (gnat_target_type)))
- {
- tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
- ? TREE_TYPE (gnu_source_type)
- : NULL_TREE;
- tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
-
- if ((TYPE_DUMMY_P (gnu_target_desig_type)
- || get_alias_set (gnu_target_desig_type) != 0)
- && (!POINTER_TYPE_P (gnu_source_type)
- || (TYPE_DUMMY_P (gnu_source_desig_type)
- != TYPE_DUMMY_P (gnu_target_desig_type))
- || (TYPE_DUMMY_P (gnu_source_desig_type)
- && gnu_source_desig_type != gnu_target_desig_type)
- || (get_alias_set (gnu_source_desig_type)
- != get_alias_set (gnu_target_desig_type))))
- {
- post_error_ne
- ("?possible aliasing problem for type&",
- gnat_node, Target_Type (gnat_node));
- post_error
- ("\\?use -fno-strict-aliasing switch for references",
- gnat_node);
- post_error_ne
- ("\\?or use `pragma No_Strict_Aliasing (&);`",
- gnat_node, Target_Type (gnat_node));
- }
- }
-
- /* But if the result is a fat pointer type, we have no mechanism to
- do that, so we unconditionally warn in problematic cases. */
- else if (TYPE_FAT_POINTER_P (gnu_target_type))
- {
- tree gnu_source_array_type
- = TYPE_FAT_POINTER_P (gnu_source_type)
- ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
- : NULL_TREE;
- tree gnu_target_array_type
- = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
-
- if ((TYPE_DUMMY_P (gnu_target_array_type)
- || get_alias_set (gnu_target_array_type) != 0)
- && (!TYPE_FAT_POINTER_P (gnu_source_type)
- || (TYPE_DUMMY_P (gnu_source_array_type)
- != TYPE_DUMMY_P (gnu_target_array_type))
- || (TYPE_DUMMY_P (gnu_source_array_type)
- && gnu_source_array_type != gnu_target_array_type)
- || (get_alias_set (gnu_source_array_type)
- != get_alias_set (gnu_target_array_type))))
- {
- post_error_ne
- ("?possible aliasing problem for type&",
- gnat_node, Target_Type (gnat_node));
- post_error
- ("\\?use -fno-strict-aliasing switch for references",
- gnat_node);
- }
- }
- }
- gnu_result = alloc_stmt_list ();
- break;
-
- case N_Raise_Statement:
- case N_Function_Specification:
- case N_Procedure_Specification:
- case N_Op_Concat:
- case N_Component_Association:
- case N_Task_Body:
- default:
- gcc_assert (type_annotate_only);
- gnu_result = alloc_stmt_list ();
- }
-
- /* If we pushed our level as part of processing the elaboration routine,
- pop it back now. */
- if (went_into_elab_proc)
- {
- add_stmt (gnu_result);
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
- current_function_decl = NULL_TREE;
- }
-
- /* Set the location information on the result if it is a real expression.
- References can be reused for multiple GNAT nodes and they would get
- the location information of their last use. Note that we may have
- no result if we tried to build a CALL_EXPR node to a procedure with
- no side-effects and optimization is enabled. */
- if (gnu_result
- && EXPR_P (gnu_result)
- && TREE_CODE (gnu_result) != NOP_EXPR
- && !REFERENCE_CLASS_P (gnu_result))
- set_expr_location_from_node (gnu_result, gnat_node);
-
- /* If we're supposed to return something of void_type, it means we have
- something we're elaborating for effect, so just return. */
- if (TREE_CODE (gnu_result_type) == VOID_TYPE)
- return gnu_result;
-
- /* If the result is a constant that overflows, raise constraint error. */
- else if (TREE_CODE (gnu_result) == INTEGER_CST
- && TREE_OVERFLOW (gnu_result))
- {
- post_error ("Constraint_Error will be raised at run-time?", gnat_node);
-
- gnu_result
- = build1 (NULL_EXPR, gnu_result_type,
- build_call_raise (CE_Overflow_Check_Failed, gnat_node,
- N_Raise_Constraint_Error));
- }
-
- /* If our result has side-effects and is of an unconstrained type,
- make a SAVE_EXPR so that we can be sure it will only be referenced
- once. Note we must do this before any conversions. */
- if (TREE_SIDE_EFFECTS (gnu_result)
- && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
- || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
- gnu_result = gnat_stabilize_reference (gnu_result, false);
-
- /* Now convert the result to the result type, unless we are in one of the
- following cases:
-
- 1. If this is the Name of an assignment statement or a parameter of
- a procedure call, return the result almost unmodified since the
- RHS will have to be converted to our type in that case, unless
- the result type has a simpler size. Similarly, don't convert
- integral types that are the operands of an unchecked conversion
- since we need to ignore those conversions (for 'Valid).
-
- 2. If we have a label (which doesn't have any well-defined type), a
- field or an error, return the result almost unmodified. Also don't
- do the conversion if the result type involves a PLACEHOLDER_EXPR in
- its size since those are the cases where the front end may have the
- type wrong due to "instantiating" the unconstrained record with
- discriminant values. Similarly, if the two types are record types
- with the same name don't convert. This will be the case when we are
- converting from a packable version of a type to its original type and
- we need those conversions to be NOPs in order for assignments into
- these types to work properly.
-
- 3. If the type is void or if we have no result, return error_mark_node
- to show we have no result.
-
- 4. Finally, if the type of the result is already correct. */
-
- if (Present (Parent (gnat_node))
- && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
- && Name (Parent (gnat_node)) == gnat_node)
- || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
- && Name (Parent (gnat_node)) != gnat_node)
- || Nkind (Parent (gnat_node)) == N_Parameter_Association
- || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
- && !AGGREGATE_TYPE_P (gnu_result_type)
- && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
- && !(TYPE_SIZE (gnu_result_type)
- && TYPE_SIZE (TREE_TYPE (gnu_result))
- && (AGGREGATE_TYPE_P (gnu_result_type)
- == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
- && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
- && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
- != INTEGER_CST))
- || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (gnu_result))))))
- && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
- {
- /* Remove padding only if the inner object is of self-referential
- size: in that case it must be an object of unconstrained type
- with a default discriminant and we want to avoid copying too
- much data. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
- (TREE_TYPE (gnu_result))))))
- gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
- gnu_result);
- }
-
- else if (TREE_CODE (gnu_result) == LABEL_DECL
- || TREE_CODE (gnu_result) == FIELD_DECL
- || TREE_CODE (gnu_result) == ERROR_MARK
- || (TYPE_SIZE (gnu_result_type)
- && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
- && TREE_CODE (gnu_result) != INDIRECT_REF
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
- || ((TYPE_NAME (gnu_result_type)
- == TYPE_NAME (TREE_TYPE (gnu_result)))
- && TREE_CODE (gnu_result_type) == RECORD_TYPE
- && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
- {
- /* Remove any padding. */
- if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
- gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
- gnu_result);
- }
-
- else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
- gnu_result = error_mark_node;
-
- else if (gnu_result_type != TREE_TYPE (gnu_result))
- gnu_result = convert (gnu_result_type, gnu_result);
-
- /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
- while ((TREE_CODE (gnu_result) == NOP_EXPR
- || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
- && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
- gnu_result = TREE_OPERAND (gnu_result, 0);
-
- return gnu_result;
-}
-\f
-/* Subroutine of above to push the exception label stack. GNU_STACK is
- a pointer to the stack to update and GNAT_LABEL, if present, is the
- label to push onto the stack. */
-
-static void
-push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label)
-{
- tree gnu_label = (Present (gnat_label)
- ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
- : NULL_TREE);
-
- *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack);
-}
-\f
-/* Record the current code position in GNAT_NODE. */
-
-static void
-record_code_position (Node_Id gnat_node)
-{
- tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
-
- add_stmt_with_node (stmt_stmt, gnat_node);
- save_gnu_tree (gnat_node, stmt_stmt, true);
-}
-
-/* Insert the code for GNAT_NODE at the position saved for that node. */
-
-static void
-insert_code_for (Node_Id gnat_node)
-{
- STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
- save_gnu_tree (gnat_node, NULL_TREE, true);
-}
-\f
-/* Start a new statement group chained to the previous group. */
-
-void
-start_stmt_group (void)
-{
- struct stmt_group *group = stmt_group_free_list;
-
- /* First see if we can get one from the free list. */
- if (group)
- stmt_group_free_list = group->previous;
- else
- group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group));
-
- group->previous = current_stmt_group;
- group->stmt_list = group->block = group->cleanups = NULL_TREE;
- current_stmt_group = group;
-}
-
-/* Add GNU_STMT to the current statement group. */
-
-void
-add_stmt (tree gnu_stmt)
-{
- append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list);
-}
-
-/* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
-
-void
-add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
-{
- if (Present (gnat_node))
- set_expr_location_from_node (gnu_stmt, gnat_node);
- add_stmt (gnu_stmt);
-}
-
-/* Add a declaration statement for GNU_DECL to the current statement group.
- Get SLOC from Entity_Id. */
-
-void
-add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
-{
- tree type = TREE_TYPE (gnu_decl);
- tree gnu_stmt, gnu_init, t;
-
- /* If this is a variable that Gigi is to ignore, we may have been given
- an ERROR_MARK. So test for it. We also might have been given a
- reference for a renaming. So only do something for a decl. Also
- ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
- if (!DECL_P (gnu_decl)
- || (TREE_CODE (gnu_decl) == TYPE_DECL
- && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
- return;
-
- gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
-
- /* If we are global, we don't want to actually output the DECL_EXPR for
- this decl since we already have evaluated the expressions in the
- sizes and positions as globals and doing it again would be wrong. */
- if (global_bindings_p ())
- {
- /* Mark everything as used to prevent node sharing with subprograms.
- Note that walk_tree knows how to deal with TYPE_DECL, but neither
- VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
- mark_visited (&gnu_stmt);
- if (TREE_CODE (gnu_decl) == VAR_DECL
- || TREE_CODE (gnu_decl) == CONST_DECL)
- {
- mark_visited (&DECL_SIZE (gnu_decl));
- mark_visited (&DECL_SIZE_UNIT (gnu_decl));
- mark_visited (&DECL_INITIAL (gnu_decl));
- }
- /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */
- if (TREE_CODE (gnu_decl) == TYPE_DECL
- && (TREE_CODE (type) == RECORD_TYPE
- || TREE_CODE (type) == UNION_TYPE
- || TREE_CODE (type) == QUAL_UNION_TYPE)
- && (t = TYPE_ADA_SIZE (type)))
- mark_visited (&t);
- }
- else
- add_stmt_with_node (gnu_stmt, gnat_entity);
-
- /* If this is a variable and an initializer is attached to it, it must be
- valid for the context. Similar to init_const in create_var_decl_1. */
- if (TREE_CODE (gnu_decl) == VAR_DECL
- && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
- && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
- || (TREE_STATIC (gnu_decl)
- && !initializer_constant_valid_p (gnu_init,
- TREE_TYPE (gnu_init)))))
- {
- /* If GNU_DECL has a padded type, convert it to the unpadded
- type so the assignment is done properly. */
- if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
- t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
- else
- t = gnu_decl;
-
- gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, t, gnu_init);
-
- DECL_INITIAL (gnu_decl) = NULL_TREE;
- if (TREE_READONLY (gnu_decl))
- {
- TREE_READONLY (gnu_decl) = 0;
- DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
- }
-
- add_stmt_with_node (gnu_stmt, gnat_entity);
- }
-}
-
-/* Callback for walk_tree to mark the visited trees rooted at *TP. */
-
-static tree
-mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
-{
- if (TREE_VISITED (*tp))
- *walk_subtrees = 0;
-
- /* Don't mark a dummy type as visited because we want to mark its sizes
- and fields once it's filled in. */
- else if (!TYPE_IS_DUMMY_P (*tp))
- TREE_VISITED (*tp) = 1;
-
- if (TYPE_P (*tp))
- TYPE_SIZES_GIMPLIFIED (*tp) = 1;
-
- return NULL_TREE;
-}
-
-/* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
-
-static tree
-unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
- void *data ATTRIBUTE_UNUSED)
-{
- tree t = *tp;
-
- if (TREE_CODE (t) == SAVE_EXPR)
- TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0));
-
- return NULL_TREE;
-}
-
-/* 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. */
-
-void
-mark_visited (tree *tp)
-{
- walk_tree (tp, mark_visited_r, NULL, NULL);
-}
-
-/* Add GNU_CLEANUP, a cleanup action, to the current code group and
- set its location to that of GNAT_NODE if present. */
-
-static void
-add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
-{
- if (Present (gnat_node))
- set_expr_location_from_node (gnu_cleanup, gnat_node);
- append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups);
-}
-
-/* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
-
-void
-set_block_for_group (tree gnu_block)
-{
- gcc_assert (!current_stmt_group->block);
- current_stmt_group->block = gnu_block;
-}
-
-/* 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. */
-
-tree
-end_stmt_group (void)
-{
- struct stmt_group *group = current_stmt_group;
- tree gnu_retval = group->stmt_list;
-
- /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
- are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
- make a BIND_EXPR. Note that we nest in that because the cleanup may
- reference variables in the block. */
- if (gnu_retval == NULL_TREE)
- gnu_retval = alloc_stmt_list ();
-
- if (group->cleanups)
- gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
- group->cleanups);
-
- if (current_stmt_group->block)
- gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
- gnu_retval, group->block);
-
- /* Remove this group from the stack and add it to the free list. */
- current_stmt_group = group->previous;
- group->previous = stmt_group_free_list;
- stmt_group_free_list = group;
-
- return gnu_retval;
-}
-
-/* Add a list of statements from GNAT_LIST, a possibly-empty list of
- statements.*/
-
-static void
-add_stmt_list (List_Id gnat_list)
-{
- Node_Id gnat_node;
-
- if (Present (gnat_list))
- for (gnat_node = First (gnat_list); Present (gnat_node);
- gnat_node = Next (gnat_node))
- add_stmt (gnat_to_gnu (gnat_node));
-}
-
-/* Build a tree from GNAT_LIST, a possibly-empty list of statements.
- If BINDING_P is true, push and pop a binding level around the list. */
-
-static tree
-build_stmt_group (List_Id gnat_list, bool binding_p)
-{
- start_stmt_group ();
- if (binding_p)
- gnat_pushlevel ();
-
- add_stmt_list (gnat_list);
- if (binding_p)
- gnat_poplevel ();
-
- return end_stmt_group ();
-}
-\f
-/* Push and pop routines for stacks. We keep a free list around so we
- don't waste tree nodes. */
-
-static void
-push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value)
-{
- tree gnu_node = gnu_stack_free_list;
-
- if (gnu_node)
- {
- gnu_stack_free_list = TREE_CHAIN (gnu_node);
- TREE_CHAIN (gnu_node) = *gnu_stack_ptr;
- TREE_PURPOSE (gnu_node) = gnu_purpose;
- TREE_VALUE (gnu_node) = gnu_value;
- }
- else
- gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr);
-
- *gnu_stack_ptr = gnu_node;
-}
-
-static void
-pop_stack (tree *gnu_stack_ptr)
-{
- tree gnu_node = *gnu_stack_ptr;
-
- *gnu_stack_ptr = TREE_CHAIN (gnu_node);
- TREE_CHAIN (gnu_node) = gnu_stack_free_list;
- gnu_stack_free_list = gnu_node;
-}
-\f
-/* Generate GIMPLE in place for the expression at *EXPR_P. */
-
-int
-gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
- gimple_seq *post_p ATTRIBUTE_UNUSED)
-{
- tree expr = *expr_p;
- tree op;
-
- if (IS_ADA_STMT (expr))
- return gnat_gimplify_stmt (expr_p);
-
- switch (TREE_CODE (expr))
- {
- case NULL_EXPR:
- /* If this is for a scalar, just make a VAR_DECL for it. If for
- an aggregate, get a null pointer of the appropriate type and
- dereference it. */
- if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
- *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
- convert (build_pointer_type (TREE_TYPE (expr)),
- integer_zero_node));
- else
- {
- *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
- TREE_NO_WARNING (*expr_p) = 1;
- }
-
- gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
- return GS_OK;
-
- case UNCONSTRAINED_ARRAY_REF:
- /* We should only do this if we are just elaborating for side-effects,
- but we can't know that yet. */
- *expr_p = TREE_OPERAND (*expr_p, 0);
- return GS_OK;
-
- case ADDR_EXPR:
- op = TREE_OPERAND (expr, 0);
-
- /* If we're taking the address of a constant CONSTRUCTOR, force it to
- be put into static memory. We know it's going to be readonly given
- the semantics we have and it's required to be static memory in
- the case when the reference is in an elaboration procedure. */
- if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
- {
- tree new_var = create_tmp_var (TREE_TYPE (op), "C");
-
- TREE_READONLY (new_var) = 1;
- TREE_STATIC (new_var) = 1;
- TREE_ADDRESSABLE (new_var) = 1;
- DECL_INITIAL (new_var) = op;
-
- TREE_OPERAND (expr, 0) = new_var;
- recompute_tree_invariant_for_addr_expr (expr);
- return GS_ALL_DONE;
- }
-
- /* If we are taking the address of a SAVE_EXPR, we are typically
- processing a misaligned argument to be passed by reference in a
- procedure call. We just mark the operand as addressable + not
- readonly here and let the common gimplifier code perform the
- temporary creation, initialization, and "instantiation" in place of
- the SAVE_EXPR in further operands, in particular in the copy back
- code inserted after the call. */
- else if (TREE_CODE (op) == SAVE_EXPR)
- {
- TREE_ADDRESSABLE (op) = 1;
- TREE_READONLY (op) = 0;
- }
-
- /* We let the gimplifier process &COND_EXPR and expect it to yield the
- address of the selected operand when it is addressable. Besides, we
- also expect addressable_p to only let COND_EXPRs where both arms are
- addressable reach here. */
- else if (TREE_CODE (op) == COND_EXPR)
- ;
-
- /* Otherwise, if we are taking the address of something that is neither
- reference, declaration, or constant, make a variable for the operand
- here and then take its address. If we don't do it this way, we may
- confuse the gimplifier because it needs to know the variable is
- addressable at this point. This duplicates code in
- internal_get_tmp_var, which is unfortunate. */
- else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference
- && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration
- && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant)
- {
- tree new_var = create_tmp_var (TREE_TYPE (op), "A");
- gimple stmt;
-
- TREE_ADDRESSABLE (new_var) = 1;
-
- stmt = gimplify_assign (new_var, op, pre_p);
- if (EXPR_HAS_LOCATION (op))
- gimple_set_location (stmt, *EXPR_LOCUS (op));
-
- TREE_OPERAND (expr, 0) = new_var;
- recompute_tree_invariant_for_addr_expr (expr);
- return GS_ALL_DONE;
- }
-
- /* ... fall through ... */
-
- default:
- return GS_UNHANDLED;
- }
-}
-
-/* Generate GIMPLE in place for the statement at *STMT_P. */
-
-static enum gimplify_status
-gnat_gimplify_stmt (tree *stmt_p)
-{
- tree stmt = *stmt_p;
-
- switch (TREE_CODE (stmt))
- {
- case STMT_STMT:
- *stmt_p = STMT_STMT_STMT (stmt);
- return GS_OK;
-
- case LOOP_STMT:
- {
- tree gnu_start_label = create_artificial_label ();
- tree gnu_end_label = LOOP_STMT_LABEL (stmt);
- tree t;
-
- /* Set to emit the statements of the loop. */
- *stmt_p = NULL_TREE;
-
- /* We first emit the start label and then a conditional jump to
- the end label if there's a top condition, then the body of the
- loop, then a conditional branch to the end label, then the update,
- if any, and finally a jump to the start label and the definition
- of the end label. */
- append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
- gnu_start_label),
- stmt_p);
-
- if (LOOP_STMT_TOP_COND (stmt))
- append_to_statement_list (build3 (COND_EXPR, void_type_node,
- LOOP_STMT_TOP_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
- stmt_p);
-
- append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
-
- if (LOOP_STMT_BOT_COND (stmt))
- append_to_statement_list (build3 (COND_EXPR, void_type_node,
- LOOP_STMT_BOT_COND (stmt),
- alloc_stmt_list (),
- build1 (GOTO_EXPR,
- void_type_node,
- gnu_end_label)),
- stmt_p);
-
- if (LOOP_STMT_UPDATE (stmt))
- append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
-
- t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
- SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
- append_to_statement_list (t, stmt_p);
-
- append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
- gnu_end_label),
- stmt_p);
- return GS_OK;
- }
-
- case EXIT_STMT:
- /* Build a statement to jump to the corresponding end label, then
- see if it needs to be conditional. */
- *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
- if (EXIT_STMT_COND (stmt))
- *stmt_p = build3 (COND_EXPR, void_type_node,
- EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
- return GS_OK;
-
- default:
- gcc_unreachable ();
- }
-}
-\f
-/* Force references to each of the entities in packages withed by GNAT_NODE.
- Operate recursively but check that we aren't elaborating something more
- than once.
-
- This routine is exclusively called in type_annotate mode, to compute DDA
- information for types in withed units, for ASIS use. */
-
-static void
-elaborate_all_entities (Node_Id gnat_node)
-{
- Entity_Id gnat_with_clause, gnat_entity;
-
- /* Process each unit only once. As we trace the context of all relevant
- units transitively, including generic bodies, we may encounter the
- same generic unit repeatedly. */
- if (!present_gnu_tree (gnat_node))
- save_gnu_tree (gnat_node, integer_zero_node, true);
-
- /* Save entities in all context units. A body may have an implicit_with
- on its own spec, if the context includes a child unit, so don't save
- the spec twice. */
- for (gnat_with_clause = First (Context_Items (gnat_node));
- Present (gnat_with_clause);
- gnat_with_clause = Next (gnat_with_clause))
- if (Nkind (gnat_with_clause) == N_With_Clause
- && !present_gnu_tree (Library_Unit (gnat_with_clause))
- && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
- {
- elaborate_all_entities (Library_Unit (gnat_with_clause));
-
- if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
- {
- for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
- Present (gnat_entity);
- gnat_entity = Next_Entity (gnat_entity))
- if (Is_Public (gnat_entity)
- && Convention (gnat_entity) != Convention_Intrinsic
- && Ekind (gnat_entity) != E_Package
- && Ekind (gnat_entity) != E_Package_Body
- && Ekind (gnat_entity) != E_Operator
- && !(IN (Ekind (gnat_entity), Type_Kind)
- && !Is_Frozen (gnat_entity))
- && !((Ekind (gnat_entity) == E_Procedure
- || Ekind (gnat_entity) == E_Function)
- && Is_Intrinsic_Subprogram (gnat_entity))
- && !IN (Ekind (gnat_entity), Named_Kind)
- && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
- gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
- }
- else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
- {
- Node_Id gnat_body
- = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
-
- /* Retrieve compilation unit node of generic body. */
- while (Present (gnat_body)
- && Nkind (gnat_body) != N_Compilation_Unit)
- gnat_body = Parent (gnat_body);
-
- /* If body is available, elaborate its context. */
- if (Present (gnat_body))
- elaborate_all_entities (gnat_body);
- }
- }
-
- if (Nkind (Unit (gnat_node)) == N_Package_Body)
- elaborate_all_entities (Library_Unit (gnat_node));
-}
-\f
-/* Do the processing of N_Freeze_Entity, GNAT_NODE. */
-
-static void
-process_freeze_entity (Node_Id gnat_node)
-{
- Entity_Id gnat_entity = Entity (gnat_node);
- tree gnu_old;
- tree gnu_new;
- tree gnu_init
- = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
- && present_gnu_tree (Declaration_Node (gnat_entity)))
- ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
-
- /* If this is a package, need to generate code for the package. */
- if (Ekind (gnat_entity) == E_Package)
- {
- insert_code_for
- (Parent (Corresponding_Body
- (Parent (Declaration_Node (gnat_entity)))));
- return;
- }
-
- /* Check for old definition after the above call. This Freeze_Node
- might be for one its Itypes. */
- gnu_old
- = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
-
- /* If this entity has an Address representation clause, GNU_OLD is the
- address, so discard it here. */
- if (Present (Address_Clause (gnat_entity)))
- gnu_old = 0;
-
- /* Don't do anything for class-wide types they are always
- transformed into their root type. */
- if (Ekind (gnat_entity) == E_Class_Wide_Type
- || (Ekind (gnat_entity) == E_Class_Wide_Subtype
- && Present (Equivalent_Type (gnat_entity))))
- return;
-
- /* Don't do anything for subprograms that may have been elaborated before
- their freeze nodes. This can happen, for example because of an inner call
- in an instance body, or a previous compilation of a spec for inlining
- purposes. */
- if (gnu_old
- && ((TREE_CODE (gnu_old) == FUNCTION_DECL
- && (Ekind (gnat_entity) == E_Function
- || Ekind (gnat_entity) == E_Procedure))
- || (gnu_old
- && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
- && Ekind (gnat_entity) == E_Subprogram_Type)))
- return;
-
- /* If we have a non-dummy type old tree, we have nothing to do, except
- aborting if this is the public view of a private type whose full view was
- not delayed, as this node was never delayed as it should have been. We
- let this happen for concurrent types and their Corresponding_Record_Type,
- however, because each might legitimately be elaborated before it's own
- freeze node, e.g. while processing the other. */
- if (gnu_old
- && !(TREE_CODE (gnu_old) == TYPE_DECL
- && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
- {
- gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity))
- && No (Freeze_Node (Full_View (gnat_entity))))
- || Is_Concurrent_Type (gnat_entity)
- || (IN (Ekind (gnat_entity), Record_Kind)
- && Is_Concurrent_Record_Type (gnat_entity)));
- return;
- }
-
- /* Reset the saved tree, if any, and elaborate the object or type for real.
- If there is a full declaration, elaborate it and copy the type to
- GNAT_ENTITY. Likewise if this is the record subtype corresponding to
- a class wide type or subtype. */
- if (gnu_old)
- {
- save_gnu_tree (gnat_entity, NULL_TREE, false);
- if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity))
- && present_gnu_tree (Full_View (gnat_entity)))
- save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
- if (Present (Class_Wide_Type (gnat_entity))
- && Class_Wide_Type (gnat_entity) != gnat_entity)
- save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
- }
-
- if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity)))
- {
- gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
-
- /* Propagate back-annotations from full view to partial view. */
- if (Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
-
- if (Unknown_Esize (gnat_entity))
- Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
-
- if (Unknown_RM_Size (gnat_entity))
- Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
-
- /* The above call may have defined this entity (the simplest example
- of this is when we have a private enumeral type since the bounds
- will have the public view. */
- if (!present_gnu_tree (gnat_entity))
- save_gnu_tree (gnat_entity, gnu_new, false);
- if (Present (Class_Wide_Type (gnat_entity))
- && Class_Wide_Type (gnat_entity) != gnat_entity)
- save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
- }
- else
- gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
-
- /* If we've made any pointers to the old version of this type, we
- have to update them. */
- if (gnu_old)
- update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
- TREE_TYPE (gnu_new));
-}
-\f
-/* Process the list of inlined subprograms of GNAT_NODE, which is an
- N_Compilation_Unit. */
-
-static void
-process_inlined_subprograms (Node_Id gnat_node)
-{
- Entity_Id gnat_entity;
- Node_Id gnat_body;
-
- /* If we can inline, generate Gimple for all the inlined subprograms.
- Define the entity first so we set DECL_EXTERNAL. */
- if (optimize > 0)
- for (gnat_entity = First_Inlined_Subprogram (gnat_node);
- Present (gnat_entity);
- gnat_entity = Next_Inlined_Subprogram (gnat_entity))
- {
- gnat_body = Parent (Declaration_Node (gnat_entity));
-
- if (Nkind (gnat_body) != N_Subprogram_Body)
- {
- /* ??? This really should always be Present. */
- if (No (Corresponding_Body (gnat_body)))
- continue;
-
- gnat_body
- = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
- }
-
- if (Present (gnat_body))
- {
- gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
- add_stmt (gnat_to_gnu (gnat_body));
- }
- }
-}
-\f
-/* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
- We make two passes, one to elaborate anything other than bodies (but
- we declare a function if there was no spec). The second pass
- elaborates the bodies.
-
- GNAT_END_LIST gives the element in the list past the end. Normally,
- this is Empty, but can be First_Real_Statement for a
- Handled_Sequence_Of_Statements.
-
- We make a complete pass through both lists if PASS1P is true, then make
- the second pass over both lists if PASS2P is true. The lists usually
- correspond to the public and private parts of a package. */
-
-static void
-process_decls (List_Id gnat_decls, List_Id gnat_decls2,
- Node_Id gnat_end_list, bool pass1p, bool pass2p)
-{
- List_Id gnat_decl_array[2];
- Node_Id gnat_decl;
- int i;
-
- gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
-
- if (pass1p)
- for (i = 0; i <= 1; i++)
- if (Present (gnat_decl_array[i]))
- for (gnat_decl = First (gnat_decl_array[i]);
- gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
- {
- /* For package specs, we recurse inside the declarations,
- thus taking the two pass approach inside the boundary. */
- if (Nkind (gnat_decl) == N_Package_Declaration
- && (Nkind (Specification (gnat_decl)
- == N_Package_Specification)))
- process_decls (Visible_Declarations (Specification (gnat_decl)),
- Private_Declarations (Specification (gnat_decl)),
- Empty, true, false);
-
- /* Similarly for any declarations in the actions of a
- freeze node. */
- else if (Nkind (gnat_decl) == N_Freeze_Entity)
- {
- process_freeze_entity (gnat_decl);
- process_decls (Actions (gnat_decl), Empty, Empty, true, false);
- }
-
- /* Package bodies with freeze nodes get their elaboration deferred
- until the freeze node, but the code must be placed in the right
- place, so record the code position now. */
- else if (Nkind (gnat_decl) == N_Package_Body
- && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
- record_code_position (gnat_decl);
-
- else if (Nkind (gnat_decl) == N_Package_Body_Stub
- && Present (Library_Unit (gnat_decl))
- && Present (Freeze_Node
- (Corresponding_Spec
- (Proper_Body (Unit
- (Library_Unit (gnat_decl)))))))
- record_code_position
- (Proper_Body (Unit (Library_Unit (gnat_decl))));
-
- /* We defer most subprogram bodies to the second pass. */
- else if (Nkind (gnat_decl) == N_Subprogram_Body)
- {
- if (Acts_As_Spec (gnat_decl))
- {
- Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
-
- if (Ekind (gnat_subprog_id) != E_Generic_Procedure
- && Ekind (gnat_subprog_id) != E_Generic_Function)
- gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
- }
- }
- /* For bodies and stubs that act as their own specs, the entity
- itself must be elaborated in the first pass, because it may
- be used in other declarations. */
- else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
- {
- Node_Id gnat_subprog_id =
- Defining_Entity (Specification (gnat_decl));
-
- if (Ekind (gnat_subprog_id) != E_Subprogram_Body
- && Ekind (gnat_subprog_id) != E_Generic_Procedure
- && Ekind (gnat_subprog_id) != E_Generic_Function)
- gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
- }
-
- /* Concurrent stubs stand for the corresponding subprogram bodies,
- which are deferred like other bodies. */
- else if (Nkind (gnat_decl) == N_Task_Body_Stub
- || Nkind (gnat_decl) == N_Protected_Body_Stub)
- ;
- else
- add_stmt (gnat_to_gnu (gnat_decl));
- }
-
- /* Here we elaborate everything we deferred above except for package bodies,
- which are elaborated at their freeze nodes. Note that we must also
- go inside things (package specs and freeze nodes) the first pass did. */
- if (pass2p)
- for (i = 0; i <= 1; i++)
- if (Present (gnat_decl_array[i]))
- for (gnat_decl = First (gnat_decl_array[i]);
- gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
- {
- if (Nkind (gnat_decl) == N_Subprogram_Body
- || Nkind (gnat_decl) == N_Subprogram_Body_Stub
- || Nkind (gnat_decl) == N_Task_Body_Stub
- || Nkind (gnat_decl) == N_Protected_Body_Stub)
- add_stmt (gnat_to_gnu (gnat_decl));
-
- else if (Nkind (gnat_decl) == N_Package_Declaration
- && (Nkind (Specification (gnat_decl)
- == N_Package_Specification)))
- process_decls (Visible_Declarations (Specification (gnat_decl)),
- Private_Declarations (Specification (gnat_decl)),
- Empty, false, true);
-
- else if (Nkind (gnat_decl) == N_Freeze_Entity)
- process_decls (Actions (gnat_decl), Empty, Empty, false, true);
- }
-}
-\f
-/* Emit code for a range check. GNU_EXPR is the expression to be checked,
- GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
- which we have to check. */
-
-static tree
-emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
-{
- tree gnu_range_type = get_unpadded_type (gnat_range_type);
- tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
- tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
- tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
-
- /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
- This can for example happen when translating 'Val or 'Value. */
- if (gnu_compare_type == gnu_range_type)
- return gnu_expr;
-
- /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
- we can't do anything since we might be truncating the bounds. No
- check is needed in this case. */
- if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
- && (TYPE_PRECISION (gnu_compare_type)
- < TYPE_PRECISION (get_base_type (gnu_range_type))))
- return gnu_expr;
-
- /* Checked expressions must be evaluated only once. */
- gnu_expr = protect_multiple_eval (gnu_expr);
-
- /* There's no good type to use here, so we might as well use
- integer_type_node. Note that the form of the check is
- (not (expr >= lo)) or (not (expr <= hi))
- the reason for this slightly convoluted form is that NaNs
- are not considered to be in range in the float case. */
- return emit_check
- (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
- invert_truthvalue
- (build_binary_op (GE_EXPR, integer_type_node,
- convert (gnu_compare_type, gnu_expr),
- convert (gnu_compare_type, gnu_low))),
- invert_truthvalue
- (build_binary_op (LE_EXPR, integer_type_node,
- convert (gnu_compare_type, gnu_expr),
- convert (gnu_compare_type,
- gnu_high)))),
- gnu_expr, CE_Range_Check_Failed);
-}
-\f
-/* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
- which we are about to index, GNU_EXPR is the index expression to be
- checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
- against which GNU_EXPR has to be checked. Note that for index
- checking we cannot use the emit_range_check function (although very
- similar code needs to be generated in both cases) since for index
- checking the array type against which we are checking the indices
- may be unconstrained and consequently we need to retrieve the
- actual index bounds from the array object itself
- (GNU_ARRAY_OBJECT). The place where we need to do that is in
- subprograms having unconstrained array formal parameters */
-
-static tree
-emit_index_check (tree gnu_array_object,
- tree gnu_expr,
- tree gnu_low,
- tree gnu_high)
-{
- tree gnu_expr_check;
-
- /* Checked expressions must be evaluated only once. */
- gnu_expr = protect_multiple_eval (gnu_expr);
-
- /* Must do this computation in the base type in case the expression's
- type is an unsigned subtypes. */
- gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
-
- /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
- the object we are handling. */
- gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
- gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
-
- /* There's no good type to use here, so we might as well use
- integer_type_node. */
- return emit_check
- (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
- build_binary_op (LT_EXPR, integer_type_node,
- gnu_expr_check,
- convert (TREE_TYPE (gnu_expr_check),
- gnu_low)),
- build_binary_op (GT_EXPR, integer_type_node,
- gnu_expr_check,
- convert (TREE_TYPE (gnu_expr_check),
- gnu_high))),
- gnu_expr, CE_Index_Check_Failed);
-}
-\f
-/* GNU_COND contains the condition corresponding to an access, discriminant or
- range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
- GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
- REASON is the code that says why the exception was raised. */
-
-static tree
-emit_check (tree gnu_cond, tree gnu_expr, int reason)
-{
- tree gnu_call;
- tree gnu_result;
-
- gnu_call = build_call_raise (reason, Empty, N_Raise_Constraint_Error);
-
- /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
- in front of the comparison in case it ends up being a SAVE_EXPR. Put the
- whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
- out. */
- gnu_result = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
- build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
- gnu_call, gnu_expr),
- gnu_expr);
-
- /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
- protect it. Otherwise, show GNU_RESULT has no side effects: we
- don't need to evaluate it just for the check. */
- if (TREE_SIDE_EFFECTS (gnu_expr))
- gnu_result
- = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
- else
- TREE_SIDE_EFFECTS (gnu_result) = 0;
-
- /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
- we will repeatedly do the test. It would be nice if GCC was able
- to optimize this and only do it once. */
- return save_expr (gnu_result);
-}
-\f
-/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
- overflow checks if OVERFLOW_P is nonzero and range checks if
- RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
- If TRUNCATE_P is nonzero, do a float to integer conversion with
- truncation; otherwise round. */
-
-static tree
-convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
- bool rangep, bool truncatep)
-{
- tree gnu_type = get_unpadded_type (gnat_type);
- tree gnu_in_type = TREE_TYPE (gnu_expr);
- tree gnu_in_basetype = get_base_type (gnu_in_type);
- tree gnu_base_type = get_base_type (gnu_type);
- tree gnu_result = gnu_expr;
-
- /* If we are not doing any checks, the output is an integral type, and
- the input is not a floating type, just do the conversion. This
- shortcut is required to avoid problems with packed array types
- and simplifies code in all cases anyway. */
- if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
- && !FLOAT_TYPE_P (gnu_in_type))
- return convert (gnu_type, gnu_expr);
-
- /* First convert the expression to its base type. This
- will never generate code, but makes the tests below much simpler.
- But don't do this if converting from an integer type to an unconstrained
- array type since then we need to get the bounds from the original
- (unpacked) type. */
- if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
- gnu_result = convert (gnu_in_basetype, gnu_result);
-
- /* If overflow checks are requested, we need to be sure the result will
- fit in the output base type. But don't do this if the input
- is integer and the output floating-point. */
- if (overflowp
- && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
- {
- /* Ensure GNU_EXPR only gets evaluated once. */
- tree gnu_input = protect_multiple_eval (gnu_result);
- tree gnu_cond = integer_zero_node;
- tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
- tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
- tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
- tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
-
- /* Convert the lower bounds to signed types, so we're sure we're
- comparing them properly. Likewise, convert the upper bounds
- to unsigned types. */
- if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
- gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
-
- if (INTEGRAL_TYPE_P (gnu_in_basetype)
- && !TYPE_UNSIGNED (gnu_in_basetype))
- gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
-
- if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
- gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
-
- if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
- gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
-
- /* Check each bound separately and only if the result bound
- is tighter than the bound on the input type. Note that all the
- types are base types, so the bounds must be constant. Also,
- the comparison is done in the base type of the input, which
- always has the proper signedness. First check for input
- integer (which means output integer), output float (which means
- both float), or mixed, in which case we always compare.
- Note that we have to do the comparison which would *fail* in the
- case of an error since if it's an FP comparison and one of the
- values is a NaN or Inf, the comparison will fail. */
- if (INTEGRAL_TYPE_P (gnu_in_basetype)
- ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
- : (FLOAT_TYPE_P (gnu_base_type)
- ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
- TREE_REAL_CST (gnu_out_lb))
- : 1))
- gnu_cond
- = invert_truthvalue
- (build_binary_op (GE_EXPR, integer_type_node,
- gnu_input, convert (gnu_in_basetype,
- gnu_out_lb)));
-
- if (INTEGRAL_TYPE_P (gnu_in_basetype)
- ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
- : (FLOAT_TYPE_P (gnu_base_type)
- ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
- TREE_REAL_CST (gnu_in_lb))
- : 1))
- gnu_cond
- = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
- invert_truthvalue
- (build_binary_op (LE_EXPR, integer_type_node,
- gnu_input,
- convert (gnu_in_basetype,
- gnu_out_ub))));
-
- if (!integer_zerop (gnu_cond))
- gnu_result = emit_check (gnu_cond, gnu_input,
- CE_Overflow_Check_Failed);
- }
-
- /* Now convert to the result base type. If this is a non-truncating
- float-to-integer conversion, round. */
- if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
- && !truncatep)
- {
- REAL_VALUE_TYPE half_minus_pred_half, pred_half;
- tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
- tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
- const struct real_format *fmt;
-
- /* The following calculations depend on proper rounding to even
- of each arithmetic operation. In order to prevent excess
- precision from spoiling this property, use the widest hardware
- floating-point type.
-
- FIXME: For maximum efficiency, this should only be done for machines
- and types where intermediates may have extra precision. */
-
- calc_type = longest_float_type_node;
- /* FIXME: Should not have padding in the first place */
- if (TREE_CODE (calc_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (calc_type))
- calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
-
- /* Compute the exact value calc_type'Pred (0.5) at compile time. */
- fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
- real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
- REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
- half_minus_pred_half);
- gnu_pred_half = build_real (calc_type, pred_half);
-
- /* If the input is strictly negative, subtract this value
- and otherwise add it from the input. For 0.5, the result
- is exactly between 1.0 and the machine number preceding 1.0
- (for calc_type). Since the last bit of 1.0 is even, this 0.5
- will round to 1.0, while all other number with an absolute
- value less than 0.5 round to 0.0. For larger numbers exactly
- halfway between integers, rounding will always be correct as
- the true mathematical result will be closer to the higher
- integer compared to the lower one. So, this constant works
- for all floating-point numbers.
-
- The reason to use the same constant with subtract/add instead
- of a positive and negative constant is to allow the comparison
- to be scheduled in parallel with retrieval of the constant and
- conversion of the input to the calc_type (if necessary).
- */
-
- gnu_zero = convert (gnu_in_basetype, integer_zero_node);
- gnu_saved_result = save_expr (gnu_result);
- gnu_conv = convert (calc_type, gnu_saved_result);
- gnu_comp = build2 (GE_EXPR, integer_type_node,
- gnu_saved_result, gnu_zero);
- gnu_add_pred_half
- = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
- gnu_subtract_pred_half
- = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
- gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
- gnu_add_pred_half, gnu_subtract_pred_half);
- }
-
- if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
- && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
- && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
- gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
- else
- gnu_result = convert (gnu_base_type, gnu_result);
-
- /* Finally, do the range check if requested. Note that if the
- result type is a modular type, the range check is actually
- an overflow check. */
-
- if (rangep
- || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
- && TYPE_MODULAR_P (gnu_base_type) && overflowp))
- gnu_result = emit_range_check (gnu_result, gnat_type);
-
- return convert (gnu_type, gnu_result);
-}
-\f
-/* Return true if TYPE is a smaller packable version of RECORD_TYPE. */
-
-static bool
-smaller_packable_type_p (tree type, tree record_type)
-{
- tree size, rsize;
-
- /* We're not interested in variants here. */
- if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (record_type))
- return false;
-
- /* Like a variant, a packable version keeps the original TYPE_NAME. */
- if (TYPE_NAME (type) != TYPE_NAME (record_type))
- return false;
-
- size = TYPE_SIZE (type);
- rsize = TYPE_SIZE (record_type);
-
- if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (rsize) == INTEGER_CST))
- return false;
-
- return tree_int_cst_lt (size, rsize) != 0;
-}
-
-/* Return true if GNU_EXPR can be directly addressed. This is the case
- unless it is an expression involving computation or if it involves a
- reference to a bitfield or to an object not sufficiently aligned for
- its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
- be directly addressed as an object of this type.
-
- *** Notes on addressability issues in the Ada compiler ***
-
- This predicate is necessary in order to bridge the gap between Gigi
- and the middle-end about addressability of GENERIC trees. A tree
- is said to be addressable if it can be directly addressed, i.e. if
- its address can be taken, is a multiple of the type's alignment on
- strict-alignment architectures and returns the first storage unit
- assigned to the object represented by the tree.
-
- In the C family of languages, everything is in practice addressable
- at the language level, except for bit-fields. This means that these
- compilers will take the address of any tree that doesn't represent
- a bit-field reference and expect the result to be the first storage
- unit assigned to the object. Even in cases where this will result
- in unaligned accesses at run time, nothing is supposed to be done
- and the program is considered as erroneous instead (see PR c/18287).
-
- The implicit assumptions made in the middle-end are in keeping with
- the C viewpoint described above:
- - the address of a bit-field reference is supposed to be never
- taken; the compiler (generally) will stop on such a construct,
- - any other tree is addressable if it is formally addressable,
- i.e. if it is formally allowed to be the operand of ADDR_EXPR.
-
- In Ada, the viewpoint is the opposite one: nothing is addressable
- at the language level unless explicitly declared so. This means
- that the compiler will both make sure that the trees representing
- references to addressable ("aliased" in Ada parlance) objects are
- addressable and make no real attempts at ensuring that the trees
- representing references to non-addressable objects are addressable.
-
- In the first case, Ada is effectively equivalent to C and handing
- down the direct result of applying ADDR_EXPR to these trees to the
- middle-end works flawlessly. In the second case, Ada cannot afford
- to consider the program as erroneous if the address of trees that
- are not addressable is requested for technical reasons, unlike C;
- as a consequence, the Ada compiler must arrange for either making
- sure that this address is not requested in the middle-end or for
- compensating by inserting temporaries if it is requested in Gigi.
-
- The first goal can be achieved because the middle-end should not
- request the address of non-addressable trees on its own; the only
- exception is for the invocation of low-level block operations like
- memcpy, for which the addressability requirements are lower since
- the type's alignment can be disregarded. In practice, this means
- that Gigi must make sure that such operations cannot be applied to
- non-BLKmode bit-fields.
-
- The second goal is achieved by means of the addressable_p predicate
- and by inserting SAVE_EXPRs around trees deemed non-addressable.
- They will be turned during gimplification into proper temporaries
- whose address will be used in lieu of that of the original tree. */
-
-static bool
-addressable_p (tree gnu_expr, tree gnu_type)
-{
- /* The size of the real type of the object must not be smaller than
- that of the expected type, otherwise an indirect access in the
- latter type would be larger than the object. Only records need
- to be considered in practice. */
- if (gnu_type
- && TREE_CODE (gnu_type) == RECORD_TYPE
- && smaller_packable_type_p (TREE_TYPE (gnu_expr), gnu_type))
- return false;
-
- switch (TREE_CODE (gnu_expr))
- {
- case VAR_DECL:
- case PARM_DECL:
- case FUNCTION_DECL:
- case RESULT_DECL:
- /* All DECLs are addressable: if they are in a register, we can force
- them to memory. */
- return true;
-
- case UNCONSTRAINED_ARRAY_REF:
- case INDIRECT_REF:
- case CONSTRUCTOR:
- case STRING_CST:
- case INTEGER_CST:
- case NULL_EXPR:
- case SAVE_EXPR:
- case CALL_EXPR:
- return true;
-
- case COND_EXPR:
- /* We accept &COND_EXPR as soon as both operands are addressable and
- expect the outcome to be the address of the selected operand. */
- return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
- && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
-
- case COMPONENT_REF:
- return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
- /* Even with DECL_BIT_FIELD cleared, we have to ensure that
- the field is sufficiently aligned, in case it is subject
- to a pragma Component_Alignment. But we don't need to
- check the alignment of the containing record, as it is
- guaranteed to be not smaller than that of its most
- aligned field that is not a bit-field. */
- && (!STRICT_ALIGNMENT
- || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
- >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
- /* The field of a padding record is always addressable. */
- || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
- && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
-
- case ARRAY_REF: case ARRAY_RANGE_REF:
- case REALPART_EXPR: case IMAGPART_EXPR:
- case NOP_EXPR:
- return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
-
- case CONVERT_EXPR:
- return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
- && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
-
- case VIEW_CONVERT_EXPR:
- {
- /* This is addressable if we can avoid a copy. */
- tree type = TREE_TYPE (gnu_expr);
- tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
- return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
- && (!STRICT_ALIGNMENT
- || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
- || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
- || ((TYPE_MODE (type) == BLKmode
- || TYPE_MODE (inner_type) == BLKmode)
- && (!STRICT_ALIGNMENT
- || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
- || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
- || TYPE_ALIGN_OK (type)
- || TYPE_ALIGN_OK (inner_type))))
- && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
- }
-
- default:
- return false;
- }
-}
-\f
-/* 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. */
-
-void
-process_type (Entity_Id gnat_entity)
-{
- tree gnu_old
- = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
- tree gnu_new;
-
- /* If we are to delay elaboration of this type, just do any
- elaborations needed for expressions within the declaration and
- make a dummy type entry for this node and its Full_View (if
- any) in case something points to it. Don't do this if it
- has already been done (the only way that can happen is if
- the private completion is also delayed). */
- if (Present (Freeze_Node (gnat_entity))
- || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity))
- && Freeze_Node (Full_View (gnat_entity))
- && !present_gnu_tree (Full_View (gnat_entity))))
- {
- elaborate_entity (gnat_entity);
-
- if (!gnu_old)
- {
- tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
- make_dummy_type (gnat_entity),
- NULL, false, false, gnat_entity);
-
- save_gnu_tree (gnat_entity, gnu_decl, false);
- if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity)))
- save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
- }
-
- return;
- }
-
- /* If we saved away a dummy type for this node it means that this
- made the type that corresponds to the full type of an incomplete
- type. Clear that type for now and then update the type in the
- pointers. */
- if (gnu_old)
- {
- gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
- && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
-
- save_gnu_tree (gnat_entity, NULL_TREE, false);
- }
-
- /* Now fully elaborate the type. */
- gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
- gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
-
- /* If we have an old type and we've made pointers to this type,
- update those pointers. */
- if (gnu_old)
- update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
- TREE_TYPE (gnu_new));
-
- /* If this is a record type corresponding to a task or protected type
- that is a completion of an incomplete type, perform a similar update
- on the type. */
- /* ??? Including protected types here is a guess. */
-
- if (IN (Ekind (gnat_entity), Record_Kind)
- && Is_Concurrent_Record_Type (gnat_entity)
- && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
- {
- tree gnu_task_old
- = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
-
- save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
- NULL_TREE, false);
- save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
- gnu_new, false);
-
- update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
- TREE_TYPE (gnu_new));
- }
-}
-\f
-/* GNAT_ENTITY is the type of the resulting constructors,
- GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
- and GNU_TYPE is the GCC type of the corresponding record.
-
- Return a CONSTRUCTOR to build the record. */
-
-static tree
-assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
-{
- tree gnu_list, gnu_result;
-
- /* We test for GNU_FIELD being empty in the case where a variant
- was the last thing since we don't take things off GNAT_ASSOC in
- that case. We check GNAT_ASSOC in case we have a variant, but it
- has no fields. */
-
- for (gnu_list = NULL_TREE; Present (gnat_assoc);
- gnat_assoc = Next (gnat_assoc))
- {
- Node_Id gnat_field = First (Choices (gnat_assoc));
- tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
- tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
-
- /* The expander is supposed to put a single component selector name
- in every record component association */
- gcc_assert (No (Next (gnat_field)));
-
- /* Ignore fields that have Corresponding_Discriminants since we'll
- be setting that field in the parent. */
- if (Present (Corresponding_Discriminant (Entity (gnat_field)))
- && Is_Tagged_Type (Scope (Entity (gnat_field))))
- continue;
-
- /* Also ignore discriminants of Unchecked_Unions. */
- else if (Is_Unchecked_Union (gnat_entity)
- && Ekind (Entity (gnat_field)) == E_Discriminant)
- continue;
-
- /* Before assigning a value in an aggregate make sure range checks
- are done if required. Then convert to the type of the field. */
- if (Do_Range_Check (Expression (gnat_assoc)))
- gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
-
- gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
-
- /* Add the field and expression to the list. */
- gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
- }
-
- gnu_result = extract_values (gnu_list, gnu_type);
-
-#ifdef ENABLE_CHECKING
- {
- tree gnu_field;
-
- /* Verify every entry in GNU_LIST was used. */
- for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
- gcc_assert (TREE_ADDRESSABLE (gnu_field));
- }
-#endif
-
- return gnu_result;
-}
-
-/* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
- is the first element of an array aggregate. It may itself be an
- aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
- corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
- of the array component. It is needed for range checking. */
-
-static tree
-pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
- Entity_Id gnat_component_type)
-{
- tree gnu_expr_list = NULL_TREE;
- tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
- tree gnu_expr;
-
- for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
- {
- /* If the expression is itself an array aggregate then first build the
- innermost constructor if it is part of our array (multi-dimensional
- case). */
-
- if (Nkind (gnat_expr) == N_Aggregate
- && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
- gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
- TREE_TYPE (gnu_array_type),
- gnat_component_type);
- else
- {
- gnu_expr = gnat_to_gnu (gnat_expr);
-
- /* before assigning the element to the array make sure it is
- in range */
- if (Do_Range_Check (gnat_expr))
- gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
- }
-
- gnu_expr_list
- = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
- gnu_expr_list);
-
- gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
- }
-
- return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
-}
-\f
-/* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
- some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
- of the associations that are from RECORD_TYPE. If we see an internal
- record, make a recursive call to fill it in as well. */
-
-static tree
-extract_values (tree values, tree record_type)
-{
- tree result = NULL_TREE;
- tree field, tem;
-
- for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
- {
- tree value = 0;
-
- /* _Parent is an internal field, but may have values in the aggregate,
- so check for values first. */
- if ((tem = purpose_member (field, values)))
- {
- value = TREE_VALUE (tem);
- TREE_ADDRESSABLE (tem) = 1;
- }
-
- else if (DECL_INTERNAL_P (field))
- {
- value = extract_values (values, TREE_TYPE (field));
- if (TREE_CODE (value) == CONSTRUCTOR
- && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
- value = 0;
- }
- else
- /* If we have a record subtype, the names will match, but not the
- actual FIELD_DECLs. */
- for (tem = values; tem; tem = TREE_CHAIN (tem))
- if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
- {
- value = convert (TREE_TYPE (field), TREE_VALUE (tem));
- TREE_ADDRESSABLE (tem) = 1;
- }
-
- if (!value)
- continue;
-
- result = tree_cons (field, value, result);
- }
-
- return gnat_build_constructor (record_type, nreverse (result));
-}
-\f
-/* EXP is to be treated as an array or record. Handle the cases when it is
- an access object and perform the required dereferences. */
-
-static tree
-maybe_implicit_deref (tree exp)
-{
- /* If the type is a pointer, dereference it. */
-
- if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
- exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
-
- /* If we got a padded type, remove it too. */
- if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
- exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
-
- return exp;
-}
-\f
-/* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
-
-tree
-protect_multiple_eval (tree exp)
-{
- tree type = TREE_TYPE (exp);
-
- /* If this has no side effects, we don't need to do anything. */
- if (!TREE_SIDE_EFFECTS (exp))
- return exp;
-
- /* If it is a conversion, protect what's inside the conversion.
- Similarly, if we're indirectly referencing something, we only
- actually need to protect the address since the data itself can't
- change in these situations. */
- else if (TREE_CODE (exp) == NON_LVALUE_EXPR
- || CONVERT_EXPR_P (exp)
- || TREE_CODE (exp) == VIEW_CONVERT_EXPR
- || TREE_CODE (exp) == INDIRECT_REF
- || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
- return build1 (TREE_CODE (exp), type,
- protect_multiple_eval (TREE_OPERAND (exp, 0)));
-
- /* If EXP is a fat pointer or something that can be placed into a register,
- just make a SAVE_EXPR. */
- if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
- return save_expr (exp);
-
- /* Otherwise, dereference, protect the address, and re-reference. */
- else
- return
- build_unary_op (INDIRECT_REF, type,
- save_expr (build_unary_op (ADDR_EXPR,
- build_reference_type (type),
- exp)));
-}
-\f
-/* 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. */
-
-tree
-maybe_stabilize_reference (tree ref, bool force, bool *success)
-{
- tree type = TREE_TYPE (ref);
- enum tree_code code = TREE_CODE (ref);
- tree result;
-
- /* Assume we'll success unless proven otherwise. */
- *success = true;
-
- switch (code)
- {
- case CONST_DECL:
- case VAR_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- /* No action is needed in this case. */
- return ref;
-
- case ADDR_EXPR:
- CASE_CONVERT:
- case FLOAT_EXPR:
- case FIX_TRUNC_EXPR:
- case VIEW_CONVERT_EXPR:
- result
- = build1 (code, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success));
- break;
-
- case INDIRECT_REF:
- case UNCONSTRAINED_ARRAY_REF:
- result = build1 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
- force));
- break;
-
- case COMPONENT_REF:
- result = build3 (COMPONENT_REF, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success),
- TREE_OPERAND (ref, 1), NULL_TREE);
- break;
-
- case BIT_FIELD_REF:
- result = build3 (BIT_FIELD_REF, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
- force));
- break;
-
- case ARRAY_REF:
- case ARRAY_RANGE_REF:
- result = build4 (code, type,
- maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
- success),
- gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
- force),
- NULL_TREE, NULL_TREE);
- break;
-
- case COMPOUND_EXPR:
- result = gnat_stabilize_reference_1 (ref, force);
- break;
-
- case CALL_EXPR:
- /* This generates better code than the scheme in protect_multiple_eval
- because large objects will be returned via invisible reference in
- most ABIs so the temporary will directly be filled by the callee. */
- result = gnat_stabilize_reference_1 (ref, force);
- break;
-
- case CONSTRUCTOR:
- /* Constructors with 1 element are used extensively to formally
- convert objects to special wrapping types. */
- if (TREE_CODE (type) == RECORD_TYPE
- && VEC_length (constructor_elt, CONSTRUCTOR_ELTS (ref)) == 1)
- {
- tree index
- = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->index;
- tree value
- = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (ref), 0)->value;
- result
- = build_constructor_single (type, index,
- gnat_stabilize_reference_1 (value,
- force));
- }
- else
- {
- *success = false;
- return ref;
- }
- break;
-
- case ERROR_MARK:
- ref = error_mark_node;
-
- /* ... Fallthru to failure ... */
-
- /* If arg isn't a kind of lvalue we recognize, make no change.
- Caller should recognize the error for an invalid lvalue. */
- default:
- *success = false;
- return ref;
- }
-
- TREE_READONLY (result) = TREE_READONLY (ref);
-
- /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
- expression may not be sustained across some paths, such as the way via
- build1 for INDIRECT_REF. We re-populate those flags here for the general
- case, which is consistent with the GCC version of this routine.
-
- Special care should be taken regarding TREE_SIDE_EFFECTS, because some
- paths introduce side effects where there was none initially (e.g. calls
- to save_expr), and we also want to keep track of that. */
-
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
-
- return result;
-}
-
-/* Wrapper around maybe_stabilize_reference, for common uses without
- lvalue restrictions and without need to examine the success
- indication. */
-
-static tree
-gnat_stabilize_reference (tree ref, bool force)
-{
- bool dummy;
- return maybe_stabilize_reference (ref, force, &dummy);
-}
-
-/* Similar to stabilize_reference_1 in tree.c, but supports an extra
- arg to force a SAVE_EXPR for everything. */
-
-static tree
-gnat_stabilize_reference_1 (tree e, bool force)
-{
- enum tree_code code = TREE_CODE (e);
- tree type = TREE_TYPE (e);
- tree result;
-
- /* We cannot ignore const expressions because it might be a reference
- to a const array but whose index contains side-effects. But we can
- ignore things that are actual constant or that already have been
- handled by this function. */
-
- if (TREE_CONSTANT (e) || code == SAVE_EXPR)
- return e;
-
- switch (TREE_CODE_CLASS (code))
- {
- case tcc_exceptional:
- case tcc_type:
- case tcc_declaration:
- case tcc_comparison:
- case tcc_statement:
- case tcc_expression:
- case tcc_reference:
- case tcc_vl_exp:
- /* If this is a COMPONENT_REF of a fat pointer, save the entire
- fat pointer. This may be more efficient, but will also allow
- us to more easily find the match for the PLACEHOLDER_EXPR. */
- if (code == COMPONENT_REF
- && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
- result = build3 (COMPONENT_REF, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
- force),
- TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
- else if (TREE_SIDE_EFFECTS (e) || force)
- return save_expr (e);
- else
- return e;
- break;
-
- case tcc_constant:
- /* Constants need no processing. In fact, we should never reach
- here. */
- return e;
-
- case tcc_binary:
- /* Recursively stabilize each operand. */
- result = build2 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
- force));
- break;
-
- case tcc_unary:
- /* Recursively stabilize each operand. */
- result = build1 (code, type,
- gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
- force));
- break;
-
- default:
- gcc_unreachable ();
- }
-
- TREE_READONLY (result) = TREE_READONLY (e);
-
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
- TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
- return result;
-}
-\f
-/* 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. */
-
-bool
-Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
-{
- if (Sloc == No_Location)
- return false;
-
- if (Sloc <= Standard_Location)
- {
- if (*locus == UNKNOWN_LOCATION)
- *locus = BUILTINS_LOCATION;
- return false;
- }
- else
- {
- Source_File_Index file = Get_Source_File_Index (Sloc);
- Logical_Line_Number line = Get_Logical_Line_Number (Sloc);
- Column_Number column = Get_Column_Number (Sloc);
- struct line_map *map = &line_table->maps[file - 1];
-
- /* Translate the location according to the line-map.h formula. */
- *locus = map->start_location
- + ((line - map->to_line) << map->column_bits)
- + (column & ((1 << map->column_bits) - 1));
- }
-
- ref_filename
- = IDENTIFIER_POINTER
- (get_identifier
- (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
-
- return true;
-}
-
-/* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
- don't do anything if it doesn't correspond to a source location. */
-
-static void
-set_expr_location_from_node (tree node, Node_Id gnat_node)
-{
- location_t locus;
-
- if (!Sloc_to_locus (Sloc (gnat_node), &locus))
- return;
-
- SET_EXPR_LOCATION (node, locus);
-}
-\f
-/* Return a colon-separated list of encodings contained in encoded Ada
- name. */
-
-static const char *
-extract_encoding (const char *name)
-{
- char *encoding = GGC_NEWVEC (char, strlen (name));
-
- get_encoding (name, encoding);
-
- return encoding;
-}
-
-/* Extract the Ada name from an encoded name. */
-
-static const char *
-decode_name (const char *name)
-{
- char *decoded = GGC_NEWVEC (char, strlen (name) * 2 + 60);
-
- __gnat_decode (name, decoded, 0);
-
- return decoded;
-}
-\f
-/* 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. */
-
-void
-post_error (const char *msg, Node_Id node)
-{
- String_Template temp;
- Fat_Pointer fp;
-
- temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
- fp.Array = msg, fp.Bounds = &temp;
- if (Present (node))
- Error_Msg_N (fp, node);
-}
-
-/* Similar, but NODE is the node at which to post the error and ENT
- is the node to use for the "&" substitution. */
-
-void
-post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
-{
- String_Template temp;
- Fat_Pointer fp;
-
- temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
- fp.Array = msg, fp.Bounds = &temp;
- if (Present (node))
- Error_Msg_NE (fp, node, 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 ^. */
-
-void
-post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
-{
- String_Template temp;
- Fat_Pointer fp;
-
- temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
- fp.Array = msg, fp.Bounds = &temp;
- Error_Msg_Uint_1 = UI_From_Int (n);
-
- if (Present (node))
- Error_Msg_NE (fp, node, ent);
-}
-\f
-/* 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. */
-
-void
-post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
-{
- char *newmsg = XALLOCAVEC (char, strlen (msg) + 1);
- String_Template temp = {1, 0};
- Fat_Pointer fp;
- char start_yes, end_yes, start_no, end_no;
- const char *p;
- char *q;
-
- fp.Array = newmsg, fp.Bounds = &temp;
-
- if (host_integerp (t, 1)
-#if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
- &&
- compare_tree_int
- (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
-#endif
- )
- {
- Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
- start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
- }
- else
- start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
-
- for (p = msg, q = newmsg; *p; p++)
- {
- if (*p == start_yes)
- for (p++; *p != end_yes; p++)
- *q++ = *p;
- else if (*p == start_no)
- for (p++; *p != end_no; p++)
- ;
- else
- *q++ = *p;
- }
-
- *q = 0;
-
- temp.High_Bound = strlen (newmsg);
- if (Present (node))
- Error_Msg_NE (fp, node, ent);
-}
-
-/* Similar to post_error_ne_tree, except that NUM is a second
- integer to write in the message. */
-
-void
-post_error_ne_tree_2 (const char *msg,
- Node_Id node,
- Entity_Id ent,
- tree t,
- int num)
-{
- Error_Msg_Uint_2 = UI_From_Int (num);
- post_error_ne_tree (msg, node, ent, t);
-}
-\f
-/* Initialize the table that maps GNAT codes to GCC codes for simple
- binary and unary operations. */
-
-static void
-init_code_table (void)
-{
- gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
- gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
-
- gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
- gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
- gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
- gnu_codes[N_Op_Eq] = EQ_EXPR;
- gnu_codes[N_Op_Ne] = NE_EXPR;
- gnu_codes[N_Op_Lt] = LT_EXPR;
- gnu_codes[N_Op_Le] = LE_EXPR;
- gnu_codes[N_Op_Gt] = GT_EXPR;
- gnu_codes[N_Op_Ge] = GE_EXPR;
- gnu_codes[N_Op_Add] = PLUS_EXPR;
- gnu_codes[N_Op_Subtract] = MINUS_EXPR;
- gnu_codes[N_Op_Multiply] = MULT_EXPR;
- gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
- gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
- gnu_codes[N_Op_Minus] = NEGATE_EXPR;
- gnu_codes[N_Op_Abs] = ABS_EXPR;
- gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
- gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
- gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
- gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
- gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
- gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
-}
-
-/* Return a label to branch to for the exception type in KIND or NULL_TREE
- if none. */
-
-tree
-get_exception_label (char kind)
-{
- if (kind == N_Raise_Constraint_Error)
- return TREE_VALUE (gnu_constraint_error_label_stack);
- else if (kind == N_Raise_Storage_Error)
- return TREE_VALUE (gnu_storage_error_label_stack);
- else if (kind == N_Raise_Program_Error)
- return TREE_VALUE (gnu_program_error_label_stack);
- else
- return NULL_TREE;
-}
-
-#include "gt-ada-trans.h"
+++ /dev/null
-/****************************************************************************
- * *
- * GNAT COMPILER COMPONENTS *
- * *
- * U T I L S *
- * *
- * 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. *
- * *
- ****************************************************************************/
-
-/* We have attribute handlers using C specific format specifiers in warning
- messages. Make sure they are properly recognized. */
-#define GCC_DIAG_STYLE __gcc_cdiag__
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "tm.h"
-#include "tree.h"
-#include "flags.h"
-#include "defaults.h"
-#include "toplev.h"
-#include "output.h"
-#include "ggc.h"
-#include "debug.h"
-#include "convert.h"
-#include "target.h"
-#include "function.h"
-#include "cgraph.h"
-#include "tree-inline.h"
-#include "tree-iterator.h"
-#include "gimple.h"
-#include "tree-dump.h"
-#include "pointer-set.h"
-#include "langhooks.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"
-
-#ifndef MAX_FIXED_MODE_SIZE
-#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
-#endif
-
-#ifndef MAX_BITS_PER_WORD
-#define MAX_BITS_PER_WORD BITS_PER_WORD
-#endif
-
-/* If nonzero, pretend we are allocating at global level. */
-int force_global;
-
-/* Tree nodes for the various types and decls we create. */
-tree gnat_std_decls[(int) ADT_LAST];
-
-/* Functions to call for each of the possible raise reasons. */
-tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
-
-/* Forward declarations for handlers of attributes. */
-static tree handle_const_attribute (tree *, tree, tree, int, bool *);
-static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *);
-static tree handle_pure_attribute (tree *, tree, tree, int, bool *);
-static tree handle_novops_attribute (tree *, tree, tree, int, bool *);
-static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *);
-static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *);
-static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *);
-static tree handle_malloc_attribute (tree *, tree, tree, int, bool *);
-static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *);
-
-/* Fake handler for attributes we don't properly support, typically because
- they'd require dragging a lot of the common-c front-end circuitry. */
-static tree fake_attribute_handler (tree *, tree, tree, int, bool *);
-
-/* Table of machine-independent internal attributes for Ada. We support
- this minimal set of attributes to accommodate the needs of builtins. */
-const struct attribute_spec gnat_internal_attribute_table[] =
-{
- /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler } */
- { "const", 0, 0, true, false, false, handle_const_attribute },
- { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute },
- { "pure", 0, 0, true, false, false, handle_pure_attribute },
- { "no vops", 0, 0, true, false, false, handle_novops_attribute },
- { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute },
- { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute },
- { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute },
- { "malloc", 0, 0, true, false, false, handle_malloc_attribute },
- { "type generic", 0, 0, false, true, true, handle_type_generic_attribute },
-
- /* ??? format and format_arg are heavy and not supported, which actually
- prevents support for stdio builtins, which we however declare as part
- of the common builtins.def contents. */
- { "format", 3, 3, false, true, true, fake_attribute_handler },
- { "format_arg", 1, 1, false, true, true, fake_attribute_handler },
-
- { NULL, 0, 0, false, false, false, NULL }
-};
-
-/* Associates a GNAT tree node to a GCC tree node. It is used in
- `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
- of `save_gnu_tree' for more info. */
-static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
-
-#define GET_GNU_TREE(GNAT_ENTITY) \
- associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id]
-
-#define SET_GNU_TREE(GNAT_ENTITY,VAL) \
- associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL)
-
-#define PRESENT_GNU_TREE(GNAT_ENTITY) \
- (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
-
-/* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */
-static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table;
-
-#define GET_DUMMY_NODE(GNAT_ENTITY) \
- dummy_node_table[(GNAT_ENTITY) - First_Node_Id]
-
-#define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \
- dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL)
-
-#define PRESENT_DUMMY_NODE(GNAT_ENTITY) \
- (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE)
-
-/* This variable keeps a table for types for each precision so that we only
- allocate each of them once. Signed and unsigned types are kept separate.
-
- Note that these types are only used when fold-const requests something
- special. Perhaps we should NOT share these types; we'll see how it
- goes later. */
-static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
-
-/* Likewise for float types, but record these by mode. */
-static GTY(()) tree float_types[NUM_MACHINE_MODES];
-
-/* For each binding contour we allocate a binding_level structure to indicate
- the binding depth. */
-
-struct gnat_binding_level GTY((chain_next ("%h.chain")))
-{
- /* The binding level containing this one (the enclosing binding level). */
- struct gnat_binding_level *chain;
- /* The BLOCK node for this level. */
- tree block;
- /* If nonzero, the setjmp buffer that needs to be updated for any
- variable-sized definition within this context. */
- tree jmpbuf_decl;
-};
-
-/* The binding level currently in effect. */
-static GTY(()) struct gnat_binding_level *current_binding_level;
-
-/* A chain of gnat_binding_level structures awaiting reuse. */
-static GTY((deletable)) struct gnat_binding_level *free_binding_level;
-
-/* An array of global declarations. */
-static GTY(()) VEC(tree,gc) *global_decls;
-
-/* An array of builtin function declarations. */
-static GTY(()) VEC(tree,gc) *builtin_decls;
-
-/* An array of global renaming pointers. */
-static GTY(()) VEC(tree,gc) *global_renaming_pointers;
-
-/* A chain of unused BLOCK nodes. */
-static GTY((deletable)) tree free_block_chain;
-
-static void gnat_install_builtins (void);
-static tree merge_sizes (tree, tree, tree, bool, bool);
-static tree compute_related_constant (tree, tree);
-static tree split_plus (tree, tree *);
-static void gnat_gimplify_function (tree);
-static tree float_type_for_precision (int, enum machine_mode);
-static tree convert_to_fat_pointer (tree, tree);
-static tree convert_to_thin_pointer (tree, tree);
-static tree make_descriptor_field (const char *,tree, tree, tree);
-static bool potential_alignment_gap (tree, tree, tree);
-\f
-/* Initialize the association of GNAT nodes to GCC trees. */
-
-void
-init_gnat_to_gnu (void)
-{
- associate_gnat_to_gnu
- = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
-}
-
-/* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
- which is to be associated with GNAT_ENTITY. Such GCC tree node is always
- a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
-
- If GNU_DECL is zero, a previous association is to be reset. */
-
-void
-save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
-{
- /* Check that GNAT_ENTITY is not already defined and that it is being set
- to something which is a decl. Raise gigi 401 if not. Usually, this
- means GNAT_ENTITY is defined twice, but occasionally is due to some
- Gigi problem. */
- gcc_assert (!(gnu_decl
- && (PRESENT_GNU_TREE (gnat_entity)
- || (!no_check && !DECL_P (gnu_decl)))));
-
- SET_GNU_TREE (gnat_entity, gnu_decl);
-}
-
-/* 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.
-
- In some cases, such as delayed elaboration or expressions that need to
- be elaborated only once, GNAT_ENTITY is really not an entity. */
-
-tree
-get_gnu_tree (Entity_Id gnat_entity)
-{
- gcc_assert (PRESENT_GNU_TREE (gnat_entity));
- return GET_GNU_TREE (gnat_entity);
-}
-
-/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */
-
-bool
-present_gnu_tree (Entity_Id gnat_entity)
-{
- return PRESENT_GNU_TREE (gnat_entity);
-}
-\f
-/* Initialize the association of GNAT nodes to GCC trees as dummies. */
-
-void
-init_dummy_type (void)
-{
- dummy_node_table
- = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
-}
-
-/* Make a dummy type corresponding to GNAT_TYPE. */
-
-tree
-make_dummy_type (Entity_Id gnat_type)
-{
- Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type);
- tree gnu_type;
-
- /* If there is an equivalent type, get its underlying type. */
- if (Present (gnat_underlying))
- gnat_underlying = Underlying_Type (gnat_underlying);
-
- /* If there was no equivalent type (can only happen when just annotating
- types) or underlying type, go back to the original type. */
- if (No (gnat_underlying))
- gnat_underlying = gnat_type;
-
- /* If it there already a dummy type, use that one. Else make one. */
- if (PRESENT_DUMMY_NODE (gnat_underlying))
- return GET_DUMMY_NODE (gnat_underlying);
-
- /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
- an ENUMERAL_TYPE. */
- gnu_type = make_node (Is_Record_Type (gnat_underlying)
- ? tree_code_for_record_type (gnat_underlying)
- : ENUMERAL_TYPE);
- TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
- TYPE_DUMMY_P (gnu_type) = 1;
- if (AGGREGATE_TYPE_P (gnu_type))
- {
- TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
- TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
- }
-
- SET_DUMMY_NODE (gnat_underlying, gnu_type);
-
- return gnu_type;
-}
-\f
-/* Return nonzero if we are currently in the global binding level. */
-
-int
-global_bindings_p (void)
-{
- return ((force_global || !current_function_decl) ? -1 : 0);
-}
-
-/* Enter a new binding level. */
-
-void
-gnat_pushlevel ()
-{
- struct gnat_binding_level *newlevel = NULL;
-
- /* Reuse a struct for this binding level, if there is one. */
- if (free_binding_level)
- {
- newlevel = free_binding_level;
- free_binding_level = free_binding_level->chain;
- }
- else
- newlevel
- = (struct gnat_binding_level *)
- ggc_alloc (sizeof (struct gnat_binding_level));
-
- /* Use a free BLOCK, if any; otherwise, allocate one. */
- if (free_block_chain)
- {
- newlevel->block = free_block_chain;
- free_block_chain = BLOCK_CHAIN (free_block_chain);
- BLOCK_CHAIN (newlevel->block) = NULL_TREE;
- }
- else
- newlevel->block = make_node (BLOCK);
-
- /* Point the BLOCK we just made to its parent. */
- if (current_binding_level)
- BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
-
- BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
- TREE_USED (newlevel->block) = 1;
-
- /* Add this level to the front of the chain (stack) of levels that are
- active. */
- newlevel->chain = current_binding_level;
- newlevel->jmpbuf_decl = NULL_TREE;
- current_binding_level = newlevel;
-}
-
-/* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL
- and point FNDECL to this BLOCK. */
-
-void
-set_current_block_context (tree fndecl)
-{
- BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
- DECL_INITIAL (fndecl) = current_binding_level->block;
-}
-
-/* Set the jmpbuf_decl for the current binding level to DECL. */
-
-void
-set_block_jmpbuf_decl (tree decl)
-{
- current_binding_level->jmpbuf_decl = decl;
-}
-
-/* Get the jmpbuf_decl, if any, for the current binding level. */
-
-tree
-get_block_jmpbuf_decl ()
-{
- return current_binding_level->jmpbuf_decl;
-}
-
-/* Exit a binding level. Set any BLOCK into the current code group. */
-
-void
-gnat_poplevel ()
-{
- struct gnat_binding_level *level = current_binding_level;
- tree block = level->block;
-
- BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
- BLOCK_SUBBLOCKS (block) = nreverse (BLOCK_SUBBLOCKS (block));
-
- /* If this is a function-level BLOCK don't do anything. Otherwise, if there
- are no variables free the block and merge its subblocks into those of its
- parent block. Otherwise, add it to the list of its parent. */
- if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
- ;
- else if (BLOCK_VARS (block) == NULL_TREE)
- {
- BLOCK_SUBBLOCKS (level->chain->block)
- = chainon (BLOCK_SUBBLOCKS (block),
- BLOCK_SUBBLOCKS (level->chain->block));
- BLOCK_CHAIN (block) = free_block_chain;
- free_block_chain = block;
- }
- else
- {
- BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
- BLOCK_SUBBLOCKS (level->chain->block) = block;
- TREE_USED (block) = 1;
- set_block_for_group (block);
- }
-
- /* Free this binding structure. */
- current_binding_level = level->chain;
- level->chain = free_binding_level;
- free_binding_level = level;
-}
-
-\f
-/* Records a ..._DECL node DECL as belonging to the current lexical scope
- and uses GNAT_NODE for location information and propagating flags. */
-
-void
-gnat_pushdecl (tree decl, Node_Id gnat_node)
-{
- /* If this decl is public external or at toplevel, there is no context.
- But PARM_DECLs always go in the level of its function. */
- if (TREE_CODE (decl) != PARM_DECL
- && ((DECL_EXTERNAL (decl) && TREE_PUBLIC (decl))
- || global_bindings_p ()))
- DECL_CONTEXT (decl) = 0;
- else
- {
- DECL_CONTEXT (decl) = current_function_decl;
-
- /* Functions imported in another function are not really nested. */
- if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl))
- DECL_NO_STATIC_CHAIN (decl) = 1;
- }
-
- TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
-
- /* Set the location of DECL and emit a declaration for it. */
- if (Present (gnat_node))
- Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
- add_decl_expr (decl, gnat_node);
-
- /* Put the declaration on the list. The list of declarations is in reverse
- order. The list will be reversed later. Put global variables in the
- globals list and builtin functions in a dedicated list to speed up
- further lookups. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
- the list, as they will cause trouble with the debugger and aren't needed
- anyway. */
- if (TREE_CODE (decl) != TYPE_DECL
- || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
- {
- if (global_bindings_p ())
- {
- VEC_safe_push (tree, gc, global_decls, decl);
-
- if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl))
- VEC_safe_push (tree, gc, builtin_decls, decl);
- }
- else
- {
- TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
- BLOCK_VARS (current_binding_level->block) = decl;
- }
- }
-
- /* For the declaration of a type, set its name if it either is not already
- set, was set to an IDENTIFIER_NODE, indicating an internal name,
- or if the previous type name was not derived from a source name.
- We'd rather have the type named with a real name and all the pointer
- types to the same object have the same POINTER_TYPE node. Code in the
- equivalent function of c-decl.c makes a copy of the type node here, but
- that may cause us trouble with incomplete types. We make an exception
- for fat pointer types because the compiler automatically builds them
- for unconstrained array types and the debugger uses them to represent
- both these and pointers to these. */
- if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl))
- {
- tree t = TREE_TYPE (decl);
-
- if (!TYPE_NAME (t) || TREE_CODE (TYPE_NAME (t)) == IDENTIFIER_NODE)
- ;
- else if (TYPE_FAT_POINTER_P (t))
- {
- tree tt = build_variant_type_copy (t);
- TYPE_NAME (tt) = decl;
- TREE_USED (tt) = TREE_USED (t);
- TREE_TYPE (decl) = tt;
- DECL_ORIGINAL_TYPE (decl) = t;
- t = NULL_TREE;
- }
- else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
- ;
- else
- t = NULL_TREE;
-
- /* Propagate the name to all the variants. This is needed for
- the type qualifiers machinery to work properly. */
- if (t)
- for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t))
- TYPE_NAME (t) = decl;
- }
-}
-\f
-/* Do little here. Set up the standard declarations later after the
- front end has been run. */
-
-void
-gnat_init_decl_processing (void)
-{
- /* Make the binding_level structure for global names. */
- current_function_decl = 0;
- current_binding_level = 0;
- free_binding_level = 0;
- gnat_pushlevel ();
-
- build_common_tree_nodes (true, true);
-
- /* In Ada, we use a signed type for SIZETYPE. Use the signed type
- corresponding to the size of Pmode. In most cases when ptr_mode and
- Pmode differ, C will use the width of ptr_mode as sizetype. But we get
- far better code using the width of Pmode. Make this here since we need
- this before we can expand the GNAT types. */
- size_type_node = gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0);
- set_sizetype (size_type_node);
- build_common_tree_nodes_2 (0);
-
- ptr_void_type_node = build_pointer_type (void_type_node);
-}
-
-/* Create the predefined scalar types such as `integer_type_node' needed
- in the gcc back-end and initialize the global binding level. */
-
-void
-init_gigi_decls (tree long_long_float_type, tree exception_type)
-{
- tree endlink, decl;
- unsigned int i;
-
- /* Set the types that GCC and Gigi use from the front end. We would like
- to do this for char_type_node, but it needs to correspond to the C
- char type. */
- if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
- {
- /* In this case, the builtin floating point types are VAX float,
- so make up a type for use. */
- longest_float_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (longest_float_type_node);
- create_type_decl (get_identifier ("longest float type"),
- longest_float_type_node, NULL, false, true, Empty);
- }
- else
- longest_float_type_node = TREE_TYPE (long_long_float_type);
-
- except_type_node = TREE_TYPE (exception_type);
-
- unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
- create_type_decl (get_identifier ("unsigned int"), unsigned_type_node,
- NULL, false, true, Empty);
-
- void_type_decl_node = create_type_decl (get_identifier ("void"),
- void_type_node, NULL, false, true,
- Empty);
-
- void_ftype = build_function_type (void_type_node, NULL_TREE);
- ptr_void_ftype = build_pointer_type (void_ftype);
-
- /* Build the special descriptor type and its null node if needed. */
- if (TARGET_VTABLE_USES_DESCRIPTORS)
- {
- tree field_list = NULL_TREE, null_list = NULL_TREE;
- int j;
-
- fdesc_type_node = make_node (RECORD_TYPE);
-
- for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
- {
- tree field = create_field_decl (NULL_TREE, ptr_void_ftype,
- fdesc_type_node, 0, 0, 0, 1);
- TREE_CHAIN (field) = field_list;
- field_list = field;
- null_list = tree_cons (field, null_pointer_node, null_list);
- }
-
- finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
- null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
- }
-
- /* Now declare runtime functions. */
- endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
-
- /* malloc is a function declaration tree for a function to allocate
- memory. */
- malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"),
- NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype,
- endlink)),
- NULL_TREE, false, true, true, NULL,
- Empty);
- DECL_IS_MALLOC (malloc_decl) = 1;
-
- /* malloc32 is a function declaration tree for a function to allocate
- 32bit memory on a 64bit system. Needed only on 64bit VMS. */
- malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"),
- NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype,
- endlink)),
- NULL_TREE, false, true, true, NULL,
- Empty);
- DECL_IS_MALLOC (malloc32_decl) = 1;
-
- /* free is a function declaration tree for a function to free memory. */
- free_decl
- = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Make the types and functions used for exception processing. */
- jmpbuf_type
- = build_array_type (gnat_type_for_mode (Pmode, 0),
- build_index_type (build_int_cst (NULL_TREE, 5)));
- create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
- true, true, Empty);
- jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
-
- /* Functions to get and set the jumpbuf pointer for the current thread. */
- get_jmpbuf_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
- NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
- /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
- DECL_PURE_P (get_jmpbuf_decl) = 1;
-
- set_jmpbuf_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
- NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Function to get the current exception. */
- get_excptr_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__get_gnat_exception"),
- NULL_TREE,
- build_function_type (build_pointer_type (except_type_node), NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
- /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
- DECL_PURE_P (get_excptr_decl) = 1;
-
- /* Functions that raise exceptions. */
- raise_nodefer_decl
- = create_subprog_decl
- (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type (except_type_node),
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Dummy objects to materialize "others" and "all others" in the exception
- tables. These are exported by a-exexpr.adb, so see this unit for the
- types to use. */
-
- others_decl
- = create_var_decl (get_identifier ("OTHERS"),
- get_identifier ("__gnat_others_value"),
- integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
-
- all_others_decl
- = create_var_decl (get_identifier ("ALL_OTHERS"),
- get_identifier ("__gnat_all_others_value"),
- integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
-
- /* Hooks to call when entering/leaving an exception handler. */
- begin_handler_decl
- = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- end_handler_decl
- = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* If in no exception handlers mode, all raise statements are redirected to
- __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
- this procedure will never be called in this mode. */
- if (No_Exception_Handlers_Set ())
- {
- decl
- = create_subprog_decl
- (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type (char_type_node),
- tree_cons (NULL_TREE,
- integer_type_node,
- endlink))),
- NULL_TREE, false, true, true, NULL, Empty);
-
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- gnat_raise_decls[i] = decl;
- }
- else
- /* Otherwise, make one decl for each exception reason. */
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- {
- char name[17];
-
- sprintf (name, "__gnat_rcheck_%.2d", i);
- gnat_raise_decls[i]
- = create_subprog_decl
- (get_identifier (name), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type
- (char_type_node),
- tree_cons (NULL_TREE,
- integer_type_node,
- endlink))),
- NULL_TREE, false, true, true, NULL, Empty);
- }
-
- /* Indicate that these never return. */
- TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
- TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
- TREE_TYPE (raise_nodefer_decl)
- = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
- TYPE_QUAL_VOLATILE);
-
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- {
- TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
- TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
- TREE_TYPE (gnat_raise_decls[i])
- = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
- TYPE_QUAL_VOLATILE);
- }
-
- /* setjmp returns an integer and has one operand, which is a pointer to
- a jmpbuf. */
- setjmp_decl
- = create_subprog_decl
- (get_identifier ("__builtin_setjmp"), NULL_TREE,
- build_function_type (integer_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
- DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
-
- /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
- address. */
- update_setjmp_buf_decl
- = create_subprog_decl
- (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
- DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
-
- main_identifier_node = get_identifier ("main");
-
- /* Install the builtins we might need, either internally or as
- user available facilities for Intrinsic imports. */
- gnat_install_builtins ();
-}
-\f
-/* 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. */
-
-void
-finish_record_type (tree record_type, tree fieldlist, int rep_level,
- bool do_not_finalize)
-{
- enum tree_code code = TREE_CODE (record_type);
- tree name = TYPE_NAME (record_type);
- tree ada_size = bitsize_zero_node;
- tree size = bitsize_zero_node;
- bool had_size = TYPE_SIZE (record_type) != 0;
- bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0;
- bool had_align = TYPE_ALIGN (record_type) != 0;
- tree field;
-
- if (name && TREE_CODE (name) == TYPE_DECL)
- name = DECL_NAME (name);
-
- TYPE_FIELDS (record_type) = fieldlist;
- TYPE_STUB_DECL (record_type) = build_decl (TYPE_DECL, name, record_type);
-
- /* We don't need both the typedef name and the record name output in
- the debugging information, since they are the same. */
- DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1;
-
- /* Globally initialize the record first. If this is a rep'ed record,
- that just means some initializations; otherwise, layout the record. */
- if (rep_level > 0)
- {
- TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
- TYPE_MODE (record_type) = BLKmode;
-
- if (!had_size_unit)
- TYPE_SIZE_UNIT (record_type) = size_zero_node;
- if (!had_size)
- TYPE_SIZE (record_type) = bitsize_zero_node;
-
- /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
- out just like a UNION_TYPE, since the size will be fixed. */
- else if (code == QUAL_UNION_TYPE)
- code = UNION_TYPE;
- }
- else
- {
- /* Ensure there isn't a size already set. There can be in an error
- case where there is a rep clause but all fields have errors and
- no longer have a position. */
- TYPE_SIZE (record_type) = 0;
- layout_type (record_type);
- }
-
- /* At this point, the position and size of each field is known. It was
- either set before entry by a rep clause, or by laying out the type above.
-
- We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs)
- to compute the Ada size; the GCC size and alignment (for rep'ed records
- that are not padding types); and the mode (for rep'ed records). We also
- clear the DECL_BIT_FIELD indication for the cases we know have not been
- handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
-
- if (code == QUAL_UNION_TYPE)
- fieldlist = nreverse (fieldlist);
-
- for (field = fieldlist; field; field = TREE_CHAIN (field))
- {
- tree type = TREE_TYPE (field);
- tree pos = bit_position (field);
- tree this_size = DECL_SIZE (field);
- tree this_ada_size;
-
- if ((TREE_CODE (type) == RECORD_TYPE
- || TREE_CODE (type) == UNION_TYPE
- || TREE_CODE (type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (type)
- && !TYPE_CONTAINS_TEMPLATE_P (type)
- && TYPE_ADA_SIZE (type))
- this_ada_size = TYPE_ADA_SIZE (type);
- else
- this_ada_size = this_size;
-
- /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */
- if (DECL_BIT_FIELD (field)
- && operand_equal_p (this_size, TYPE_SIZE (type), 0))
- {
- unsigned int align = TYPE_ALIGN (type);
-
- /* In the general case, type alignment is required. */
- if (value_factor_p (pos, align))
- {
- /* The enclosing record type must be sufficiently aligned.
- Otherwise, if no alignment was specified for it and it
- has been laid out already, bump its alignment to the
- desired one if this is compatible with its size. */
- if (TYPE_ALIGN (record_type) >= align)
- {
- DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
- DECL_BIT_FIELD (field) = 0;
- }
- else if (!had_align
- && rep_level == 0
- && value_factor_p (TYPE_SIZE (record_type), align))
- {
- TYPE_ALIGN (record_type) = align;
- DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
- DECL_BIT_FIELD (field) = 0;
- }
- }
-
- /* In the non-strict alignment case, only byte alignment is. */
- if (!STRICT_ALIGNMENT
- && DECL_BIT_FIELD (field)
- && value_factor_p (pos, BITS_PER_UNIT))
- DECL_BIT_FIELD (field) = 0;
- }
-
- /* If we still have DECL_BIT_FIELD set at this point, we know the field
- is technically not addressable. Except that it can actually be
- addressed if the field is BLKmode and happens to be properly
- aligned. */
- DECL_NONADDRESSABLE_P (field)
- |= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode;
-
- /* A type must be as aligned as its most aligned field that is not
- a bit-field. But this is already enforced by layout_type. */
- if (rep_level > 0 && !DECL_BIT_FIELD (field))
- TYPE_ALIGN (record_type)
- = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
-
- switch (code)
- {
- case UNION_TYPE:
- ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
- size = size_binop (MAX_EXPR, size, this_size);
- break;
-
- case QUAL_UNION_TYPE:
- ada_size
- = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
- this_ada_size, ada_size);
- size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
- this_size, size);
- break;
-
- case RECORD_TYPE:
- /* Since we know here that all fields are sorted in order of
- increasing bit position, the size of the record is one
- higher than the ending bit of the last field processed
- unless we have a rep clause, since in that case we might
- have a field outside a QUAL_UNION_TYPE that has a higher ending
- position. So use a MAX in that case. Also, if this field is a
- QUAL_UNION_TYPE, we need to take into account the previous size in
- the case of empty variants. */
- ada_size
- = merge_sizes (ada_size, pos, this_ada_size,
- TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
- size
- = merge_sizes (size, pos, this_size,
- TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0);
- break;
-
- default:
- gcc_unreachable ();
- }
- }
-
- if (code == QUAL_UNION_TYPE)
- nreverse (fieldlist);
-
- if (rep_level < 2)
- {
- /* If this is a padding record, we never want to make the size smaller
- than what was specified in it, if any. */
- if (TREE_CODE (record_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
- size = TYPE_SIZE (record_type);
-
- /* Now set any of the values we've just computed that apply. */
- if (!TYPE_IS_FAT_POINTER_P (record_type)
- && !TYPE_CONTAINS_TEMPLATE_P (record_type))
- SET_TYPE_ADA_SIZE (record_type, ada_size);
-
- if (rep_level > 0)
- {
- tree size_unit = had_size_unit
- ? TYPE_SIZE_UNIT (record_type)
- : convert (sizetype,
- size_binop (CEIL_DIV_EXPR, size,
- bitsize_unit_node));
- unsigned int align = TYPE_ALIGN (record_type);
-
- TYPE_SIZE (record_type) = variable_size (round_up (size, align));
- TYPE_SIZE_UNIT (record_type)
- = variable_size (round_up (size_unit, align / BITS_PER_UNIT));
-
- compute_record_mode (record_type);
- }
- }
-
- if (!do_not_finalize)
- rest_of_record_type_compilation (record_type);
-}
-
-/* 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. */
-
-void
-rest_of_record_type_compilation (tree record_type)
-{
- tree fieldlist = TYPE_FIELDS (record_type);
- tree field;
- enum tree_code code = TREE_CODE (record_type);
- bool var_size = false;
-
- for (field = fieldlist; field; field = TREE_CHAIN (field))
- {
- /* We need to make an XVE/XVU record if any field has variable size,
- whether or not the record does. For example, if we have a union,
- it may be that all fields, rounded up to the alignment, have the
- same size, in which case we'll use that size. But the debug
- output routines (except Dwarf2) won't be able to output the fields,
- so we need to make the special record. */
- if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST
- /* If a field has a non-constant qualifier, the record will have
- variable size too. */
- || (code == QUAL_UNION_TYPE
- && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST))
- {
- var_size = true;
- break;
- }
- }
-
- /* If this record is of variable size, rename it so that the
- debugger knows it is and make a new, parallel, record
- that tells the debugger how the record is laid out. See
- exp_dbug.ads. But don't do this for records that are padding
- since they confuse GDB. */
- if (var_size
- && !(TREE_CODE (record_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (record_type)))
- {
- tree new_record_type
- = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
- ? UNION_TYPE : TREE_CODE (record_type));
- tree orig_name = TYPE_NAME (record_type);
- tree orig_id
- = (TREE_CODE (orig_name) == TYPE_DECL ? DECL_NAME (orig_name)
- : orig_name);
- tree new_id
- = concat_id_with_name (orig_id,
- TREE_CODE (record_type) == QUAL_UNION_TYPE
- ? "XVU" : "XVE");
- tree last_pos = bitsize_zero_node;
- tree old_field;
- tree prev_old_field = 0;
-
- TYPE_NAME (new_record_type) = new_id;
- TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
- TYPE_STUB_DECL (new_record_type)
- = build_decl (TYPE_DECL, new_id, new_record_type);
- DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
- DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
- = DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
- TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
- TYPE_SIZE_UNIT (new_record_type)
- = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT);
-
- add_parallel_type (TYPE_STUB_DECL (record_type), new_record_type);
-
- /* Now scan all the fields, replacing each field with a new
- field corresponding to the new encoding. */
- for (old_field = TYPE_FIELDS (record_type); old_field;
- old_field = TREE_CHAIN (old_field))
- {
- tree field_type = TREE_TYPE (old_field);
- tree field_name = DECL_NAME (old_field);
- tree new_field;
- tree curpos = bit_position (old_field);
- bool var = false;
- unsigned int align = 0;
- tree pos;
-
- /* See how the position was modified from the last position.
-
- There are two basic cases we support: a value was added
- to the last position or the last position was rounded to
- a boundary and they something was added. Check for the
- first case first. If not, see if there is any evidence
- of rounding. If so, round the last position and try
- again.
-
- If this is a union, the position can be taken as zero. */
-
- /* Some computations depend on the shape of the position expression,
- so strip conversions to make sure it's exposed. */
- curpos = remove_conversions (curpos, true);
-
- if (TREE_CODE (new_record_type) == UNION_TYPE)
- pos = bitsize_zero_node, align = 0;
- else
- pos = compute_related_constant (curpos, last_pos);
-
- if (!pos && TREE_CODE (curpos) == MULT_EXPR
- && host_integerp (TREE_OPERAND (curpos, 1), 1))
- {
- tree offset = TREE_OPERAND (curpos, 0);
- align = tree_low_cst (TREE_OPERAND (curpos, 1), 1);
-
- /* An offset which is a bitwise AND with a negative power of 2
- means an alignment corresponding to this power of 2. */
- offset = remove_conversions (offset, true);
- if (TREE_CODE (offset) == BIT_AND_EXPR
- && host_integerp (TREE_OPERAND (offset, 1), 0)
- && tree_int_cst_sgn (TREE_OPERAND (offset, 1)) < 0)
- {
- unsigned int pow
- = - tree_low_cst (TREE_OPERAND (offset, 1), 0);
- if (exact_log2 (pow) > 0)
- align *= pow;
- }
-
- pos = compute_related_constant (curpos,
- round_up (last_pos, align));
- }
- else if (!pos && TREE_CODE (curpos) == PLUS_EXPR
- && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST
- && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
- && host_integerp (TREE_OPERAND
- (TREE_OPERAND (curpos, 0), 1),
- 1))
- {
- align
- = tree_low_cst
- (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1);
- pos = compute_related_constant (curpos,
- round_up (last_pos, align));
- }
- else if (potential_alignment_gap (prev_old_field, old_field,
- pos))
- {
- align = TYPE_ALIGN (field_type);
- pos = compute_related_constant (curpos,
- round_up (last_pos, align));
- }
-
- /* If we can't compute a position, set it to zero.
-
- ??? We really should abort here, but it's too much work
- to get this correct for all cases. */
-
- if (!pos)
- pos = bitsize_zero_node;
-
- /* See if this type is variable-sized and make a pointer type
- and indicate the indirection if so. Beware that the debug
- back-end may adjust the position computed above according
- to the alignment of the field type, i.e. the pointer type
- in this case, if we don't preventively counter that. */
- if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
- {
- field_type = build_pointer_type (field_type);
- if (align != 0 && TYPE_ALIGN (field_type) > align)
- {
- field_type = copy_node (field_type);
- TYPE_ALIGN (field_type) = align;
- }
- var = true;
- }
-
- /* Make a new field name, if necessary. */
- if (var || align != 0)
- {
- char suffix[16];
-
- if (align != 0)
- sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
- align / BITS_PER_UNIT);
- else
- strcpy (suffix, "XVL");
-
- field_name = concat_id_with_name (field_name, suffix);
- }
-
- new_field = create_field_decl (field_name, field_type,
- new_record_type, 0,
- DECL_SIZE (old_field), pos, 0);
- TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
- TYPE_FIELDS (new_record_type) = new_field;
-
- /* If old_field is a QUAL_UNION_TYPE, take its size as being
- zero. The only time it's not the last field of the record
- is when there are other components at fixed positions after
- it (meaning there was a rep clause for every field) and we
- want to be able to encode them. */
- last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
- (TREE_CODE (TREE_TYPE (old_field))
- == QUAL_UNION_TYPE)
- ? bitsize_zero_node
- : DECL_SIZE (old_field));
- prev_old_field = old_field;
- }
-
- TYPE_FIELDS (new_record_type)
- = nreverse (TYPE_FIELDS (new_record_type));
-
- rest_of_type_decl_compilation (TYPE_STUB_DECL (new_record_type));
- }
-
- rest_of_type_decl_compilation (TYPE_STUB_DECL (record_type));
-}
-
-/* Append PARALLEL_TYPE on the chain of parallel types for decl. */
-
-void
-add_parallel_type (tree decl, tree parallel_type)
-{
- tree d = decl;
-
- while (DECL_PARALLEL_TYPE (d))
- d = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (d));
-
- SET_DECL_PARALLEL_TYPE (d, parallel_type);
-}
-
-/* Return the parallel type associated to a type, if any. */
-
-tree
-get_parallel_type (tree type)
-{
- if (TYPE_STUB_DECL (type))
- return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type));
- else
- return NULL_TREE;
-}
-
-/* Utility function of above to merge LAST_SIZE, the previous size of a record
- with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
- if this represents a QUAL_UNION_TYPE in which case we must look for
- COND_EXPRs and replace a value of zero with the old size. If HAS_REP
- is nonzero, we must take the MAX of the end position of this field
- with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
-
- We return an expression for the size. */
-
-static tree
-merge_sizes (tree last_size, tree first_bit, tree size, bool special,
- bool has_rep)
-{
- tree type = TREE_TYPE (last_size);
- tree new;
-
- if (!special || TREE_CODE (size) != COND_EXPR)
- {
- new = size_binop (PLUS_EXPR, first_bit, size);
- if (has_rep)
- new = size_binop (MAX_EXPR, last_size, new);
- }
-
- else
- new = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
- integer_zerop (TREE_OPERAND (size, 1))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 1),
- 1, has_rep),
- integer_zerop (TREE_OPERAND (size, 2))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 2),
- 1, has_rep));
-
- /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
- when fed through substitute_in_expr) into thinking that a constant
- size is not constant. */
- while (TREE_CODE (new) == NON_LVALUE_EXPR)
- new = TREE_OPERAND (new, 0);
-
- return new;
-}
-
-/* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
- related by the addition of a constant. Return that constant if so. */
-
-static tree
-compute_related_constant (tree op0, tree op1)
-{
- tree op0_var, op1_var;
- tree op0_con = split_plus (op0, &op0_var);
- tree op1_con = split_plus (op1, &op1_var);
- tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
-
- if (operand_equal_p (op0_var, op1_var, 0))
- return result;
- else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
- return result;
- else
- return 0;
-}
-
-/* Utility function of above to split a tree OP which may be a sum, into a
- constant part, which is returned, and a variable part, which is stored
- in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
- bitsizetype. */
-
-static tree
-split_plus (tree in, tree *pvar)
-{
- /* Strip NOPS in order to ease the tree traversal and maximize the
- potential for constant or plus/minus discovery. We need to be careful
- to always return and set *pvar to bitsizetype trees, but it's worth
- the effort. */
- STRIP_NOPS (in);
-
- *pvar = convert (bitsizetype, in);
-
- if (TREE_CODE (in) == INTEGER_CST)
- {
- *pvar = bitsize_zero_node;
- return convert (bitsizetype, in);
- }
- else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
- {
- tree lhs_var, rhs_var;
- tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
- tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
-
- if (lhs_var == TREE_OPERAND (in, 0)
- && rhs_var == TREE_OPERAND (in, 1))
- return bitsize_zero_node;
-
- *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
- return size_binop (TREE_CODE (in), lhs_con, rhs_con);
- }
- else
- return bitsize_zero_node;
-}
-\f
-/* Return 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_CICO_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. */
-
-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)
-{
- /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
- the subprogram formal parameters. This list is generated by traversing the
- input list of PARM_DECL nodes. */
- tree param_type_list = NULL;
- tree param_decl;
- tree type;
-
- for (param_decl = param_decl_list; param_decl;
- param_decl = TREE_CHAIN (param_decl))
- param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl),
- param_type_list);
-
- /* The list of the function parameter types has to be terminated by the void
- type to signal to the back-end that we are not dealing with a variable
- parameter subprogram, but that the subprogram has a fixed number of
- parameters. */
- param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list);
-
- /* The list of argument types has been created in reverse
- so nreverse it. */
- param_type_list = nreverse (param_type_list);
-
- type = build_function_type (return_type, param_type_list);
-
- /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST
- or the new type should, make a copy of TYPE. Likewise for
- RETURNS_UNCONSTRAINED and RETURNS_BY_REF. */
- if (TYPE_CI_CO_LIST (type) || cico_list
- || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
- || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref
- || TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr)
- type = copy_type (type);
-
- TYPE_CI_CO_LIST (type) = cico_list;
- TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
- TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
- TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr;
- return type;
-}
-\f
-/* Return a copy of TYPE but safe to modify in any way. */
-
-tree
-copy_type (tree type)
-{
- tree new = copy_node (type);
-
- /* copy_node clears this field instead of copying it, because it is
- aliased with TREE_CHAIN. */
- TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type);
-
- TYPE_POINTER_TO (new) = 0;
- TYPE_REFERENCE_TO (new) = 0;
- TYPE_MAIN_VARIANT (new) = new;
- TYPE_NEXT_VARIANT (new) = 0;
-
- return new;
-}
-\f
-/* 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. */
-
-tree
-create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
-{
- /* First build a type for the desired range. */
- tree type = build_index_2_type (min, max);
-
- /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it
- doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE
- is set, but not to INDEX, make a copy of this type with the requested
- index type. Note that we have no way of sharing these types, but that's
- only a small hole. */
- if (TYPE_INDEX_TYPE (type) == index)
- return type;
- else if (TYPE_INDEX_TYPE (type))
- type = copy_type (type);
-
- SET_TYPE_INDEX_TYPE (type, index);
- create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node);
- return type;
-}
-\f
-/* 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. */
-
-tree
-create_type_decl (tree type_name, tree type, struct attrib *attr_list,
- bool artificial_p, bool debug_info_p, Node_Id gnat_node)
-{
- tree type_decl = build_decl (TYPE_DECL, type_name, type);
- enum tree_code code = TREE_CODE (type);
-
- DECL_ARTIFICIAL (type_decl) = artificial_p;
-
- if (!TYPE_IS_DUMMY_P (type))
- gnat_pushdecl (type_decl, gnat_node);
-
- process_attributes (type_decl, attr_list);
-
- /* Pass type declaration information to the debugger unless this is an
- UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
- and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or
- type for which debugging information was not requested. */
- if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
- DECL_IGNORED_P (type_decl) = 1;
- else if (code != ENUMERAL_TYPE
- && (code != RECORD_TYPE || TYPE_IS_FAT_POINTER_P (type))
- && !((code == POINTER_TYPE || code == REFERENCE_TYPE)
- && TYPE_IS_DUMMY_P (TREE_TYPE (type))))
- rest_of_type_decl_compilation (type_decl);
-
- return type_decl;
-}
-
-/* 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 is for a reference to a public entity or for a
- definition to be made visible outside of the current compilation unit, for
- instance 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)
-{
- bool init_const
- = (var_init != 0
- && gnat_types_compatible_p (type, TREE_TYPE (var_init))
- && (global_bindings_p () || static_flag
- ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) != 0
- : TREE_CONSTANT (var_init)));
-
- /* Whether we will make TREE_CONSTANT the DECL we produce here, in which
- case the initializer may be used in-lieu of the DECL node (as done in
- Identifier_to_gnu). This is useful to prevent the need of elaboration
- code when an identifier for which such a decl is made is in turn used as
- an initializer. We used to rely on CONST vs VAR_DECL for this purpose,
- but extra constraints apply to this choice (see below) and are not
- relevant to the distinction we wish to make. */
- bool constant_p = const_flag && init_const;
-
- /* The actual DECL node. CONST_DECL was initially intended for enumerals
- and may be used for scalars in general but not for aggregates. */
- tree var_decl
- = build_decl ((constant_p && const_decl_allowed_p
- && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
- var_name, type);
-
- /* If this is external, throw away any initializations (they will be done
- elsewhere) unless this is a constant for which we would like to remain
- able to get the initializer. If we are defining a global here, leave a
- constant initialization and save any variable elaborations for the
- elaboration routine. If we are just annotating types, throw away the
- initialization if it isn't a constant. */
- if ((extern_flag && !constant_p)
- || (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
- var_init = NULL_TREE;
-
- /* At the global level, an initializer requiring code to be generated
- produces elaboration statements. Check that such statements are allowed,
- that is, not violating a No_Elaboration_Code restriction. */
- if (global_bindings_p () && var_init != 0 && ! init_const)
- Check_Elaboration_Code_Allowed (gnat_node);
-
- /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
- try to fiddle with DECL_COMMON. However, on platforms that don't
- support global BSS sections, uninitialized global variables would
- go in DATA instead, thus increasing the size of the executable. */
- if (!flag_no_common
- && TREE_CODE (var_decl) == VAR_DECL
- && !have_global_bss_p ())
- DECL_COMMON (var_decl) = 1;
- DECL_INITIAL (var_decl) = var_init;
- TREE_READONLY (var_decl) = const_flag;
- DECL_EXTERNAL (var_decl) = extern_flag;
- TREE_PUBLIC (var_decl) = public_flag || extern_flag;
- TREE_CONSTANT (var_decl) = constant_p;
- TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
- = TYPE_VOLATILE (type);
-
- /* If it's public and not external, always allocate storage for it.
- At the global binding level we need to allocate static storage for the
- variable if and only if it's not external. If we are not at the top level
- we allocate automatic storage unless requested not to. */
- TREE_STATIC (var_decl)
- = !extern_flag && (public_flag || static_flag || global_bindings_p ());
-
- if (asm_name && VAR_OR_FUNCTION_DECL_P (var_decl))
- SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
-
- process_attributes (var_decl, attr_list);
-
- /* Add this decl to the current binding level. */
- gnat_pushdecl (var_decl, gnat_node);
-
- if (TREE_SIDE_EFFECTS (var_decl))
- TREE_ADDRESSABLE (var_decl) = 1;
-
- if (TREE_CODE (var_decl) != CONST_DECL)
- {
- if (global_bindings_p ())
- rest_of_decl_compilation (var_decl, true, 0);
- }
- else
- expand_decl (var_decl);
-
- return var_decl;
-}
-\f
-/* Return true if TYPE, an aggregate type, contains (or is) an array. */
-
-static bool
-aggregate_type_contains_array_p (tree type)
-{
- switch (TREE_CODE (type))
- {
- case RECORD_TYPE:
- case UNION_TYPE:
- case QUAL_UNION_TYPE:
- {
- tree field;
- for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
- if (AGGREGATE_TYPE_P (TREE_TYPE (field))
- && aggregate_type_contains_array_p (TREE_TYPE (field)))
- return true;
- return false;
- }
-
- case ARRAY_TYPE:
- return true;
-
- default:
- gcc_unreachable ();
- }
-}
-
-/* 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. If it is negative, we
- should not make a bitfield, which is used by make_aligning_type. */
-
-tree
-create_field_decl (tree field_name, tree field_type, tree record_type,
- int packed, tree size, tree pos, int addressable)
-{
- tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
-
- DECL_CONTEXT (field_decl) = record_type;
- TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
-
- /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
- byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
- Likewise for an aggregate without specified position that contains an
- array, because in this case slices of variable length of this array
- must be handled by GCC and variable-sized objects need to be aligned
- to at least a byte boundary. */
- if (packed && (TYPE_MODE (field_type) == BLKmode
- || (!pos
- && AGGREGATE_TYPE_P (field_type)
- && aggregate_type_contains_array_p (field_type))))
- DECL_ALIGN (field_decl) = BITS_PER_UNIT;
-
- /* If a size is specified, use it. Otherwise, if the record type is packed
- compute a size to use, which may differ from the object's natural size.
- We always set a size in this case to trigger the checks for bitfield
- creation below, which is typically required when no position has been
- specified. */
- if (size)
- size = convert (bitsizetype, size);
- else if (packed == 1)
- {
- size = rm_size (field_type);
-
- /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
- byte. */
- if (TREE_CODE (size) == INTEGER_CST
- && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
- size = round_up (size, BITS_PER_UNIT);
- }
-
- /* If we may, according to ADDRESSABLE, make a bitfield if a size is
- specified for two reasons: first if the size differs from the natural
- size. Second, if the alignment is insufficient. There are a number of
- ways the latter can be true.
-
- We never make a bitfield if the type of the field has a nonconstant size,
- because no such entity requiring bitfield operations should reach here.
-
- We do *preventively* make a bitfield when there might be the need for it
- but we don't have all the necessary information to decide, as is the case
- of a field with no specified position in a packed record.
-
- We also don't look at STRICT_ALIGNMENT here, and rely on later processing
- in layout_decl or finish_record_type to clear the bit_field indication if
- it is in fact not needed. */
- if (addressable >= 0
- && size
- && TREE_CODE (size) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
- && (!tree_int_cst_equal (size, TYPE_SIZE (field_type))
- || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
- || packed
- || (TYPE_ALIGN (record_type) != 0
- && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
- {
- DECL_BIT_FIELD (field_decl) = 1;
- DECL_SIZE (field_decl) = size;
- if (!packed && !pos)
- DECL_ALIGN (field_decl)
- = (TYPE_ALIGN (record_type) != 0
- ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type))
- : TYPE_ALIGN (field_type));
- }
-
- DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
-
- /* Bump the alignment if need be, either for bitfield/packing purposes or
- to satisfy the type requirements if no such consideration applies. When
- we get the alignment from the type, indicate if this is from an explicit
- user request, which prevents stor-layout from lowering it later on. */
- {
- int bit_align
- = (DECL_BIT_FIELD (field_decl) ? 1
- : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
-
- if (bit_align > DECL_ALIGN (field_decl))
- DECL_ALIGN (field_decl) = bit_align;
- else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl))
- {
- DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
- DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type);
- }
- }
-
- if (pos)
- {
- /* We need to pass in the alignment the DECL is known to have.
- This is the lowest-order bit set in POS, but no more than
- the alignment of the record, if one is specified. Note
- that an alignment of 0 is taken as infinite. */
- unsigned int known_align;
-
- if (host_integerp (pos, 1))
- known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
- else
- known_align = BITS_PER_UNIT;
-
- if (TYPE_ALIGN (record_type)
- && (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
- known_align = TYPE_ALIGN (record_type);
-
- layout_decl (field_decl, known_align);
- SET_DECL_OFFSET_ALIGN (field_decl,
- host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
- : BITS_PER_UNIT);
- pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
- &DECL_FIELD_BIT_OFFSET (field_decl),
- DECL_OFFSET_ALIGN (field_decl), pos);
-
- DECL_HAS_REP_P (field_decl) = 1;
- }
-
- /* In addition to what our caller says, claim the field is addressable if we
- know that its type is not suitable.
-
- The field may also be "technically" nonaddressable, meaning that even if
- we attempt to take the field's address we will actually get the address
- of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD
- value we have at this point is not accurate enough, so we don't account
- for this here and let finish_record_type decide. */
- if (!type_for_nonaliased_component_p (field_type))
- addressable = 1;
-
- DECL_NONADDRESSABLE_P (field_decl) = !addressable;
-
- return field_decl;
-}
-\f
-/* 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). */
-
-tree
-create_param_decl (tree param_name, tree param_type, bool readonly)
-{
- tree param_decl = build_decl (PARM_DECL, param_name, param_type);
-
- /* Honor targetm.calls.promote_prototypes(), as not doing so can
- lead to various ABI violations. */
- if (targetm.calls.promote_prototypes (param_type)
- && (TREE_CODE (param_type) == INTEGER_TYPE
- || TREE_CODE (param_type) == ENUMERAL_TYPE)
- && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
- {
- /* We have to be careful about biased types here. Make a subtype
- of integer_type_node with the proper biasing. */
- if (TREE_CODE (param_type) == INTEGER_TYPE
- && TYPE_BIASED_REPRESENTATION_P (param_type))
- {
- param_type
- = copy_type (build_range_type (integer_type_node,
- TYPE_MIN_VALUE (param_type),
- TYPE_MAX_VALUE (param_type)));
-
- TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
- }
- else
- param_type = integer_type_node;
- }
-
- DECL_ARG_TYPE (param_decl) = param_type;
- TREE_READONLY (param_decl) = readonly;
- return param_decl;
-}
-\f
-/* Given a DECL and ATTR_LIST, process the listed attributes. */
-
-void
-process_attributes (tree decl, struct attrib *attr_list)
-{
- for (; attr_list; attr_list = attr_list->next)
- switch (attr_list->type)
- {
- case ATTR_MACHINE_ATTRIBUTE:
- decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
- NULL_TREE),
- ATTR_FLAG_TYPE_IN_PLACE);
- break;
-
- case ATTR_LINK_ALIAS:
- if (! DECL_EXTERNAL (decl))
- {
- TREE_STATIC (decl) = 1;
- assemble_alias (decl, attr_list->name);
- }
- break;
-
- case ATTR_WEAK_EXTERNAL:
- if (SUPPORTS_WEAK)
- declare_weak (decl);
- else
- post_error ("?weak declarations not supported on this target",
- attr_list->error_point);
- break;
-
- case ATTR_LINK_SECTION:
- if (targetm.have_named_sections)
- {
- DECL_SECTION_NAME (decl)
- = build_string (IDENTIFIER_LENGTH (attr_list->name),
- IDENTIFIER_POINTER (attr_list->name));
- DECL_COMMON (decl) = 0;
- }
- else
- post_error ("?section attributes are not supported for this target",
- attr_list->error_point);
- break;
-
- case ATTR_LINK_CONSTRUCTOR:
- DECL_STATIC_CONSTRUCTOR (decl) = 1;
- TREE_USED (decl) = 1;
- break;
-
- case ATTR_LINK_DESTRUCTOR:
- DECL_STATIC_DESTRUCTOR (decl) = 1;
- TREE_USED (decl) = 1;
- break;
- }
-}
-\f
-/* Record a global renaming pointer. */
-
-void
-record_global_renaming_pointer (tree decl)
-{
- gcc_assert (DECL_RENAMED_OBJECT (decl));
- VEC_safe_push (tree, gc, global_renaming_pointers, decl);
-}
-
-/* Invalidate the global renaming pointers. */
-
-void
-invalidate_global_renaming_pointers (void)
-{
- unsigned int i;
- tree iter;
-
- for (i = 0; VEC_iterate(tree, global_renaming_pointers, i, iter); i++)
- SET_DECL_RENAMED_OBJECT (iter, NULL_TREE);
-
- VEC_free (tree, gc, global_renaming_pointers);
-}
-
-/* Return true if VALUE is a known to be a multiple of FACTOR, which must be
- a power of 2. */
-
-bool
-value_factor_p (tree value, HOST_WIDE_INT factor)
-{
- if (host_integerp (value, 1))
- return tree_low_cst (value, 1) % factor == 0;
-
- if (TREE_CODE (value) == MULT_EXPR)
- return (value_factor_p (TREE_OPERAND (value, 0), factor)
- || value_factor_p (TREE_OPERAND (value, 1), factor));
-
- return false;
-}
-
-/* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
- unless we can prove these 2 fields are laid out in such a way that no gap
- exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET
- is the distance in bits between the end of PREV_FIELD and the starting
- position of CURR_FIELD. It is ignored if null. */
-
-static bool
-potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
-{
- /* If this is the first field of the record, there cannot be any gap */
- if (!prev_field)
- return false;
-
- /* If the previous field is a union type, then return False: The only
- time when such a field is not the last field of the record is when
- there are other components at fixed positions after it (meaning there
- was a rep clause for every field), in which case we don't want the
- alignment constraint to override them. */
- if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
- return false;
-
- /* If the distance between the end of prev_field and the beginning of
- curr_field is constant, then there is a gap if the value of this
- constant is not null. */
- if (offset && host_integerp (offset, 1))
- return !integer_zerop (offset);
-
- /* If the size and position of the previous field are constant,
- then check the sum of this size and position. There will be a gap
- iff it is not multiple of the current field alignment. */
- if (host_integerp (DECL_SIZE (prev_field), 1)
- && host_integerp (bit_position (prev_field), 1))
- return ((tree_low_cst (bit_position (prev_field), 1)
- + tree_low_cst (DECL_SIZE (prev_field), 1))
- % DECL_ALIGN (curr_field) != 0);
-
- /* If both the position and size of the previous field are multiples
- of the current field alignment, there cannot be any gap. */
- if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
- && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
- return false;
-
- /* Fallback, return that there may be a potential gap */
- return true;
-}
-
-/* Returns a LABEL_DECL node for LABEL_NAME. */
-
-tree
-create_label_decl (tree label_name)
-{
- tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node);
-
- DECL_CONTEXT (label_decl) = current_function_decl;
- DECL_MODE (label_decl) = VOIDmode;
- DECL_SOURCE_LOCATION (label_decl) = input_location;
-
- return label_decl;
-}
-\f
-/* 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. */
-
-tree
-create_subprog_decl (tree subprog_name, tree asm_name,
- tree subprog_type, tree param_decl_list, bool inline_flag,
- bool public_flag, bool extern_flag,
- struct attrib *attr_list, Node_Id gnat_node)
-{
- tree return_type = TREE_TYPE (subprog_type);
- tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
-
- /* If this is a function nested inside an inlined external function, it
- means we aren't going to compile the outer function unless it is
- actually inlined, so do the same for us. */
- if (current_function_decl && DECL_INLINE (current_function_decl)
- && DECL_EXTERNAL (current_function_decl))
- extern_flag = true;
-
- DECL_EXTERNAL (subprog_decl) = extern_flag;
- TREE_PUBLIC (subprog_decl) = public_flag;
- TREE_STATIC (subprog_decl) = 1;
- TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type);
- TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
- TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
- DECL_ARGUMENTS (subprog_decl) = param_decl_list;
- DECL_RESULT (subprog_decl) = build_decl (RESULT_DECL, 0, return_type);
- DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
- DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
-
- /* TREE_ADDRESSABLE is set on the result type to request the use of the
- target by-reference return mechanism. This is not supported all the
- way down to RTL expansion with GCC 4, which ICEs on temporary creation
- attempts with such a type and expects DECL_BY_REFERENCE to be set on
- the RESULT_DECL instead - see gnat_genericize for more details. */
- if (TREE_ADDRESSABLE (TREE_TYPE (DECL_RESULT (subprog_decl))))
- {
- tree result_decl = DECL_RESULT (subprog_decl);
-
- TREE_ADDRESSABLE (TREE_TYPE (result_decl)) = 0;
- DECL_BY_REFERENCE (result_decl) = 1;
- }
-
- if (inline_flag)
- DECL_DECLARED_INLINE_P (subprog_decl) = 1;
-
- if (asm_name)
- {
- SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
-
- /* The expand_main_function circuitry expects "main_identifier_node" to
- designate the DECL_NAME of the 'main' entry point, in turn expected
- to be declared as the "main" function literally by default. Ada
- program entry points are typically declared with a different name
- within the binder generated file, exported as 'main' to satisfy the
- system expectations. Redirect main_identifier_node in this case. */
- if (asm_name == main_identifier_node)
- main_identifier_node = DECL_NAME (subprog_decl);
- }
-
- process_attributes (subprog_decl, attr_list);
-
- /* Add this decl to the current binding level. */
- gnat_pushdecl (subprog_decl, gnat_node);
-
- /* Output the assembler code and/or RTL for the declaration. */
- rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
-
- return subprog_decl;
-}
-\f
-/* 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. */
-
-void
-begin_subprog_body (tree subprog_decl)
-{
- tree param_decl;
-
- current_function_decl = subprog_decl;
- announce_function (subprog_decl);
-
- /* Enter a new binding level and show that all the parameters belong to
- this function. */
- gnat_pushlevel ();
- for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
- param_decl = TREE_CHAIN (param_decl))
- DECL_CONTEXT (param_decl) = subprog_decl;
-
- make_decl_rtl (subprog_decl);
-
- /* We handle pending sizes via the elaboration of types, so we don't need to
- save them. This causes them to be marked as part of the outer function
- and then discarded. */
- get_pending_sizes ();
-}
-
-
-/* Helper for the genericization callback. Return a dereference of VAL
- if it is of a reference type. */
-
-static tree
-convert_from_reference (tree val)
-{
- tree value_type, ref;
-
- if (TREE_CODE (TREE_TYPE (val)) != REFERENCE_TYPE)
- return val;
-
- value_type = TREE_TYPE (TREE_TYPE (val));
- ref = build1 (INDIRECT_REF, value_type, val);
-
- /* See if what we reference is CONST or VOLATILE, which requires
- looking into array types to get to the component type. */
-
- while (TREE_CODE (value_type) == ARRAY_TYPE)
- value_type = TREE_TYPE (value_type);
-
- TREE_READONLY (ref)
- = (TYPE_QUALS (value_type) & TYPE_QUAL_CONST);
- TREE_THIS_VOLATILE (ref)
- = (TYPE_QUALS (value_type) & TYPE_QUAL_VOLATILE);
-
- TREE_SIDE_EFFECTS (ref)
- = (TREE_THIS_VOLATILE (ref) || TREE_SIDE_EFFECTS (val));
-
- return ref;
-}
-
-/* Helper for the genericization callback. Returns true if T denotes
- a RESULT_DECL with DECL_BY_REFERENCE set. */
-
-static inline bool
-is_byref_result (tree t)
-{
- return (TREE_CODE (t) == RESULT_DECL && DECL_BY_REFERENCE (t));
-}
-
-
-/* Tree walking callback for gnat_genericize. Currently ...
-
- o Adjust references to the function's DECL_RESULT if it is marked
- DECL_BY_REFERENCE and so has had its type turned into a reference
- type at the end of the function compilation. */
-
-static tree
-gnat_genericize_r (tree *stmt_p, int *walk_subtrees, void *data)
-{
- /* This implementation is modeled after what the C++ front-end is
- doing, basis of the downstream passes behavior. */
-
- tree stmt = *stmt_p;
- struct pointer_set_t *p_set = (struct pointer_set_t*) data;
-
- /* If we have a direct mention of the result decl, dereference. */
- if (is_byref_result (stmt))
- {
- *stmt_p = convert_from_reference (stmt);
- *walk_subtrees = 0;
- return NULL;
- }
-
- /* Otherwise, no need to walk the same tree twice. */
- if (pointer_set_contains (p_set, stmt))
- {
- *walk_subtrees = 0;
- return NULL_TREE;
- }
-
- /* If we are taking the address of what now is a reference, just get the
- reference value. */
- if (TREE_CODE (stmt) == ADDR_EXPR
- && is_byref_result (TREE_OPERAND (stmt, 0)))
- {
- *stmt_p = convert (TREE_TYPE (stmt), TREE_OPERAND (stmt, 0));
- *walk_subtrees = 0;
- }
-
- /* Don't dereference an by-reference RESULT_DECL inside a RETURN_EXPR. */
- else if (TREE_CODE (stmt) == RETURN_EXPR
- && TREE_OPERAND (stmt, 0)
- && is_byref_result (TREE_OPERAND (stmt, 0)))
- *walk_subtrees = 0;
-
- /* Don't look inside trees that cannot embed references of interest. */
- else if (IS_TYPE_OR_DECL_P (stmt))
- *walk_subtrees = 0;
-
- pointer_set_insert (p_set, *stmt_p);
-
- return NULL;
-}
-
-/* Perform lowering of Ada trees to GENERIC. In particular:
-
- o Turn a DECL_BY_REFERENCE RESULT_DECL into a real by-reference decl
- and adjust all the references to this decl accordingly. */
-
-static void
-gnat_genericize (tree fndecl)
-{
- /* Prior to GCC 4, an explicit By_Reference result mechanism for a function
- was handled by simply setting TREE_ADDRESSABLE on the result type.
- Everything required to actually pass by invisible ref using the target
- mechanism (e.g. extra parameter) was handled at RTL expansion time.
-
- This doesn't work with GCC 4 any more for several reasons. First, the
- gimplification process might need the creation of temporaries of this
- type, and the gimplifier ICEs on such attempts. Second, the middle-end
- now relies on a different attribute for such cases (DECL_BY_REFERENCE on
- RESULT/PARM_DECLs), and expects the user invisible by-reference-ness to
- be explicitly accounted for by the front-end in the function body.
-
- We achieve the complete transformation in two steps:
-
- 1/ create_subprog_decl performs early attribute tweaks: it clears
- TREE_ADDRESSABLE from the result type and sets DECL_BY_REFERENCE on
- the result decl. The former ensures that the bit isn't set in the GCC
- tree saved for the function, so prevents ICEs on temporary creation.
- The latter we use here to trigger the rest of the processing.
-
- 2/ This function performs the type transformation on the result decl
- and adjusts all the references to this decl from the function body
- accordingly.
-
- Clearing TREE_ADDRESSABLE from the type differs from the C++ front-end
- strategy, which escapes the gimplifier temporary creation issues by
- creating it's own temporaries using TARGET_EXPR nodes. Our way relies
- on simple specific support code in aggregate_value_p to look at the
- target function result decl explicitly. */
-
- struct pointer_set_t *p_set;
- tree decl_result = DECL_RESULT (fndecl);
-
- if (!DECL_BY_REFERENCE (decl_result))
- return;
-
- /* Make the DECL_RESULT explicitly by-reference and adjust all the
- occurrences in the function body using the common tree-walking facility.
- We want to see every occurrence of the result decl to adjust the
- referencing tree, so need to use our own pointer set to control which
- trees should be visited again or not. */
-
- p_set = pointer_set_create ();
-
- TREE_TYPE (decl_result) = build_reference_type (TREE_TYPE (decl_result));
- TREE_ADDRESSABLE (decl_result) = 0;
- relayout_decl (decl_result);
-
- walk_tree (&DECL_SAVED_TREE (fndecl), gnat_genericize_r, p_set, NULL);
-
- pointer_set_destroy (p_set);
-}
-
-/* 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. */
-
-void
-end_subprog_body (tree body, bool elab_p)
-{
- tree fndecl = current_function_decl;
-
- /* Mark the BLOCK for this level as being for this function and pop the
- level. Since the vars in it are the parameters, clear them. */
- BLOCK_VARS (current_binding_level->block) = 0;
- BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
- DECL_INITIAL (fndecl) = current_binding_level->block;
- gnat_poplevel ();
-
- /* Deal with inline. If declared inline or we should default to inline,
- set the flag in the decl. */
- DECL_INLINE (fndecl) = 1;
-
- /* We handle pending sizes via the elaboration of types, so we don't
- need to save them. */
- get_pending_sizes ();
-
- /* Mark the RESULT_DECL as being in this subprogram. */
- DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
-
- DECL_SAVED_TREE (fndecl) = body;
-
- current_function_decl = DECL_CONTEXT (fndecl);
- set_cfun (NULL);
-
- /* We cannot track the location of errors past this point. */
- error_gnat_node = Empty;
-
- /* If we're only annotating types, don't actually compile this function. */
- if (type_annotate_only)
- return;
-
- /* Perform the required pre-gimplification transformations on the tree. */
- gnat_genericize (fndecl);
-
- /* We do different things for nested and non-nested functions.
- ??? This should be in cgraph. */
- if (!DECL_CONTEXT (fndecl))
- {
- gnat_gimplify_function (fndecl);
-
- /* If this is an empty elaboration proc, just discard the node.
- Otherwise, compile further. */
- if (elab_p && empty_body_p (gimple_body (fndecl)))
- cgraph_remove_node (cgraph_node (fndecl));
- else
- cgraph_finalize_function (fndecl, false);
- }
- else
- /* Register this function with cgraph just far enough to get it
- added to our parent's nested function list. */
- (void) cgraph_node (fndecl);
-}
-
-/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
-
-static void
-gnat_gimplify_function (tree fndecl)
-{
- struct cgraph_node *cgn;
-
- dump_function (TDI_original, fndecl);
- gimplify_function_tree (fndecl);
- dump_function (TDI_generic, fndecl);
-
- /* Convert all nested functions to GIMPLE now. We do things in this order
- so that items like VLA sizes are expanded properly in the context of the
- correct function. */
- cgn = cgraph_node (fndecl);
- for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
- gnat_gimplify_function (cgn->decl);
-}
-\f
-
-tree
-gnat_builtin_function (tree decl)
-{
- gnat_pushdecl (decl, Empty);
- return decl;
-}
-
-/* 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. */
-
-tree
-gnat_type_for_size (unsigned precision, int unsignedp)
-{
- tree t;
- char type_name[20];
-
- if (precision <= 2 * MAX_BITS_PER_WORD
- && signed_and_unsigned_types[precision][unsignedp])
- return signed_and_unsigned_types[precision][unsignedp];
-
- if (unsignedp)
- t = make_unsigned_type (precision);
- else
- t = make_signed_type (precision);
-
- if (precision <= 2 * MAX_BITS_PER_WORD)
- signed_and_unsigned_types[precision][unsignedp] = t;
-
- if (!TYPE_NAME (t))
- {
- sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
- TYPE_NAME (t) = get_identifier (type_name);
- }
-
- return t;
-}
-
-/* Likewise for floating-point types. */
-
-static tree
-float_type_for_precision (int precision, enum machine_mode mode)
-{
- tree t;
- char type_name[20];
-
- if (float_types[(int) mode])
- return float_types[(int) mode];
-
- float_types[(int) mode] = t = make_node (REAL_TYPE);
- TYPE_PRECISION (t) = precision;
- layout_type (t);
-
- gcc_assert (TYPE_MODE (t) == mode);
- if (!TYPE_NAME (t))
- {
- sprintf (type_name, "FLOAT_%d", precision);
- TYPE_NAME (t) = get_identifier (type_name);
- }
-
- return t;
-}
-
-/* Return a data type that has machine mode MODE. UNSIGNEDP selects
- an unsigned type; otherwise a signed type is returned. */
-
-tree
-gnat_type_for_mode (enum machine_mode mode, int unsignedp)
-{
- if (mode == BLKmode)
- return NULL_TREE;
- else if (mode == VOIDmode)
- return void_type_node;
- else if (COMPLEX_MODE_P (mode))
- return NULL_TREE;
- else if (SCALAR_FLOAT_MODE_P (mode))
- return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
- else if (SCALAR_INT_MODE_P (mode))
- return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
- else
- return NULL_TREE;
-}
-
-/* Return the unsigned version of a TYPE_NODE, a scalar type. */
-
-tree
-gnat_unsigned_type (tree type_node)
-{
- tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
-
- if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
- {
- type = copy_node (type);
- TREE_TYPE (type) = type_node;
- }
- else if (TREE_TYPE (type_node)
- && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
- && TYPE_MODULAR_P (TREE_TYPE (type_node)))
- {
- type = copy_node (type);
- TREE_TYPE (type) = TREE_TYPE (type_node);
- }
-
- return type;
-}
-
-/* Return the signed version of a TYPE_NODE, a scalar type. */
-
-tree
-gnat_signed_type (tree type_node)
-{
- tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
-
- if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
- {
- type = copy_node (type);
- TREE_TYPE (type) = type_node;
- }
- else if (TREE_TYPE (type_node)
- && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
- && TYPE_MODULAR_P (TREE_TYPE (type_node)))
- {
- type = copy_node (type);
- TREE_TYPE (type) = TREE_TYPE (type_node);
- }
-
- return type;
-}
-
-/* Return 1 if the types T1 and T2 are compatible, i.e. if they can be
- transparently converted to each other. */
-
-int
-gnat_types_compatible_p (tree t1, tree t2)
-{
- enum tree_code code;
-
- /* This is the default criterion. */
- if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
- return 1;
-
- /* We only check structural equivalence here. */
- if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
- return 0;
-
- /* Array types are also compatible if they are constrained and have
- the same component type and the same domain. */
- if (code == ARRAY_TYPE
- && TREE_TYPE (t1) == TREE_TYPE (t2)
- && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
- TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
- && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
- TYPE_MAX_VALUE (TYPE_DOMAIN (t2))))
- return 1;
-
- /* Padding record types are also compatible if they pad the same
- type and have the same constant size. */
- if (code == RECORD_TYPE
- && TYPE_IS_PADDING_P (t1) && TYPE_IS_PADDING_P (t2)
- && TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2))
- && tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)))
- return 1;
-
- return 0;
-}
-\f
-/* 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. */
-
-tree
-max_size (tree exp, bool max_p)
-{
- enum tree_code code = TREE_CODE (exp);
- tree type = TREE_TYPE (exp);
-
- switch (TREE_CODE_CLASS (code))
- {
- case tcc_declaration:
- case tcc_constant:
- return exp;
-
- case tcc_vl_exp:
- if (code == CALL_EXPR)
- {
- tree *argarray;
- int i, n = call_expr_nargs (exp);
- gcc_assert (n > 0);
-
- argarray = (tree *) alloca (n * sizeof (tree));
- for (i = 0; i < n; i++)
- argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
- return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
- }
- break;
-
- case tcc_reference:
- /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
- modify. Otherwise, we treat it like a variable. */
- if (!CONTAINS_PLACEHOLDER_P (exp))
- return exp;
-
- type = TREE_TYPE (TREE_OPERAND (exp, 1));
- return
- max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
-
- case tcc_comparison:
- return max_p ? size_one_node : size_zero_node;
-
- case tcc_unary:
- case tcc_binary:
- case tcc_expression:
- switch (TREE_CODE_LENGTH (code))
- {
- case 1:
- if (code == NON_LVALUE_EXPR)
- return max_size (TREE_OPERAND (exp, 0), max_p);
- else
- return
- fold_build1 (code, type,
- max_size (TREE_OPERAND (exp, 0),
- code == NEGATE_EXPR ? !max_p : max_p));
-
- case 2:
- if (code == COMPOUND_EXPR)
- return max_size (TREE_OPERAND (exp, 1), max_p);
-
- /* Calculate "(A ? B : C) - D" as "A ? B - D : C - D" which
- may provide a tighter bound on max_size. */
- if (code == MINUS_EXPR
- && TREE_CODE (TREE_OPERAND (exp, 0)) == COND_EXPR)
- {
- tree lhs = fold_build2 (MINUS_EXPR, type,
- TREE_OPERAND (TREE_OPERAND (exp, 0), 1),
- TREE_OPERAND (exp, 1));
- tree rhs = fold_build2 (MINUS_EXPR, type,
- TREE_OPERAND (TREE_OPERAND (exp, 0), 2),
- TREE_OPERAND (exp, 1));
- return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
- max_size (lhs, max_p),
- max_size (rhs, max_p));
- }
-
- {
- tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
- tree rhs = max_size (TREE_OPERAND (exp, 1),
- code == MINUS_EXPR ? !max_p : max_p);
-
- /* Special-case wanting the maximum value of a MIN_EXPR.
- In that case, if one side overflows, return the other.
- sizetype is signed, but we know sizes are non-negative.
- Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
- overflowing or the maximum possible value and the RHS
- a variable. */
- if (max_p
- && code == MIN_EXPR
- && TREE_CODE (rhs) == INTEGER_CST
- && TREE_OVERFLOW (rhs))
- return lhs;
- else if (max_p
- && code == MIN_EXPR
- && TREE_CODE (lhs) == INTEGER_CST
- && TREE_OVERFLOW (lhs))
- return rhs;
- else if ((code == MINUS_EXPR || code == PLUS_EXPR)
- && ((TREE_CODE (lhs) == INTEGER_CST
- && TREE_OVERFLOW (lhs))
- || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
- && !TREE_CONSTANT (rhs))
- return lhs;
- else
- return fold_build2 (code, type, lhs, rhs);
- }
-
- case 3:
- if (code == SAVE_EXPR)
- return exp;
- else if (code == COND_EXPR)
- return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
- max_size (TREE_OPERAND (exp, 1), max_p),
- max_size (TREE_OPERAND (exp, 2), max_p));
- }
-
- /* Other tree classes cannot happen. */
- default:
- break;
- }
-
- gcc_unreachable ();
-}
-\f
-/* 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. */
-
-tree
-build_template (tree template_type, tree array_type, tree expr)
-{
- tree template_elts = NULL_TREE;
- tree bound_list = NULL_TREE;
- tree field;
-
- while (TREE_CODE (array_type) == RECORD_TYPE
- && (TYPE_IS_PADDING_P (array_type)
- || TYPE_JUSTIFIED_MODULAR_P (array_type)))
- array_type = TREE_TYPE (TYPE_FIELDS (array_type));
-
- if (TREE_CODE (array_type) == ARRAY_TYPE
- || (TREE_CODE (array_type) == INTEGER_TYPE
- && TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
- bound_list = TYPE_ACTUAL_BOUNDS (array_type);
-
- /* First make the list for a CONSTRUCTOR for the template. Go down the
- field list of the template instead of the type chain because this
- array might be an Ada array of arrays and we can't tell where the
- nested arrays stop being the underlying object. */
-
- for (field = TYPE_FIELDS (template_type); field;
- (bound_list
- ? (bound_list = TREE_CHAIN (bound_list))
- : (array_type = TREE_TYPE (array_type))),
- field = TREE_CHAIN (TREE_CHAIN (field)))
- {
- tree bounds, min, max;
-
- /* If we have a bound list, get the bounds from there. Likewise
- for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with
- DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template.
- This will give us a maximum range. */
- if (bound_list)
- bounds = TREE_VALUE (bound_list);
- else if (TREE_CODE (array_type) == ARRAY_TYPE)
- bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
- else if (expr && TREE_CODE (expr) == PARM_DECL
- && DECL_BY_COMPONENT_PTR_P (expr))
- bounds = TREE_TYPE (field);
- else
- gcc_unreachable ();
-
- min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds));
- max = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MAX_VALUE (bounds));
-
- /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
- substitute it from OBJECT. */
- min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
- max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
-
- template_elts = tree_cons (TREE_CHAIN (field), max,
- tree_cons (field, min, template_elts));
- }
-
- return gnat_build_constructor (template_type, nreverse (template_elts));
-}
-\f
-/* 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 an entity used
- to print out an error message if the mechanism cannot be applied to
- an object of that type and also for the name. */
-
-tree
-build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
-{
- tree record_type = make_node (RECORD_TYPE);
- tree pointer32_type;
- tree field_list = 0;
- int class;
- int dtype = 0;
- tree inner_type;
- int ndim;
- int i;
- tree *idx_arr;
- tree tem;
-
- /* If TYPE is an unconstrained array, use the underlying array type. */
- if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
- type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
-
- /* If this is an array, compute the number of dimensions in the array,
- get the index types, and point to the inner type. */
- if (TREE_CODE (type) != ARRAY_TYPE)
- ndim = 0;
- else
- for (ndim = 1, inner_type = type;
- TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
- && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
- ndim++, inner_type = TREE_TYPE (inner_type))
- ;
-
- idx_arr = (tree *) alloca (ndim * sizeof (tree));
-
- if (mech != By_Descriptor_NCA
- && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
- for (i = ndim - 1, inner_type = type;
- i >= 0;
- i--, inner_type = TREE_TYPE (inner_type))
- idx_arr[i] = TYPE_DOMAIN (inner_type);
- else
- for (i = 0, inner_type = type;
- i < ndim;
- i++, inner_type = TREE_TYPE (inner_type))
- idx_arr[i] = TYPE_DOMAIN (inner_type);
-
- /* Now get the DTYPE value. */
- switch (TREE_CODE (type))
- {
- case INTEGER_TYPE:
- case ENUMERAL_TYPE:
- if (TYPE_VAX_FLOATING_POINT_P (type))
- switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
- {
- case 6:
- dtype = 10;
- break;
- case 9:
- dtype = 11;
- break;
- case 15:
- dtype = 27;
- break;
- }
- else
- switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
- {
- case 8:
- dtype = TYPE_UNSIGNED (type) ? 2 : 6;
- break;
- case 16:
- dtype = TYPE_UNSIGNED (type) ? 3 : 7;
- break;
- case 32:
- dtype = TYPE_UNSIGNED (type) ? 4 : 8;
- break;
- case 64:
- dtype = TYPE_UNSIGNED (type) ? 5 : 9;
- break;
- case 128:
- dtype = TYPE_UNSIGNED (type) ? 25 : 26;
- break;
- }
- break;
-
- case REAL_TYPE:
- dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
- break;
-
- case COMPLEX_TYPE:
- if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
- && TYPE_VAX_FLOATING_POINT_P (type))
- switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
- {
- case 6:
- dtype = 12;
- break;
- case 9:
- dtype = 13;
- break;
- case 15:
- dtype = 29;
- }
- else
- dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
- break;
-
- case ARRAY_TYPE:
- dtype = 14;
- break;
-
- default:
- break;
- }
-
- /* Get the CLASS value. */
- switch (mech)
- {
- case By_Descriptor_A:
- class = 4;
- break;
- case By_Descriptor_NCA:
- class = 10;
- break;
- case By_Descriptor_SB:
- class = 15;
- break;
- case By_Descriptor:
- case By_Descriptor_S:
- default:
- class = 1;
- break;
- }
-
- /* Make the type for a descriptor for VMS. The first four fields
- are the same for all types. */
-
- field_list
- = chainon (field_list,
- make_descriptor_field
- ("LENGTH", gnat_type_for_size (16, 1), record_type,
- size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
-
- field_list = chainon (field_list,
- make_descriptor_field ("DTYPE",
- gnat_type_for_size (8, 1),
- record_type, size_int (dtype)));
- field_list = chainon (field_list,
- make_descriptor_field ("CLASS",
- gnat_type_for_size (8, 1),
- record_type, size_int (class)));
-
- /* Of course this will crash at run-time if the address space is not
- within the low 32 bits, but there is nothing else we can do. */
- pointer32_type = build_pointer_type_for_mode (type, SImode, false);
-
- field_list
- = chainon (field_list,
- make_descriptor_field
- ("POINTER", pointer32_type, record_type,
- build_unary_op (ADDR_EXPR,
- pointer32_type,
- build0 (PLACEHOLDER_EXPR, type))));
-
- switch (mech)
- {
- case By_Descriptor:
- case By_Descriptor_S:
- break;
-
- case By_Descriptor_SB:
- field_list
- = chainon (field_list,
- make_descriptor_field
- ("SB_L1", gnat_type_for_size (32, 1), record_type,
- TREE_CODE (type) == ARRAY_TYPE
- ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
- field_list
- = chainon (field_list,
- make_descriptor_field
- ("SB_U1", gnat_type_for_size (32, 1), record_type,
- TREE_CODE (type) == ARRAY_TYPE
- ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
- break;
-
- case By_Descriptor_A:
- case By_Descriptor_NCA:
- field_list = chainon (field_list,
- make_descriptor_field ("SCALE",
- gnat_type_for_size (8, 1),
- record_type,
- size_zero_node));
-
- field_list = chainon (field_list,
- make_descriptor_field ("DIGITS",
- gnat_type_for_size (8, 1),
- record_type,
- size_zero_node));
-
- field_list
- = chainon (field_list,
- make_descriptor_field
- ("AFLAGS", gnat_type_for_size (8, 1), record_type,
- size_int (mech == By_Descriptor_NCA
- ? 0
- /* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
- : (TREE_CODE (type) == ARRAY_TYPE
- && TYPE_CONVENTION_FORTRAN_P (type)
- ? 224 : 192))));
-
- field_list = chainon (field_list,
- make_descriptor_field ("DIMCT",
- gnat_type_for_size (8, 1),
- record_type,
- size_int (ndim)));
-
- field_list = chainon (field_list,
- make_descriptor_field ("ARSIZE",
- gnat_type_for_size (32, 1),
- record_type,
- size_in_bytes (type)));
-
- /* Now build a pointer to the 0,0,0... element. */
- tem = build0 (PLACEHOLDER_EXPR, type);
- for (i = 0, inner_type = type; i < ndim;
- i++, inner_type = TREE_TYPE (inner_type))
- tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
- convert (TYPE_DOMAIN (inner_type), size_zero_node),
- NULL_TREE, NULL_TREE);
-
- field_list
- = chainon (field_list,
- make_descriptor_field
- ("A0",
- build_pointer_type_for_mode (inner_type, SImode, false),
- record_type,
- build1 (ADDR_EXPR,
- build_pointer_type_for_mode (inner_type, SImode,
- false),
- tem)));
-
- /* Next come the addressing coefficients. */
- tem = size_one_node;
- for (i = 0; i < ndim; i++)
- {
- char fname[3];
- tree idx_length
- = size_binop (MULT_EXPR, tem,
- size_binop (PLUS_EXPR,
- size_binop (MINUS_EXPR,
- TYPE_MAX_VALUE (idx_arr[i]),
- TYPE_MIN_VALUE (idx_arr[i])),
- size_int (1)));
-
- fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
- fname[1] = '0' + i, fname[2] = 0;
- field_list
- = chainon (field_list,
- make_descriptor_field (fname,
- gnat_type_for_size (32, 1),
- record_type, idx_length));
-
- if (mech == By_Descriptor_NCA)
- tem = idx_length;
- }
-
- /* Finally here are the bounds. */
- for (i = 0; i < ndim; i++)
- {
- char fname[3];
-
- fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
- field_list
- = chainon (field_list,
- make_descriptor_field
- (fname, gnat_type_for_size (32, 1), record_type,
- TYPE_MIN_VALUE (idx_arr[i])));
-
- fname[0] = 'U';
- field_list
- = chainon (field_list,
- make_descriptor_field
- (fname, gnat_type_for_size (32, 1), record_type,
- TYPE_MAX_VALUE (idx_arr[i])));
- }
- break;
-
- default:
- post_error ("unsupported descriptor type for &", gnat_entity);
- }
-
- finish_record_type (record_type, field_list, 0, true);
- create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
- NULL, true, false, gnat_entity);
-
- return record_type;
-}
-
-/* Utility routine for above code to make a field. */
-
-static tree
-make_descriptor_field (const char *name, tree type,
- tree rec_type, tree initial)
-{
- tree field
- = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
-
- DECL_INITIAL (field) = initial;
- return field;
-}
-
-/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
- pointer or fat pointer type. GNAT_SUBPROG is the subprogram to which
- the VMS descriptor is passed. */
-
-static tree
-convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
-{
- tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
- tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
- /* The CLASS field is the 3rd field in the descriptor. */
- tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
- /* The POINTER field is the 4th field in the descriptor. */
- tree pointer = TREE_CHAIN (class);
-
- /* Retrieve the value of the POINTER field. */
- gnu_expr
- = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
-
- if (POINTER_TYPE_P (gnu_type))
- return convert (gnu_type, gnu_expr);
-
- else if (TYPE_FAT_POINTER_P (gnu_type))
- {
- tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
- tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
- tree template_type = TREE_TYPE (p_bounds_type);
- tree min_field = TYPE_FIELDS (template_type);
- tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
- tree template, template_addr, aflags, dimct, t, u;
- /* See the head comment of build_vms_descriptor. */
- int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class));
-
- /* Convert POINTER to the type of the P_ARRAY field. */
- gnu_expr = convert (p_array_type, gnu_expr);
-
- switch (iclass)
- {
- case 1: /* Class S */
- case 15: /* Class SB */
- /* Build {1, LENGTH} template; LENGTH is the 1st field. */
- t = TYPE_FIELDS (desc_type);
- t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
- t = tree_cons (min_field,
- convert (TREE_TYPE (min_field), integer_one_node),
- tree_cons (max_field,
- convert (TREE_TYPE (max_field), t),
- NULL_TREE));
- template = gnat_build_constructor (template_type, t);
- template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
-
- /* For class S, we are done. */
- if (iclass == 1)
- break;
-
- /* Test that we really have a SB descriptor, like DEC Ada. */
- t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL);
- u = convert (TREE_TYPE (class), DECL_INITIAL (class));
- u = build_binary_op (EQ_EXPR, integer_type_node, t, u);
- /* If so, there is already a template in the descriptor and
- it is located right after the POINTER field. */
- t = TREE_CHAIN (pointer);
- template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
- /* Otherwise use the {1, LENGTH} template we build above. */
- template_addr = build3 (COND_EXPR, p_bounds_type, u,
- build_unary_op (ADDR_EXPR, p_bounds_type,
- template),
- template_addr);
- break;
-
- case 4: /* Class A */
- /* The AFLAGS field is the 7th field in the descriptor. */
- t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer)));
- aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
- /* The DIMCT field is the 8th field in the descriptor. */
- t = TREE_CHAIN (t);
- dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
- /* Raise CONSTRAINT_ERROR if either more than 1 dimension
- or FL_COEFF or FL_BOUNDS not set. */
- u = build_int_cst (TREE_TYPE (aflags), 192);
- u = build_binary_op (TRUTH_OR_EXPR, integer_type_node,
- build_binary_op (NE_EXPR, integer_type_node,
- dimct,
- convert (TREE_TYPE (dimct),
- size_one_node)),
- build_binary_op (NE_EXPR, integer_type_node,
- build2 (BIT_AND_EXPR,
- TREE_TYPE (aflags),
- aflags, u),
- u));
- add_stmt (build3 (COND_EXPR, void_type_node, u,
- build_call_raise (CE_Length_Check_Failed, Empty,
- N_Raise_Constraint_Error),
- NULL_TREE));
- /* There is already a template in the descriptor and it is
- located at the start of block 3 (12th field). */
- t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t))));
- template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
- template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template);
- break;
-
- case 10: /* Class NCA */
- default:
- post_error ("unsupported descriptor type for &", gnat_subprog);
- template_addr = integer_zero_node;
- break;
- }
-
- /* Build the fat pointer in the form of a constructor. */
- t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr,
- tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)),
- template_addr, NULL_TREE));
- return gnat_build_constructor (gnu_type, t);
- }
-
- else
- gcc_unreachable ();
-}
-
-/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
- and the GNAT node GNAT_SUBPROG. */
-
-void
-build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog)
-{
- tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call;
- tree gnu_stub_param, gnu_param_list, gnu_arg_types, gnu_param;
- tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog);
- tree gnu_body;
-
- gnu_subprog_type = TREE_TYPE (gnu_subprog);
- gnu_param_list = NULL_TREE;
-
- begin_subprog_body (gnu_stub_decl);
- gnat_pushlevel ();
-
- start_stmt_group ();
-
- /* Loop over the parameters of the stub and translate any of them
- passed by descriptor into a by reference one. */
- for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl),
- gnu_arg_types = TYPE_ARG_TYPES (gnu_subprog_type);
- gnu_stub_param;
- gnu_stub_param = TREE_CHAIN (gnu_stub_param),
- gnu_arg_types = TREE_CHAIN (gnu_arg_types))
- {
- if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
- gnu_param = convert_vms_descriptor (TREE_VALUE (gnu_arg_types),
- gnu_stub_param, gnat_subprog);
- else
- gnu_param = gnu_stub_param;
-
- gnu_param_list = tree_cons (NULL_TREE, gnu_param, gnu_param_list);
- }
-
- gnu_body = end_stmt_group ();
-
- /* Invoke the internal subprogram. */
- gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type),
- gnu_subprog);
- gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type),
- gnu_subprog_addr,
- nreverse (gnu_param_list));
-
- /* Propagate the return value, if any. */
- if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type)))
- append_to_statement_list (gnu_subprog_call, &gnu_body);
- else
- append_to_statement_list (build_return_expr (DECL_RESULT (gnu_stub_decl),
- gnu_subprog_call),
- &gnu_body);
-
- gnat_poplevel ();
-
- allocate_struct_function (gnu_stub_decl, false);
- end_subprog_body (gnu_body, false);
-}
-\f
-/* 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. */
-
-tree
-build_unc_object_type (tree template_type, tree object_type, tree name)
-{
- tree type = make_node (RECORD_TYPE);
- tree template_field = create_field_decl (get_identifier ("BOUNDS"),
- template_type, type, 0, 0, 0, 1);
- tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type,
- type, 0, 0, 0, 1);
-
- TYPE_NAME (type) = name;
- TYPE_CONTAINS_TEMPLATE_P (type) = 1;
- finish_record_type (type,
- chainon (chainon (NULL_TREE, template_field),
- array_field),
- 0, false);
-
- return type;
-}
-
-/* Same, taking a thin or fat pointer type instead of a template type. */
-
-tree
-build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
- tree name)
-{
- tree template_type;
-
- gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
-
- template_type
- = (TYPE_FAT_POINTER_P (thin_fat_ptr_type)
- ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
- : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
- return build_unc_object_type (template_type, object_type, name);
-}
-
-/* Shift the component offsets within an unconstrained object TYPE to make it
- suitable for use as a designated type for thin pointers. */
-
-void
-shift_unc_components_for_thin_pointers (tree type)
-{
- /* Thin pointer values designate the ARRAY data of an unconstrained object,
- allocated past the BOUNDS template. The designated type is adjusted to
- have ARRAY at position zero and the template at a negative offset, so
- that COMPONENT_REFs on (*thin_ptr) designate the proper location. */
-
- tree bounds_field = TYPE_FIELDS (type);
- tree array_field = TREE_CHAIN (TYPE_FIELDS (type));
-
- DECL_FIELD_OFFSET (bounds_field)
- = size_binop (MINUS_EXPR, size_zero_node, byte_position (array_field));
-
- DECL_FIELD_OFFSET (array_field) = size_zero_node;
- DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node;
-}
-\f
-/* 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. */
-
-void
-update_pointer_to (tree old_type, tree new_type)
-{
- tree ptr = TYPE_POINTER_TO (old_type);
- tree ref = TYPE_REFERENCE_TO (old_type);
- tree ptr1, ref1;
- tree type;
-
- /* If this is the main variant, process all the other variants first. */
- if (TYPE_MAIN_VARIANT (old_type) == old_type)
- for (type = TYPE_NEXT_VARIANT (old_type); type;
- type = TYPE_NEXT_VARIANT (type))
- update_pointer_to (type, new_type);
-
- /* If no pointer or reference, we are done. */
- if (!ptr && !ref)
- return;
-
- /* Merge the old type qualifiers in the new type.
-
- Each old variant has qualifiers for specific reasons, and the new
- designated type as well. Each set of qualifiers represents useful
- information grabbed at some point, and merging the two simply unifies
- these inputs into the final type description.
-
- Consider for instance a volatile type frozen after an access to constant
- type designating it. After the designated type freeze, we get here with a
- volatile new_type and a dummy old_type with a readonly variant, created
- when the access type was processed. We shall make a volatile and readonly
- designated type, because that's what it really is.
-
- We might also get here for a non-dummy old_type variant with different
- qualifiers than the new_type ones, for instance in some cases of pointers
- to private record type elaboration (see the comments around the call to
- this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
- qualifiers in those cases too, to avoid accidentally discarding the
- initial set, and will often end up with old_type == new_type then. */
- new_type = build_qualified_type (new_type,
- TYPE_QUALS (old_type)
- | TYPE_QUALS (new_type));
-
- /* If the new type and the old one are identical, there is nothing to
- update. */
- if (old_type == new_type)
- return;
-
- /* Otherwise, first handle the simple case. */
- if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
- {
- TYPE_POINTER_TO (new_type) = ptr;
- TYPE_REFERENCE_TO (new_type) = ref;
-
- for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
- for (ptr1 = TYPE_MAIN_VARIANT (ptr); ptr1;
- ptr1 = TYPE_NEXT_VARIANT (ptr1))
- TREE_TYPE (ptr1) = new_type;
-
- for (; ref; ref = TYPE_NEXT_REF_TO (ref))
- for (ref1 = TYPE_MAIN_VARIANT (ref); ref1;
- ref1 = TYPE_NEXT_VARIANT (ref1))
- TREE_TYPE (ref1) = new_type;
- }
-
- /* Now deal with the unconstrained array case. In this case the "pointer"
- is actually a RECORD_TYPE where both fields are pointers to dummy nodes.
- Turn them into pointers to the correct types using update_pointer_to. */
- else if (TREE_CODE (ptr) != RECORD_TYPE || !TYPE_IS_FAT_POINTER_P (ptr))
- gcc_unreachable ();
-
- else
- {
- tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type);
- tree array_field = TYPE_FIELDS (ptr);
- tree bounds_field = TREE_CHAIN (TYPE_FIELDS (ptr));
- tree new_ptr = TYPE_POINTER_TO (new_type);
- tree new_ref;
- tree var;
-
- /* Make pointers to the dummy template point to the real template. */
- update_pointer_to
- (TREE_TYPE (TREE_TYPE (bounds_field)),
- TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_ptr)))));
-
- /* The references to the template bounds present in the array type
- are made through a PLACEHOLDER_EXPR of type new_ptr. Since we
- are updating ptr to make it a full replacement for new_ptr as
- pointer to new_type, we must rework the PLACEHOLDER_EXPR so as
- to make it of type ptr. */
- new_ref = build3 (COMPONENT_REF, TREE_TYPE (bounds_field),
- build0 (PLACEHOLDER_EXPR, ptr),
- bounds_field, NULL_TREE);
-
- /* Create the new array for the new PLACEHOLDER_EXPR and make
- pointers to the dummy array point to it.
-
- ??? This is now the only use of substitute_in_type,
- which is a very "heavy" routine to do this, so it
- should be replaced at some point. */
- update_pointer_to
- (TREE_TYPE (TREE_TYPE (array_field)),
- substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))),
- TREE_CHAIN (TYPE_FIELDS (new_ptr)), new_ref));
-
- /* Make ptr the pointer to new_type. */
- TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
- = TREE_TYPE (new_type) = ptr;
-
- for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
- SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type);
-
- /* Now handle updating the allocation record, what the thin pointer
- points to. Update all pointers from the old record into the new
- one, update the type of the array field, and recompute the size. */
- update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec);
-
- TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
- = TREE_TYPE (TREE_TYPE (array_field));
-
- /* The size recomputation needs to account for alignment constraints, so
- we let layout_type work it out. This will reset the field offsets to
- what they would be in a regular record, so we shift them back to what
- we want them to be for a thin pointer designated type afterwards. */
- DECL_SIZE (TYPE_FIELDS (new_obj_rec)) = 0;
- DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))) = 0;
- TYPE_SIZE (new_obj_rec) = 0;
- layout_type (new_obj_rec);
-
- shift_unc_components_for_thin_pointers (new_obj_rec);
-
- /* We are done, at last. */
- rest_of_record_type_compilation (ptr);
- }
-}
-\f
-/* Convert a pointer to a constrained array into a pointer to a fat
- pointer. This involves making or finding a template. */
-
-static tree
-convert_to_fat_pointer (tree type, tree expr)
-{
- tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
- tree template, template_addr;
- tree etype = TREE_TYPE (expr);
-
- /* If EXPR is a constant of zero, we make a fat pointer that has a null
- pointer to the template and array. */
- if (integer_zerop (expr))
- return
- gnat_build_constructor
- (type,
- tree_cons (TYPE_FIELDS (type),
- convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
- tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
- convert (build_pointer_type (template_type),
- expr),
- NULL_TREE)));
-
- /* If EXPR is a thin pointer, make the template and data from the record. */
-
- else if (TYPE_THIN_POINTER_P (etype))
- {
- tree fields = TYPE_FIELDS (TREE_TYPE (etype));
-
- expr = save_expr (expr);
- if (TREE_CODE (expr) == ADDR_EXPR)
- expr = TREE_OPERAND (expr, 0);
- else
- expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
-
- template = build_component_ref (expr, NULL_TREE, fields, false);
- expr = build_unary_op (ADDR_EXPR, NULL_TREE,
- build_component_ref (expr, NULL_TREE,
- TREE_CHAIN (fields), false));
- }
- else
- /* Otherwise, build the constructor for the template. */
- template = build_template (template_type, TREE_TYPE (etype), expr);
-
- template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
-
- /* The result is a CONSTRUCTOR for the fat pointer.
-
- If expr is an argument of a foreign convention subprogram, the type it
- points to is directly the component type. In this case, the expression
- type may not match the corresponding FIELD_DECL type at this point, so we
- call "convert" here to fix that up if necessary. This type consistency is
- required, for instance because it ensures that possible later folding of
- component_refs against this constructor always yields something of the
- same type as the initial reference.
-
- Note that the call to "build_template" above is still fine, because it
- will only refer to the provided template_type in this case. */
- return
- gnat_build_constructor
- (type, tree_cons (TYPE_FIELDS (type),
- convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
- tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
- template_addr, NULL_TREE)));
-}
-\f
-/* Convert to a thin pointer type, TYPE. The only thing we know how to convert
- is something that is a fat pointer, so convert to it first if it EXPR
- is not already a fat pointer. */
-
-static tree
-convert_to_thin_pointer (tree type, tree expr)
-{
- if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr)))
- expr
- = convert_to_fat_pointer
- (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
-
- /* We get the pointer to the data and use a NOP_EXPR to make it the
- proper GCC type. */
- expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)),
- false);
- expr = build1 (NOP_EXPR, type, expr);
-
- return expr;
-}
-\f
-/* 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. */
-
-tree
-convert (tree type, tree expr)
-{
- enum tree_code code = TREE_CODE (type);
- tree etype = TREE_TYPE (expr);
- enum tree_code ecode = TREE_CODE (etype);
-
- /* If EXPR is already the right type, we are done. */
- if (type == etype)
- return expr;
-
- /* If both input and output have padding and are of variable size, do this
- as an unchecked conversion. Likewise if one is a mere variant of the
- other, so we avoid a pointless unpad/repad sequence. */
- else if (code == RECORD_TYPE && ecode == RECORD_TYPE
- && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
- && (!TREE_CONSTANT (TYPE_SIZE (type))
- || !TREE_CONSTANT (TYPE_SIZE (etype))
- || gnat_types_compatible_p (type, etype)
- || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))
- == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype)))))
- ;
-
- /* If the output type has padding, convert to the inner type and
- make a constructor to build the record. */
- else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
- {
- /* If we previously converted from another type and our type is
- of variable size, remove the conversion to avoid the need for
- variable-size temporaries. Likewise for a conversion between
- original and packable version. */
- if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
- && (!TREE_CONSTANT (TYPE_SIZE (type))
- || (ecode == RECORD_TYPE
- && TYPE_NAME (etype)
- == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0))))))
- expr = TREE_OPERAND (expr, 0);
-
- /* If we are just removing the padding from expr, convert the original
- object if we have variable size in order to avoid the need for some
- variable-size temporaries. Likewise if the padding is a mere variant
- of the other, so we avoid a pointless unpad/repad sequence. */
- if (TREE_CODE (expr) == COMPONENT_REF
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
- && (!TREE_CONSTANT (TYPE_SIZE (type))
- || gnat_types_compatible_p (type,
- TREE_TYPE (TREE_OPERAND (expr, 0)))
- || (ecode == RECORD_TYPE
- && TYPE_NAME (etype)
- == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))))))
- return convert (type, TREE_OPERAND (expr, 0));
-
- /* If the result type is a padded type with a self-referentially-sized
- field and the expression type is a record, do this as an
- unchecked conversion. */
- else if (TREE_CODE (etype) == RECORD_TYPE
- && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
- return unchecked_convert (type, expr, false);
-
- else
- return
- gnat_build_constructor (type,
- tree_cons (TYPE_FIELDS (type),
- convert (TREE_TYPE
- (TYPE_FIELDS (type)),
- expr),
- NULL_TREE));
- }
-
- /* If the input type has padding, remove it and convert to the output type.
- The conditions ordering is arranged to ensure that the output type is not
- a padding type here, as it is not clear whether the conversion would
- always be correct if this was to happen. */
- else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
- {
- tree unpadded;
-
- /* If we have just converted to this padded type, just get the
- inner expression. */
- if (TREE_CODE (expr) == CONSTRUCTOR
- && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr))
- && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index
- == TYPE_FIELDS (etype))
- unpadded
- = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value;
-
- /* Otherwise, build an explicit component reference. */
- else
- unpadded
- = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false);
-
- return convert (type, unpadded);
- }
-
- /* If the input is a biased type, adjust first. */
- if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
- return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
- fold_convert (TREE_TYPE (etype),
- expr),
- TYPE_MIN_VALUE (etype)));
-
- /* If the input is a justified modular type, we need to extract the actual
- object before converting it to any other type with the exceptions of an
- unconstrained array or of a mere type variant. It is useful to avoid the
- extraction and conversion in the type variant case because it could end
- up replacing a VAR_DECL expr by a constructor and we might be about the
- take the address of the result. */
- if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
- && code != UNCONSTRAINED_ARRAY_TYPE
- && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
- return convert (type, build_component_ref (expr, NULL_TREE,
- TYPE_FIELDS (etype), false));
-
- /* If converting to a type that contains a template, convert to the data
- type and then build the template. */
- if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
- {
- tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
-
- /* If the source already has a template, get a reference to the
- associated array only, as we are going to rebuild a template
- for the target type anyway. */
- expr = maybe_unconstrained_array (expr);
-
- return
- gnat_build_constructor
- (type,
- tree_cons (TYPE_FIELDS (type),
- build_template (TREE_TYPE (TYPE_FIELDS (type)),
- obj_type, NULL_TREE),
- tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
- convert (obj_type, expr), NULL_TREE)));
- }
-
- /* There are some special cases of expressions that we process
- specially. */
- switch (TREE_CODE (expr))
- {
- case ERROR_MARK:
- return expr;
-
- case NULL_EXPR:
- /* Just set its type here. For TRANSFORM_EXPR, we will do the actual
- conversion in gnat_expand_expr. NULL_EXPR does not represent
- and actual value, so no conversion is needed. */
- expr = copy_node (expr);
- TREE_TYPE (expr) = type;
- return expr;
-
- case STRING_CST:
- /* If we are converting a STRING_CST to another constrained array type,
- just make a new one in the proper type. */
- if (code == ecode && AGGREGATE_TYPE_P (etype)
- && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
- {
- expr = copy_node (expr);
- TREE_TYPE (expr) = type;
- return expr;
- }
- break;
-
- case CONSTRUCTOR:
- /* If we are converting a CONSTRUCTOR to a mere variant type, just make
- a new one in the proper type. */
- if (code == ecode && gnat_types_compatible_p (type, etype))
- {
- expr = copy_node (expr);
- TREE_TYPE (expr) = type;
- return expr;
- }
-
- /* Likewise for a conversion between original and packable version, but
- we have to work harder in order to preserve type consistency. */
- if (code == ecode
- && code == RECORD_TYPE
- && TYPE_NAME (type) == TYPE_NAME (etype))
- {
- VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr);
- unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e);
- VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, len);
- tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type);
- unsigned HOST_WIDE_INT idx;
- tree index, value;
-
- FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value)
- {
- constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL);
- /* We expect only simple constructors. Otherwise, punt. */
- if (!(index == efield || index == DECL_ORIGINAL_FIELD (efield)))
- break;
- elt->index = field;
- elt->value = convert (TREE_TYPE (field), value);
- efield = TREE_CHAIN (efield);
- field = TREE_CHAIN (field);
- }
-
- if (idx == len)
- {
- expr = copy_node (expr);
- TREE_TYPE (expr) = type;
- CONSTRUCTOR_ELTS (expr) = v;
- return expr;
- }
- }
- break;
-
- case UNCONSTRAINED_ARRAY_REF:
- /* Convert this to the type of the inner array by getting the address of
- the array from the template. */
- expr = build_unary_op (INDIRECT_REF, NULL_TREE,
- build_component_ref (TREE_OPERAND (expr, 0),
- get_identifier ("P_ARRAY"),
- NULL_TREE, false));
- etype = TREE_TYPE (expr);
- ecode = TREE_CODE (etype);
- break;
-
- case VIEW_CONVERT_EXPR:
- {
- /* GCC 4.x is very sensitive to type consistency overall, and view
- conversions thus are very frequent. Even though just "convert"ing
- the inner operand to the output type is fine in most cases, it
- might expose unexpected input/output type mismatches in special
- circumstances so we avoid such recursive calls when we can. */
- tree op0 = TREE_OPERAND (expr, 0);
-
- /* If we are converting back to the original type, we can just
- lift the input conversion. This is a common occurrence with
- switches back-and-forth amongst type variants. */
- if (type == TREE_TYPE (op0))
- return op0;
-
- /* Otherwise, if we're converting between two aggregate types, we
- might be allowed to substitute the VIEW_CONVERT_EXPR target type
- in place or to just convert the inner expression. */
- if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
- {
- /* If we are converting between mere variants, we can just
- substitute the VIEW_CONVERT_EXPR in place. */
- if (gnat_types_compatible_p (type, etype))
- return build1 (VIEW_CONVERT_EXPR, type, op0);
-
- /* Otherwise, we may just bypass the input view conversion unless
- one of the types is a fat pointer, which is handled by
- specialized code below which relies on exact type matching. */
- else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
- return convert (type, op0);
- }
- }
- break;
-
- case INDIRECT_REF:
- /* If both types are record types, just convert the pointer and
- make a new INDIRECT_REF.
-
- ??? Disable this for now since it causes problems with the
- code in build_binary_op for MODIFY_EXPR which wants to
- strip off conversions. But that code really is a mess and
- we need to do this a much better way some time. */
- if (0
- && (TREE_CODE (type) == RECORD_TYPE
- || TREE_CODE (type) == UNION_TYPE)
- && (TREE_CODE (etype) == RECORD_TYPE
- || TREE_CODE (etype) == UNION_TYPE)
- && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
- return build_unary_op (INDIRECT_REF, NULL_TREE,
- convert (build_pointer_type (type),
- TREE_OPERAND (expr, 0)));
- break;
-
- default:
- break;
- }
-
- /* Check for converting to a pointer to an unconstrained array. */
- if (TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
- return convert_to_fat_pointer (type, expr);
-
- /* If we are converting between two aggregate types that are mere
- variants, just make a VIEW_CONVERT_EXPR. */
- else if (code == ecode
- && AGGREGATE_TYPE_P (type)
- && gnat_types_compatible_p (type, etype))
- return build1 (VIEW_CONVERT_EXPR, type, expr);
-
- /* In all other cases of related types, make a NOP_EXPR. */
- else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
- || (code == INTEGER_CST && ecode == INTEGER_CST
- && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type))))
- return fold_convert (type, expr);
-
- switch (code)
- {
- case VOID_TYPE:
- return fold_build1 (CONVERT_EXPR, type, expr);
-
- case BOOLEAN_TYPE:
- return fold_convert (type, gnat_truthvalue_conversion (expr));
-
- case INTEGER_TYPE:
- if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
- && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
- || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
- return unchecked_convert (type, expr, false);
- else if (TYPE_BIASED_REPRESENTATION_P (type))
- return fold_convert (type,
- fold_build2 (MINUS_EXPR, TREE_TYPE (type),
- convert (TREE_TYPE (type), expr),
- TYPE_MIN_VALUE (type)));
-
- /* ... fall through ... */
-
- case ENUMERAL_TYPE:
- /* If we are converting an additive expression to an integer type
- with lower precision, be wary of the optimization that can be
- applied by convert_to_integer. There are 2 problematic cases:
- - if the first operand was originally of a biased type,
- because we could be recursively called to convert it
- to an intermediate type and thus rematerialize the
- additive operator endlessly,
- - if the expression contains a placeholder, because an
- intermediate conversion that changes the sign could
- be inserted and thus introduce an artificial overflow
- at compile time when the placeholder is substituted. */
- if (code == INTEGER_TYPE
- && ecode == INTEGER_TYPE
- && TYPE_PRECISION (type) < TYPE_PRECISION (etype)
- && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR))
- {
- tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type);
-
- if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE
- && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0)))
- || CONTAINS_PLACEHOLDER_P (expr))
- return build1 (NOP_EXPR, type, expr);
- }
-
- return fold (convert_to_integer (type, expr));
-
- case POINTER_TYPE:
- case REFERENCE_TYPE:
- /* If converting between two pointers to records denoting
- both a template and type, adjust if needed to account
- for any differing offsets, since one might be negative. */
- if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type))
- {
- tree bit_diff
- = size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
- bit_position (TYPE_FIELDS (TREE_TYPE (type))));
- tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff,
- sbitsize_int (BITS_PER_UNIT));
-
- expr = build1 (NOP_EXPR, type, expr);
- TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
- if (integer_zerop (byte_diff))
- return expr;
-
- return build_binary_op (POINTER_PLUS_EXPR, type, expr,
- fold (convert (sizetype, byte_diff)));
- }
-
- /* If converting to a thin pointer, handle specially. */
- if (TYPE_THIN_POINTER_P (type)
- && TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
- return convert_to_thin_pointer (type, expr);
-
- /* If converting fat pointer to normal pointer, get the pointer to the
- array and then convert it. */
- else if (TYPE_FAT_POINTER_P (etype))
- expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
- NULL_TREE, false);
-
- return fold (convert_to_pointer (type, expr));
-
- case REAL_TYPE:
- return fold (convert_to_real (type, expr));
-
- case RECORD_TYPE:
- if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype))
- return
- gnat_build_constructor
- (type, tree_cons (TYPE_FIELDS (type),
- convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
- NULL_TREE));
-
- /* ... fall through ... */
-
- case ARRAY_TYPE:
- /* In these cases, assume the front-end has validated the conversion.
- If the conversion is valid, it will be a bit-wise conversion, so
- it can be viewed as an unchecked conversion. */
- return unchecked_convert (type, expr, false);
-
- case UNION_TYPE:
- /* This is a either a conversion between a tagged type and some
- subtype, which we have to mark as a UNION_TYPE because of
- overlapping fields or a conversion of an Unchecked_Union. */
- return unchecked_convert (type, expr, false);
-
- case UNCONSTRAINED_ARRAY_TYPE:
- /* If EXPR is a constrained array, take its address, convert it to a
- fat pointer, and then dereference it. Likewise if EXPR is a
- record containing both a template and a constrained array.
- Note that a record representing a justified modular type
- always represents a packed constrained array. */
- if (ecode == ARRAY_TYPE
- || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
- || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
- || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
- return
- build_unary_op
- (INDIRECT_REF, NULL_TREE,
- convert_to_fat_pointer (TREE_TYPE (type),
- build_unary_op (ADDR_EXPR,
- NULL_TREE, expr)));
-
- /* Do something very similar for converting one unconstrained
- array to another. */
- else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
- return
- build_unary_op (INDIRECT_REF, NULL_TREE,
- convert (TREE_TYPE (type),
- build_unary_op (ADDR_EXPR,
- NULL_TREE, expr)));
- else
- gcc_unreachable ();
-
- case COMPLEX_TYPE:
- return fold (convert_to_complex (type, expr));
-
- default:
- gcc_unreachable ();
- }
-}
-\f
-/* Remove all conversions that are done in EXP. This includes converting
- from a padded type or to a justified modular type. If TRUE_ADDRESS
- is true, always return the address of the containing object even if
- the address is not bit-aligned. */
-
-tree
-remove_conversions (tree exp, bool true_address)
-{
- switch (TREE_CODE (exp))
- {
- case CONSTRUCTOR:
- if (true_address
- && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
- return
- remove_conversions (VEC_index (constructor_elt,
- CONSTRUCTOR_ELTS (exp), 0)->value,
- true);
- break;
-
- case COMPONENT_REF:
- if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
- return remove_conversions (TREE_OPERAND (exp, 0), true_address);
- break;
-
- case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR:
- CASE_CONVERT:
- return remove_conversions (TREE_OPERAND (exp, 0), true_address);
-
- default:
- break;
- }
-
- return exp;
-}
-\f
-/* 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. */
-
-tree
-maybe_unconstrained_array (tree exp)
-{
- enum tree_code code = TREE_CODE (exp);
- tree new;
-
- switch (TREE_CODE (TREE_TYPE (exp)))
- {
- case UNCONSTRAINED_ARRAY_TYPE:
- if (code == UNCONSTRAINED_ARRAY_REF)
- {
- new
- = build_unary_op (INDIRECT_REF, NULL_TREE,
- build_component_ref (TREE_OPERAND (exp, 0),
- get_identifier ("P_ARRAY"),
- NULL_TREE, false));
- TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
- return new;
- }
-
- else if (code == NULL_EXPR)
- return build1 (NULL_EXPR,
- TREE_TYPE (TREE_TYPE (TYPE_FIELDS
- (TREE_TYPE (TREE_TYPE (exp))))),
- TREE_OPERAND (exp, 0));
-
- case RECORD_TYPE:
- /* If this is a padded type, convert to the unpadded type and see if
- it contains a template. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
- {
- new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
- if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
- return
- build_component_ref (new, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
- 0);
- }
- else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
- return
- build_component_ref (exp, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
- break;
-
- default:
- break;
- }
-
- return exp;
-}
-\f
-/* Return an expression that does an unchecked conversion of EXPR to TYPE.
- If NOTRUNC_P is true, truncation operations should be suppressed. */
-
-tree
-unchecked_convert (tree type, tree expr, bool notrunc_p)
-{
- tree etype = TREE_TYPE (expr);
-
- /* If the expression is already the right type, we are done. */
- if (etype == type)
- return expr;
-
- /* If both types types are integral just do a normal conversion.
- Likewise for a conversion to an unconstrained array. */
- if ((((INTEGRAL_TYPE_P (type)
- && !(TREE_CODE (type) == INTEGER_TYPE
- && TYPE_VAX_FLOATING_POINT_P (type)))
- || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type))
- || (TREE_CODE (type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (type)))
- && ((INTEGRAL_TYPE_P (etype)
- && !(TREE_CODE (etype) == INTEGER_TYPE
- && TYPE_VAX_FLOATING_POINT_P (etype)))
- || (POINTER_TYPE_P (etype) && !TYPE_THIN_POINTER_P (etype))
- || (TREE_CODE (etype) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (etype))))
- || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
- {
- tree rtype = type;
- bool final_unchecked = false;
-
- if (TREE_CODE (etype) == INTEGER_TYPE
- && TYPE_BIASED_REPRESENTATION_P (etype))
- {
- tree ntype = copy_type (etype);
-
- TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
- TYPE_MAIN_VARIANT (ntype) = ntype;
- expr = build1 (NOP_EXPR, ntype, expr);
- }
-
- if (TREE_CODE (type) == INTEGER_TYPE
- && TYPE_BIASED_REPRESENTATION_P (type))
- {
- rtype = copy_type (type);
- TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
- TYPE_MAIN_VARIANT (rtype) = rtype;
- }
-
- /* We have another special case: if we are unchecked converting subtype
- into a base type, we need to ensure that VRP doesn't propagate range
- information since this conversion may be done precisely to validate
- that the object is within the range it is supposed to have. */
- else if (TREE_CODE (expr) != INTEGER_CST
- && TREE_CODE (type) == INTEGER_TYPE && !TREE_TYPE (type)
- && ((TREE_CODE (etype) == INTEGER_TYPE && TREE_TYPE (etype))
- || TREE_CODE (etype) == ENUMERAL_TYPE
- || TREE_CODE (etype) == BOOLEAN_TYPE))
- {
- /* The optimization barrier is a VIEW_CONVERT_EXPR node; moreover,
- in order not to be deemed an useless type conversion, it must
- be from subtype to base type.
-
- ??? This may raise addressability and/or aliasing issues because
- VIEW_CONVERT_EXPR gets gimplified as an lvalue, thus causing the
- address of its operand to be taken if it is deemed addressable
- and not already in GIMPLE form. */
- rtype = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type));
- rtype = copy_type (rtype);
- TYPE_MAIN_VARIANT (rtype) = rtype;
- TREE_TYPE (rtype) = type;
- final_unchecked = true;
- }
-
- expr = convert (rtype, expr);
- if (type != rtype)
- expr = fold_build1 (final_unchecked ? VIEW_CONVERT_EXPR : NOP_EXPR,
- type, expr);
- }
-
- /* If we are converting TO an integral type whose precision is not the
- same as its size, first unchecked convert to a record that contains
- an object of the output type. Then extract the field. */
- else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
- && 0 != compare_tree_int (TYPE_RM_SIZE (type),
- GET_MODE_BITSIZE (TYPE_MODE (type))))
- {
- tree rec_type = make_node (RECORD_TYPE);
- tree field = create_field_decl (get_identifier ("OBJ"), type,
- rec_type, 1, 0, 0, 0);
-
- TYPE_FIELDS (rec_type) = field;
- layout_type (rec_type);
-
- expr = unchecked_convert (rec_type, expr, notrunc_p);
- expr = build_component_ref (expr, NULL_TREE, field, 0);
- }
-
- /* Similarly for integral input type whose precision is not equal to its
- size. */
- else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype)
- && 0 != compare_tree_int (TYPE_RM_SIZE (etype),
- GET_MODE_BITSIZE (TYPE_MODE (etype))))
- {
- tree rec_type = make_node (RECORD_TYPE);
- tree field
- = create_field_decl (get_identifier ("OBJ"), etype, rec_type,
- 1, 0, 0, 0);
-
- TYPE_FIELDS (rec_type) = field;
- layout_type (rec_type);
-
- expr = gnat_build_constructor (rec_type, build_tree_list (field, expr));
- expr = unchecked_convert (type, expr, notrunc_p);
- }
-
- /* We have a special case when we are converting between two
- unconstrained array types. In that case, take the address,
- convert the fat pointer types, and dereference. */
- else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE
- && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
- expr = build_unary_op (INDIRECT_REF, NULL_TREE,
- build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
- build_unary_op (ADDR_EXPR, NULL_TREE,
- expr)));
- else
- {
- expr = maybe_unconstrained_array (expr);
- etype = TREE_TYPE (expr);
- expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
- }
-
- /* If the result is an integral type whose size is not equal to
- the size of the underlying machine type, sign- or zero-extend
- the result. We need not do this in the case where the input is
- an integral type of the same precision and signedness or if the output
- is a biased type or if both the input and output are unsigned. */
- if (!notrunc_p
- && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
- && !(TREE_CODE (type) == INTEGER_TYPE
- && TYPE_BIASED_REPRESENTATION_P (type))
- && 0 != compare_tree_int (TYPE_RM_SIZE (type),
- GET_MODE_BITSIZE (TYPE_MODE (type)))
- && !(INTEGRAL_TYPE_P (etype)
- && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype)
- && operand_equal_p (TYPE_RM_SIZE (type),
- (TYPE_RM_SIZE (etype) != 0
- ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
- 0))
- && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
- {
- tree base_type = gnat_type_for_mode (TYPE_MODE (type),
- TYPE_UNSIGNED (type));
- tree shift_expr
- = convert (base_type,
- size_binop (MINUS_EXPR,
- bitsize_int
- (GET_MODE_BITSIZE (TYPE_MODE (type))),
- TYPE_RM_SIZE (type)));
- expr
- = convert (type,
- build_binary_op (RSHIFT_EXPR, base_type,
- build_binary_op (LSHIFT_EXPR, base_type,
- convert (base_type, expr),
- shift_expr),
- shift_expr));
- }
-
- /* An unchecked conversion should never raise Constraint_Error. The code
- below assumes that GCC's conversion routines overflow the same way that
- the underlying hardware does. This is probably true. In the rare case
- when it is false, we can rely on the fact that such conversions are
- erroneous anyway. */
- if (TREE_CODE (expr) == INTEGER_CST)
- TREE_OVERFLOW (expr) = 0;
-
- /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR,
- show no longer constant. */
- if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
- && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype),
- OEP_ONLY_CONST))
- TREE_CONSTANT (expr) = 0;
-
- return expr;
-}
-\f
-/* Return the appropriate GCC tree code for the specified GNAT type,
- the latter being a record type as predicated by Is_Record_Type. */
-
-enum tree_code
-tree_code_for_record_type (Entity_Id gnat_type)
-{
- Node_Id component_list
- = Component_List (Type_Definition
- (Declaration_Node
- (Implementation_Base_Type (gnat_type))));
- Node_Id component;
-
- /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or
- we have a non-discriminant field outside a variant. In either case,
- it's a RECORD_TYPE. */
-
- if (!Is_Unchecked_Union (gnat_type))
- return RECORD_TYPE;
-
- for (component = First_Non_Pragma (Component_Items (component_list));
- Present (component);
- component = Next_Non_Pragma (component))
- if (Ekind (Defining_Entity (component)) == E_Component)
- return RECORD_TYPE;
-
- return UNION_TYPE;
-}
-
-/* Return true if GNU_TYPE is suitable as the type of a non-aliased
- component of an aggregate type. */
-
-bool
-type_for_nonaliased_component_p (tree gnu_type)
-{
- /* If the type is passed by reference, we may have pointers to the
- component so it cannot be made non-aliased. */
- if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type))
- return false;
-
- /* We used to say that any component of aggregate type is aliased
- because the front-end may take 'Reference of it. The front-end
- has been enhanced in the meantime so as to use a renaming instead
- in most cases, but the back-end can probably take the address of
- such a component too so we go for the conservative stance.
-
- For instance, we might need the address of any array type, even
- if normally passed by copy, to construct a fat pointer if the
- component is used as an actual for an unconstrained formal.
-
- Likewise for record types: even if a specific record subtype is
- passed by copy, the parent type might be passed by ref (e.g. if
- it's of variable size) and we might take the address of a child
- component to pass to a parent formal. We have no way to check
- for such conditions here. */
- if (AGGREGATE_TYPE_P (gnu_type))
- return false;
-
- return true;
-}
-
-/* Perform final processing on global variables. */
-
-void
-gnat_write_global_declarations (void)
-{
- /* Proceed to optimize and emit assembly.
- FIXME: shouldn't be the front end's responsibility to call this. */
- cgraph_optimize ();
-
- /* Emit debug info for all global declarations. */
- emit_debug_global_declarations (VEC_address (tree, global_decls),
- VEC_length (tree, global_decls));
-}
-
-/* ************************************************************************
- * * GCC builtins support *
- * ************************************************************************ */
-
-/* The general scheme is fairly simple:
-
- For each builtin function/type to be declared, gnat_install_builtins calls
- internal facilities which eventually get to gnat_push_decl, which in turn
- tracks the so declared builtin function decls in the 'builtin_decls' global
- datastructure. When an Intrinsic subprogram declaration is processed, we
- search this global datastructure to retrieve the associated BUILT_IN DECL
- node. */
-
-/* Search the chain of currently available builtin declarations for a node
- corresponding to function NAME (an IDENTIFIER_NODE). Return the first node
- found, if any, or NULL_TREE otherwise. */
-tree
-builtin_decl_for (tree name)
-{
- unsigned i;
- tree decl;
-
- for (i = 0; VEC_iterate(tree, builtin_decls, i, decl); i++)
- if (DECL_NAME (decl) == name)
- return decl;
-
- return NULL_TREE;
-}
-
-/* The code below eventually exposes gnat_install_builtins, which declares
- the builtin types and functions we might need, either internally or as
- user accessible facilities.
-
- ??? This is a first implementation shot, still in rough shape. It is
- heavily inspired from the "C" family implementation, with chunks copied
- verbatim from there.
-
- Two obvious TODO candidates are
- o Use a more efficient name/decl mapping scheme
- o Devise a middle-end infrastructure to avoid having to copy
- pieces between front-ends. */
-
-/* ----------------------------------------------------------------------- *
- * BUILTIN ELEMENTARY TYPES *
- * ----------------------------------------------------------------------- */
-
-/* Standard data types to be used in builtin argument declarations. */
-
-enum c_tree_index
-{
- CTI_SIGNED_SIZE_TYPE, /* For format checking only. */
- CTI_STRING_TYPE,
- CTI_CONST_STRING_TYPE,
-
- CTI_MAX
-};
-
-static tree c_global_trees[CTI_MAX];
-
-#define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE]
-#define string_type_node c_global_trees[CTI_STRING_TYPE]
-#define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE]
-
-/* ??? In addition some attribute handlers, we currently don't support a
- (small) number of builtin-types, which in turns inhibits support for a
- number of builtin functions. */
-#define wint_type_node void_type_node
-#define intmax_type_node void_type_node
-#define uintmax_type_node void_type_node
-
-/* Build the void_list_node (void_type_node having been created). */
-
-static tree
-build_void_list_node (void)
-{
- tree t = build_tree_list (NULL_TREE, void_type_node);
- return t;
-}
-
-/* Used to help initialize the builtin-types.def table. When a type of
- the correct size doesn't exist, use error_mark_node instead of NULL.
- The later results in segfaults even when a decl using the type doesn't
- get invoked. */
-
-static tree
-builtin_type_for_size (int size, bool unsignedp)
-{
- tree type = lang_hooks.types.type_for_size (size, unsignedp);
- return type ? type : error_mark_node;
-}
-
-/* Build/push the elementary type decls that builtin functions/types
- will need. */
-
-static void
-install_builtin_elementary_types (void)
-{
- signed_size_type_node = size_type_node;
- pid_type_node = integer_type_node;
- void_list_node = build_void_list_node ();
-
- string_type_node = build_pointer_type (char_type_node);
- const_string_type_node
- = build_pointer_type (build_qualified_type
- (char_type_node, TYPE_QUAL_CONST));
-}
-
-/* ----------------------------------------------------------------------- *
- * BUILTIN FUNCTION TYPES *
- * ----------------------------------------------------------------------- */
-
-/* Now, builtin function types per se. */
-
-enum c_builtin_type
-{
-#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME,
-#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME,
-#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME,
-#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME,
-#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
-#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
-#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME,
-#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6) NAME,
-#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7) NAME,
-#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME,
-#define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME,
-#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME,
-#define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME,
-#define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME,
-#define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG6) \
- NAME,
-#define DEF_POINTER_TYPE(NAME, TYPE) NAME,
-#include "builtin-types.def"
-#undef DEF_PRIMITIVE_TYPE
-#undef DEF_FUNCTION_TYPE_0
-#undef DEF_FUNCTION_TYPE_1
-#undef DEF_FUNCTION_TYPE_2
-#undef DEF_FUNCTION_TYPE_3
-#undef DEF_FUNCTION_TYPE_4
-#undef DEF_FUNCTION_TYPE_5
-#undef DEF_FUNCTION_TYPE_6
-#undef DEF_FUNCTION_TYPE_7
-#undef DEF_FUNCTION_TYPE_VAR_0
-#undef DEF_FUNCTION_TYPE_VAR_1
-#undef DEF_FUNCTION_TYPE_VAR_2
-#undef DEF_FUNCTION_TYPE_VAR_3
-#undef DEF_FUNCTION_TYPE_VAR_4
-#undef DEF_FUNCTION_TYPE_VAR_5
-#undef DEF_POINTER_TYPE
- BT_LAST
-};
-
-typedef enum c_builtin_type builtin_type;
-
-/* A temporary array used in communication with def_fn_type. */
-static GTY(()) tree builtin_types[(int) BT_LAST + 1];
-
-/* A helper function for install_builtin_types. Build function type
- for DEF with return type RET and N arguments. If VAR is true, then the
- function should be variadic after those N arguments.
-
- Takes special care not to ICE if any of the types involved are
- error_mark_node, which indicates that said type is not in fact available
- (see builtin_type_for_size). In which case the function type as a whole
- should be error_mark_node. */
-
-static void
-def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...)
-{
- tree args = NULL, t;
- va_list list;
- int i;
-
- va_start (list, n);
- for (i = 0; i < n; ++i)
- {
- builtin_type a = va_arg (list, builtin_type);
- t = builtin_types[a];
- if (t == error_mark_node)
- goto egress;
- args = tree_cons (NULL_TREE, t, args);
- }
- va_end (list);
-
- args = nreverse (args);
- if (!var)
- args = chainon (args, void_list_node);
-
- t = builtin_types[ret];
- if (t == error_mark_node)
- goto egress;
- t = build_function_type (t, args);
-
- egress:
- builtin_types[def] = t;
-}
-
-/* Build the builtin function types and install them in the builtin_types
- array for later use in builtin function decls. */
-
-static void
-install_builtin_function_types (void)
-{
- tree va_list_ref_type_node;
- tree va_list_arg_type_node;
-
- if (TREE_CODE (va_list_type_node) == ARRAY_TYPE)
- {
- va_list_arg_type_node = va_list_ref_type_node =
- build_pointer_type (TREE_TYPE (va_list_type_node));
- }
- else
- {
- va_list_arg_type_node = va_list_type_node;
- va_list_ref_type_node = build_reference_type (va_list_type_node);
- }
-
-#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \
- builtin_types[ENUM] = VALUE;
-#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \
- def_fn_type (ENUM, RETURN, 0, 0);
-#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \
- def_fn_type (ENUM, RETURN, 0, 1, ARG1);
-#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \
- def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2);
-#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
- def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3);
-#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
- def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4);
-#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
- def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
-#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
- ARG6) \
- def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6);
-#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \
- ARG6, ARG7) \
- def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7);
-#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \
- def_fn_type (ENUM, RETURN, 1, 0);
-#define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \
- def_fn_type (ENUM, RETURN, 1, 1, ARG1);
-#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \
- def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2);
-#define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \
- def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3);
-#define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \
- def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4);
-#define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \
- def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5);
-#define DEF_POINTER_TYPE(ENUM, TYPE) \
- builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]);
-
-#include "builtin-types.def"
-
-#undef DEF_PRIMITIVE_TYPE
-#undef DEF_FUNCTION_TYPE_1
-#undef DEF_FUNCTION_TYPE_2
-#undef DEF_FUNCTION_TYPE_3
-#undef DEF_FUNCTION_TYPE_4
-#undef DEF_FUNCTION_TYPE_5
-#undef DEF_FUNCTION_TYPE_6
-#undef DEF_FUNCTION_TYPE_VAR_0
-#undef DEF_FUNCTION_TYPE_VAR_1
-#undef DEF_FUNCTION_TYPE_VAR_2
-#undef DEF_FUNCTION_TYPE_VAR_3
-#undef DEF_FUNCTION_TYPE_VAR_4
-#undef DEF_FUNCTION_TYPE_VAR_5
-#undef DEF_POINTER_TYPE
- builtin_types[(int) BT_LAST] = NULL_TREE;
-}
-
-/* ----------------------------------------------------------------------- *
- * BUILTIN ATTRIBUTES *
- * ----------------------------------------------------------------------- */
-
-enum built_in_attribute
-{
-#define DEF_ATTR_NULL_TREE(ENUM) ENUM,
-#define DEF_ATTR_INT(ENUM, VALUE) ENUM,
-#define DEF_ATTR_IDENT(ENUM, STRING) ENUM,
-#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM,
-#include "builtin-attrs.def"
-#undef DEF_ATTR_NULL_TREE
-#undef DEF_ATTR_INT
-#undef DEF_ATTR_IDENT
-#undef DEF_ATTR_TREE_LIST
- ATTR_LAST
-};
-
-static GTY(()) tree built_in_attributes[(int) ATTR_LAST];
-
-static void
-install_builtin_attributes (void)
-{
- /* Fill in the built_in_attributes array. */
-#define DEF_ATTR_NULL_TREE(ENUM) \
- built_in_attributes[(int) ENUM] = NULL_TREE;
-#define DEF_ATTR_INT(ENUM, VALUE) \
- built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE);
-#define DEF_ATTR_IDENT(ENUM, STRING) \
- built_in_attributes[(int) ENUM] = get_identifier (STRING);
-#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \
- built_in_attributes[(int) ENUM] \
- = tree_cons (built_in_attributes[(int) PURPOSE], \
- built_in_attributes[(int) VALUE], \
- built_in_attributes[(int) CHAIN]);
-#include "builtin-attrs.def"
-#undef DEF_ATTR_NULL_TREE
-#undef DEF_ATTR_INT
-#undef DEF_ATTR_IDENT
-#undef DEF_ATTR_TREE_LIST
-}
-
-/* Handle a "const" attribute; arguments as in
- struct attribute_spec.handler. */
-
-static tree
-handle_const_attribute (tree *node, tree ARG_UNUSED (name),
- tree ARG_UNUSED (args), int ARG_UNUSED (flags),
- bool *no_add_attrs)
-{
- if (TREE_CODE (*node) == FUNCTION_DECL)
- TREE_READONLY (*node) = 1;
- else
- *no_add_attrs = true;
-
- return NULL_TREE;
-}
-
-/* Handle a "nothrow" attribute; arguments as in
- struct attribute_spec.handler. */
-
-static tree
-handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name),
- tree ARG_UNUSED (args), int ARG_UNUSED (flags),
- bool *no_add_attrs)
-{
- if (TREE_CODE (*node) == FUNCTION_DECL)
- TREE_NOTHROW (*node) = 1;
- else
- *no_add_attrs = true;
-
- return NULL_TREE;
-}
-
-/* Handle a "pure" attribute; arguments as in
- struct attribute_spec.handler. */
-
-static tree
-handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args),
- int ARG_UNUSED (flags), bool *no_add_attrs)
-{
- if (TREE_CODE (*node) == FUNCTION_DECL)
- DECL_PURE_P (*node) = 1;
- /* ??? TODO: Support types. */
- else
- {
- warning (OPT_Wattributes, "%qE attribute ignored", name);
- *no_add_attrs = true;
- }
-
- return NULL_TREE;
-}
-
-/* Handle a "no vops" attribute; arguments as in
- struct attribute_spec.handler. */
-
-static tree
-handle_novops_attribute (tree *node, tree ARG_UNUSED (name),
- tree ARG_UNUSED (args), int ARG_UNUSED (flags),
- bool *ARG_UNUSED (no_add_attrs))
-{
- gcc_assert (TREE_CODE (*node) == FUNCTION_DECL);
- DECL_IS_NOVOPS (*node) = 1;
- return NULL_TREE;
-}
-
-/* Helper for nonnull attribute handling; fetch the operand number
- from the attribute argument list. */
-
-static bool
-get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp)
-{
- /* Verify the arg number is a constant. */
- if (TREE_CODE (arg_num_expr) != INTEGER_CST
- || TREE_INT_CST_HIGH (arg_num_expr) != 0)
- return false;
-
- *valp = TREE_INT_CST_LOW (arg_num_expr);
- return true;
-}
-
-/* Handle the "nonnull" attribute. */
-static tree
-handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
- tree args, int ARG_UNUSED (flags),
- bool *no_add_attrs)
-{
- tree type = *node;
- unsigned HOST_WIDE_INT attr_arg_num;
-
- /* If no arguments are specified, all pointer arguments should be
- non-null. Verify a full prototype is given so that the arguments
- will have the correct types when we actually check them later. */
- if (!args)
- {
- if (!TYPE_ARG_TYPES (type))
- {
- error ("nonnull attribute without arguments on a non-prototype");
- *no_add_attrs = true;
- }
- return NULL_TREE;
- }
-
- /* Argument list specified. Verify that each argument number references
- a pointer argument. */
- for (attr_arg_num = 1; args; args = TREE_CHAIN (args))
- {
- tree argument;
- unsigned HOST_WIDE_INT arg_num = 0, ck_num;
-
- if (!get_nonnull_operand (TREE_VALUE (args), &arg_num))
- {
- error ("nonnull argument has invalid operand number (argument %lu)",
- (unsigned long) attr_arg_num);
- *no_add_attrs = true;
- return NULL_TREE;
- }
-
- argument = TYPE_ARG_TYPES (type);
- if (argument)
- {
- for (ck_num = 1; ; ck_num++)
- {
- if (!argument || ck_num == arg_num)
- break;
- argument = TREE_CHAIN (argument);
- }
-
- if (!argument
- || TREE_CODE (TREE_VALUE (argument)) == VOID_TYPE)
- {
- error ("nonnull argument with out-of-range operand number (argument %lu, operand %lu)",
- (unsigned long) attr_arg_num, (unsigned long) arg_num);
- *no_add_attrs = true;
- return NULL_TREE;
- }
-
- if (TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE)
- {
- error ("nonnull argument references non-pointer operand (argument %lu, operand %lu)",
- (unsigned long) attr_arg_num, (unsigned long) arg_num);
- *no_add_attrs = true;
- return NULL_TREE;
- }
- }
- }
-
- return NULL_TREE;
-}
-
-/* Handle a "sentinel" attribute. */
-
-static tree
-handle_sentinel_attribute (tree *node, tree name, tree args,
- int ARG_UNUSED (flags), bool *no_add_attrs)
-{
- tree params = TYPE_ARG_TYPES (*node);
-
- if (!params)
- {
- warning (OPT_Wattributes,
- "%qE attribute requires prototypes with named arguments", name);
- *no_add_attrs = true;
- }
- else
- {
- while (TREE_CHAIN (params))
- params = TREE_CHAIN (params);
-
- if (VOID_TYPE_P (TREE_VALUE (params)))
- {
- warning (OPT_Wattributes,
- "%qE attribute only applies to variadic functions", name);
- *no_add_attrs = true;
- }
- }
-
- if (args)
- {
- tree position = TREE_VALUE (args);
-
- if (TREE_CODE (position) != INTEGER_CST)
- {
- warning (0, "requested position is not an integer constant");
- *no_add_attrs = true;
- }
- else
- {
- if (tree_int_cst_lt (position, integer_zero_node))
- {
- warning (0, "requested position is less than zero");
- *no_add_attrs = true;
- }
- }
- }
-
- return NULL_TREE;
-}
-
-/* Handle a "noreturn" attribute; arguments as in
- struct attribute_spec.handler. */
-
-static tree
-handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args),
- int ARG_UNUSED (flags), bool *no_add_attrs)
-{
- tree type = TREE_TYPE (*node);
-
- /* See FIXME comment in c_common_attribute_table. */
- if (TREE_CODE (*node) == FUNCTION_DECL)
- TREE_THIS_VOLATILE (*node) = 1;
- else if (TREE_CODE (type) == POINTER_TYPE
- && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
- TREE_TYPE (*node)
- = build_pointer_type
- (build_type_variant (TREE_TYPE (type),
- TYPE_READONLY (TREE_TYPE (type)), 1));
- else
- {
- warning (OPT_Wattributes, "%qE attribute ignored", name);
- *no_add_attrs = true;
- }
-
- return NULL_TREE;
-}
-
-/* Handle a "malloc" attribute; arguments as in
- struct attribute_spec.handler. */
-
-static tree
-handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args),
- int ARG_UNUSED (flags), bool *no_add_attrs)
-{
- if (TREE_CODE (*node) == FUNCTION_DECL
- && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node))))
- DECL_IS_MALLOC (*node) = 1;
- else
- {
- warning (OPT_Wattributes, "%qE attribute ignored", name);
- *no_add_attrs = true;
- }
-
- return NULL_TREE;
-}
-
-/* Fake handler for attributes we don't properly support. */
-
-tree
-fake_attribute_handler (tree * ARG_UNUSED (node),
- tree ARG_UNUSED (name),
- tree ARG_UNUSED (args),
- int ARG_UNUSED (flags),
- bool * ARG_UNUSED (no_add_attrs))
-{
- return NULL_TREE;
-}
-
-/* Handle a "type_generic" attribute. */
-
-static tree
-handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name),
- tree ARG_UNUSED (args), int ARG_UNUSED (flags),
- bool * ARG_UNUSED (no_add_attrs))
-{
- tree params;
-
- /* Ensure we have a function type. */
- gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE);
-
- params = TYPE_ARG_TYPES (*node);
- while (params && ! VOID_TYPE_P (TREE_VALUE (params)))
- params = TREE_CHAIN (params);
-
- /* Ensure we have a variadic function. */
- gcc_assert (!params);
-
- return NULL_TREE;
-}
-
-/* ----------------------------------------------------------------------- *
- * BUILTIN FUNCTIONS *
- * ----------------------------------------------------------------------- */
-
-/* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two
- names. Does not declare a non-__builtin_ function if flag_no_builtin, or
- if nonansi_p and flag_no_nonansi_builtin. */
-
-static void
-def_builtin_1 (enum built_in_function fncode,
- const char *name,
- enum built_in_class fnclass,
- tree fntype, tree libtype,
- bool both_p, bool fallback_p,
- bool nonansi_p ATTRIBUTE_UNUSED,
- tree fnattrs, bool implicit_p)
-{
- tree decl;
- const char *libname;
-
- /* Preserve an already installed decl. It most likely was setup in advance
- (e.g. as part of the internal builtins) for specific reasons. */
- if (built_in_decls[(int) fncode] != NULL_TREE)
- return;
-
- gcc_assert ((!both_p && !fallback_p)
- || !strncmp (name, "__builtin_",
- strlen ("__builtin_")));
-
- libname = name + strlen ("__builtin_");
- decl = add_builtin_function (name, fntype, fncode, fnclass,
- (fallback_p ? libname : NULL),
- fnattrs);
- if (both_p)
- /* ??? This is normally further controlled by command-line options
- like -fno-builtin, but we don't have them for Ada. */
- add_builtin_function (libname, libtype, fncode, fnclass,
- NULL, fnattrs);
-
- built_in_decls[(int) fncode] = decl;
- if (implicit_p)
- implicit_built_in_decls[(int) fncode] = decl;
-}
-
-static int flag_isoc94 = 0;
-static int flag_isoc99 = 0;
-
-/* Install what the common builtins.def offers. */
-
-static void
-install_builtin_functions (void)
-{
-#define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \
- NONANSI_P, ATTRS, IMPLICIT, COND) \
- if (NAME && COND) \
- def_builtin_1 (ENUM, NAME, CLASS, \
- builtin_types[(int) TYPE], \
- builtin_types[(int) LIBTYPE], \
- BOTH_P, FALLBACK_P, NONANSI_P, \
- built_in_attributes[(int) ATTRS], IMPLICIT);
-#include "builtins.def"
-#undef DEF_BUILTIN
-}
-
-/* ----------------------------------------------------------------------- *
- * BUILTIN FUNCTIONS *
- * ----------------------------------------------------------------------- */
-
-/* Install the builtin functions we might need. */
-
-void
-gnat_install_builtins (void)
-{
- install_builtin_elementary_types ();
- install_builtin_function_types ();
- install_builtin_attributes ();
-
- /* Install builtins used by generic middle-end pieces first. Some of these
- know about internal specificities and control attributes accordingly, for
- instance __builtin_alloca vs no-throw and -fstack-check. We will ignore
- the generic definition from builtins.def. */
- build_common_builtin_nodes ();
-
- /* Now, install the target specific builtins, such as the AltiVec family on
- ppc, and the common set as exposed by builtins.def. */
- targetm.init_builtins ();
- install_builtin_functions ();
-}
-
-#include "gt-ada-utils.h"
-#include "gtype-ada.h"
+++ /dev/null
-/****************************************************************************
- * *
- * 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);
-\f
-/* 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));
- }
-}
-\f
-/* 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;
-}
-\f
-/* 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;
-}
-\f
-/* 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;
-}
-\f
-/* 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;
- }
-}
-\f
-/* 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;
- }
-}
-\f
-/* 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;
-}
-\f
-/* 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);
-}
-\f
-/* 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;
-}
-\f
-/* 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;
-}
-\f
-/* 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);
-}
-\f
-/* 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;
-}
-\f
-/* 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));
-}
-\f
-/* 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;
-}
-\f
-/* 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);
-}
-\f
-/* 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));
-}
-\f
-/* 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);
- }
-}
-\f
-/* 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);
-}
-\f
-/* 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;
- }
-}
projects / gcc.git / commitdiff