* *
* C Implementation File *
* *
- * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2010, 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- *
+ * 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 distributed with GNAT; see file COPYING. If not, write *
- * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
- * Boston, MA 02110-1301, USA. *
+ * Public License distributed with GNAT; see 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 "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 "adadecode.h"
#include "types.h"
#include "atree.h"
#include "elists.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
#endif
/* For efficient float-to-int rounding, it is necessary to know whether
- floating-point arithmetic on may use wider intermediate results.
- When FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
- floating-point arithmetic does not widen if double precision is emulated. */
-
+ floating-point arithmetic may use wider intermediate results. When
+ FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume
+ that arithmetic does not widen if double precision is emulated. */
#ifndef FP_ARITH_MAY_WIDEN
#if defined(HAVE_extendsfdf2)
#define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2
Char_Code *String_Chars_Ptr;
struct List_Header *List_Headers_Ptr;
-/* Current filename without path. */
+/* Current filename without path. */
const char *ref_filename;
-/* If true, then gigi is being called on an analyzed but unexpanded
+/* True when 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. */
+ 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 (())
-{
+struct GTY (()) parm_attr_d {
int id; /* GTY doesn't like Entity_Id. */
int dim;
tree first;
tree length;
};
-typedef struct parm_attr *parm_attr;
+typedef struct parm_attr_d *parm_attr;
DEF_VEC_P(parm_attr);
DEF_VEC_ALLOC_P(parm_attr,gc);
-struct language_function GTY(())
-{
+struct GTY(()) language_function {
VEC(parm_attr,gc) *parm_attr_cache;
};
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 GTY((chain_next ("%h.previous"))) stmt_group {
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 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. */
};
??? 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. */
+struct GTY((chain_next ("%h.next"))) elab_info {
+ struct elab_info *next; /* Pointer to next in chain. */
tree elab_proc; /* Elaboration procedure. */
int gnat_node; /* The N_Compilation_Unit. */
};
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 build_unary_op_trapv (enum tree_code, tree, tree);
-static tree build_binary_op_trapv (enum tree_code, tree, tree, tree);
-static tree convert_with_check (Entity_Id, tree, bool, bool, bool);
+static tree emit_range_check (tree, Node_Id, Node_Id);
+static tree emit_index_check (tree, tree, tree, tree, Node_Id);
+static tree emit_check (tree, tree, int, Node_Id);
+static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
+static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
+static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id);
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 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);
+static int lvalue_required_p (Node_Id, tree, bool, bool);
/* Hooks for debug info back-ends, only supported and used in a restricted set
of configurations. */
Entity_Id standard_exception_type, Int gigi_operating_mode)
{
Entity_Id gnat_literal;
- tree gnu_standard_long_long_float, gnu_standard_exception_type, t;
+ tree long_long_float_type, exception_type, t;
+ tree int64_type = gnat_type_for_size (64, 0);
struct elab_info *info;
int i;
type_annotate_only = (gigi_operating_mode == 1);
+ gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
+
+ /* Declare the name of the compilation unit as the first global
+ name in order to make the middle-end fully deterministic. */
+ t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
+ first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
+
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. */
+ host style syntax not understood by gdb. */
const char *filename
= IDENTIFIER_POINTER
(get_identifier
/* 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
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 ("boolean"), boolean_type_node,
- 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);
+ /* Retrieve alignment settings. */
+ double_float_alignment = get_target_double_float_alignment ();
+ double_scalar_alignment = get_target_double_scalar_alignment ();
+
+ /* Record the builtin types. Define `integer' and `unsigned char' first so
+ that dbx will output them first. */
+ record_builtin_type ("integer", integer_type_node);
+ record_builtin_type ("unsigned char", char_type_node);
+ record_builtin_type ("long integer", long_integer_type_node);
+ unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
+ record_builtin_type ("unsigned int", unsigned_type_node);
+ record_builtin_type (SIZE_TYPE, sizetype);
+ record_builtin_type ("boolean", boolean_type_node);
+ record_builtin_type ("void", void_type_node);
+
+ /* Save the type we made for integer as the type for Standard.Integer. */
+ save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
+ false);
/* Save the type we made for boolean as the type for Standard.Boolean. */
save_gnu_tree (Base_Type (standard_boolean), TYPE_NAME (boolean_type_node),
DECL_IGNORED_P (t) = 1;
save_gnu_tree (gnat_literal, t, false);
- /* 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);
+ void_ftype = build_function_type (void_type_node, NULL_TREE);
+ ptr_void_ftype = build_pointer_type (void_ftype);
+
+ /* Now declare runtime functions. */
+ t = 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, t)),
+ NULL_TREE, false, true, true, NULL, Empty);
+ DECL_IS_MALLOC (malloc_decl) = 1;
+
+ /* malloc32 is a function declaration tree for a function to allocate
+ 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */
+ malloc32_decl
+ = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE,
+ build_function_type (ptr_void_type_node,
+ tree_cons (NULL_TREE,
+ sizetype, t)),
+ 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,
+ t)),
+ NULL_TREE, false, true, true, NULL, Empty);
+
+ /* This is used for 64-bit multiplication with overflow checking. */
+ mulv64_decl
+ = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
+ build_function_type_list (int64_type, int64_type,
+ int64_type, NULL_TREE),
+ 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 (size_int (5)));
+ record_builtin_type ("JMPBUF_T", jmpbuf_type);
+ 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, t)),
+ NULL_TREE, false, true, true, NULL, Empty);
+
+ /* 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, t)),
+ 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, t)),
+ 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;
+
+ /* 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,
+ t)),
+ 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,
+ t)),
+ 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 ())
+ {
+ tree 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,
+ t))),
+ NULL_TREE, false, true, true, NULL, Empty);
+
+ for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
+ gnat_raise_decls[i] = decl;
+ }
+ else
+ /* Otherwise, make one decl for each exception reason. */
+ for (i = 0; i < (int) 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,
+ t))),
+ NULL_TREE, false, true, true, NULL, Empty);
+ }
+
+ for (i = 0; i < (int) 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);
+ }
+
+ /* 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. */
+ exception_type
+ = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
+ except_type_node = TREE_TYPE (exception_type);
+
+ /* Make other functions used for exception processing. */
+ 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;
+
+ 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),
+ t)),
+ 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);
+
+ /* Build the special descriptor type and its null node if needed. */
+ if (TARGET_VTABLE_USES_DESCRIPTORS)
+ {
+ tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
+ 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_node, null_list);
+ }
+
+ finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
+ record_builtin_type ("descriptor", fdesc_type_node);
+ null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
+ }
+
+ long_long_float_type
+ = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
+
+ 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);
+ record_builtin_type ("longest float type", longest_float_type_node);
+ }
+ else
+ longest_float_type_node = TREE_TYPE (long_long_float_type);
+
+ /* 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);
+
+ 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 ();
gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
gnu_constraint_error_label_stack
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)))
if (Exception_Mechanism == Back_End_Exceptions)
gnat_init_gcc_eh ();
- gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
-
- /* Declare the name of the compilation unit as the first global
- name in order to make the middle-end fully deterministic. */
- t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
- first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
-
/* Now translate the compilation unit proper. */
start_stmt_group ();
Compilation_Unit_to_gnu (gnat_root);
/* Finally 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);
+ tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts;
/* Unshare SAVE_EXPRs between subprograms. These are not unshared by
the gimplifier for obvious reasons, but it turns out that we need to
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)))
+ /* We should have a BIND_EXPR but it may not have any statements in it.
+ If it doesn't have any, we have nothing to do except for setting the
+ flag on the GNAT node. Otherwise, process the function as others. */
+ gnu_stmts = gnu_body;
+ if (TREE_CODE (gnu_stmts) == BIND_EXPR)
+ gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
+ if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
Set_Has_No_Elaboration_Code (info->gnat_node, 1);
+ else
+ {
+ begin_subprog_body (info->elab_proc);
+ end_subprog_body (gnu_body);
+ }
}
/* 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.
+/* 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.
+ CONSTANT indicates whether the underlying object represented by GNAT_NODE
+ is constant in the Ada sense, ALIASED whether it is aliased (but the latter
+ doesn't affect the outcome if CONSTANT is not true).
- 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. */
+ 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)
+lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
+ bool aliased)
{
Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
return id == Attr_Address
|| id == Attr_Access
|| id == Attr_Unchecked_Access
- || id == Attr_Unrestricted_Access;
+ || id == Attr_Unrestricted_Access
+ || id == Attr_Bit_Position
+ || id == Attr_Position
+ || id == Attr_First_Bit
+ || id == Attr_Last_Bit
+ || id == Attr_Bit;
}
case N_Parameter_Association:
return 0;
aliased |= Has_Aliased_Components (Etype (gnat_node));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Selected_Component:
aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent)));
- return lvalue_required_p (gnat_parent, gnu_type, aliased);
+ return lvalue_required_p (gnat_parent, gnu_type, constant, aliased);
case N_Object_Renaming_Declaration:
/* We need to make a real renaming only if the constant object is
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
+ return (!constant
+ || aliased
/* This should match the constant case of the renaming code. */
- || Is_Composite_Type (Etype (Name (gnat_parent)))
+ || Is_Composite_Type
+ (Underlying_Type (Etype (Name (gnat_parent))))
|| Nkind (Name (gnat_parent)) == N_Identifier);
+ case N_Object_Declaration:
+ /* We cannot use a constructor if this is an atomic object because
+ the actual assignment might end up being done component-wise. */
+ return Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Defining_Entity (gnat_parent));
+
+ case N_Assignment_Statement:
+ /* We cannot use a constructor if the LHS is an atomic object because
+ the actual assignment might end up being done component-wise. */
+ return (Name (gnat_parent) == gnat_node
+ || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
+ && Is_Atomic (Entity (Name (gnat_parent)))));
+
+ case N_Unchecked_Type_Conversion:
+ /* Returning 0 is very likely correct but we get better code if we
+ go through the conversion. */
+ return lvalue_required_p (gnat_parent,
+ get_unpadded_type (Etype (gnat_parent)),
+ constant, aliased);
+
default:
return 0;
}
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. */
+ volatile-ness short-circuit here since Volatile constants must bei
+ 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,
+ require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
Is_Aliased (gnat_temp));
use_constant_initializer = !require_lvalue;
}
|| (TREE_CODE (gnu_result) == PARM_DECL
&& DECL_BY_COMPONENT_PTR_P (gnu_result))))
{
- bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
+ const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
tree renamed_obj;
if (TREE_CODE (gnu_result) == PARM_DECL
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)
+ && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result))
+ && (!DECL_RENAMING_GLOBAL_P (gnu_result)
|| global_bindings_p ()))
gnu_result = renamed_obj;
else
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
- TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
+ if (read_only)
+ TREE_READONLY (gnu_result) = 1;
}
/* The GNAT tree has the type of a function as the type of its result. Also
|| 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))
+ if (TYPE_IS_PADDING_P (gnu_result_type))
gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
}
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,
+ require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true,
Is_Aliased (gnat_temp));
if (!object || !require_lvalue)
asm_constraint = build_string (strlen (comment), comment);
free (comment);
#endif
- gnu_expr = build4 (ASM_EXPR, void_type_node,
+ gnu_expr = build5 (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);
+ 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);
return gnu_result;
}
-/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
+\f
+/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
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);
+ tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
+ bool prefix_unused = false;
/* 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));
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ *gnu_result_type_p = gnu_result_type;
+ return build1 (NULL_EXPR, gnu_result_type, 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. */
+ /* These are just conversions since representation clauses for
+ enumeration types 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);
+ checkp, checkp, true, gnat_node);
}
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. */
+ /* These just add or subtract the constant 1 since representation
+ clauses for enumeration types are handled in the front-end. */
gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
attribute == Attr_Pred
? TYPE_MIN_VALUE (gnu_result_type)
: TYPE_MAX_VALUE (gnu_result_type)),
- gnu_expr, CE_Range_Check_Failed);
+ gnu_expr, CE_Range_Check_Failed, gnat_node);
}
gnu_result
- = build_binary_op (attribute == Attr_Pred
- ? MINUS_EXPR : PLUS_EXPR,
+ = 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. */
+ /* Conversions don't change addresses 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));
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)))
+ /* If this is an unconstrained array, we know the object has been
+ allocated with the template in front of the object. So compute
+ the template address. */
+ if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr
= convert (build_pointer_type
(TYPE_OBJECT_RECORD_TYPE
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)
+ /* Remove NOPs and conversions between original and packable version
+ from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR
+ to see if a COMPONENT_REF was involved. */
+ while (TREE_CODE (gnu_expr) == NOP_EXPR
+ || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR
+ && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
+ == RECORD_TYPE
+ && TYPE_NAME (TREE_TYPE (gnu_expr))
+ == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
gnu_expr = TREE_OPERAND (gnu_expr, 0);
gnu_prefix = remove_conversions (gnu_prefix, true);
}
/* 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. */
+ Otherwise, if the prefix is an object, or if we're looking for
+ 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
+ GCC size of the type. Otherwise, it 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
+ /* If the prefix is an object of 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 field. Using the MAX of those two produces
+ the right result in all cases. Don't use the size of the field
+ if it's self-referential, since that's never what's wanted. */
+ if (TREE_CODE (gnu_prefix) != TYPE_DECL
&& 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)))))
+ 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"));
- }
+ Node_Id gnat_actual_subtype
+ = Actual_Designated_Subtype (gnat_deref);
+ tree gnu_ptr_type
+ = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
+
+ if (TYPE_IS_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);
}
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
+ /* 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))
{
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));
+ gnu_result = 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);
+ {
+ unsigned int align;
- gnu_type = TREE_TYPE (gnu_prefix);
- gnu_result_type = get_unpadded_type (Etype (gnat_node));
- prefix_unused = true;
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF
+ && 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);
+ if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
+ align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
+ else
+ {
+ Node_Id gnat_prefix = Prefix (gnat_node);
+ Entity_Id gnat_type = Etype (gnat_prefix);
+ unsigned int double_align;
+ bool is_capped_double, align_clause;
+
+ /* If the default alignment of "double" or larger scalar types is
+ specifically capped and there is an alignment clause neither
+ on the type nor on the prefix itself, return the cap. */
+ if ((double_align = double_float_alignment) > 0)
+ is_capped_double
+ = is_double_float_or_array (gnat_type, &align_clause);
+ else if ((double_align = double_scalar_alignment) > 0)
+ is_capped_double
+ = is_double_scalar_or_array (gnat_type, &align_clause);
+ else
+ is_capped_double = align_clause = false;
+
+ if (is_capped_double
+ && Nkind (gnat_prefix) == N_Identifier
+ && Present (Alignment_Clause (Entity (gnat_prefix))))
+ align_clause = true;
+
+ if (is_capped_double && !align_clause)
+ align = double_align;
+ else
+ align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
+ }
+
+ gnu_result = size_int (align);
+ }
break;
case Attr_First:
int Dimension = (Present (Expressions (gnat_node))
? UI_To_Int (Intval (First (Expressions (gnat_node))))
: 1), i;
- struct parm_attr *pa = NULL;
+ struct parm_attr_d *pa = NULL;
Entity_Id gnat_param = Empty;
/* Make sure any implicit dereference gets done. */
if (!pa)
{
- pa = GGC_CNEW (struct parm_attr);
+ pa = GGC_CNEW (struct parm_attr_d);
pa->id = gnat_param;
pa->dim = Dimension;
VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
/* 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
+ (hb >= lb) ? hb - lb + 1 : 0, 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. Note that the
- comparison must be done in the original index base type,
- otherwise the conversion of either bound to gnu_compute_type
- may overflow. */
-
- 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));
-
+ signed arithmetic while the latter doesn't. Note that
+ the comparison must be done in the original index type,
+ to avoid any overflow during the conversion. */
+ tree comp_type = get_base_type (gnu_result_type);
+ tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
+ tree lb = TYPE_MIN_VALUE (index_type);
+ tree hb = TYPE_MAX_VALUE (index_type);
+ gnu_result
+ = build_binary_op (PLUS_EXPR, comp_type,
+ build_binary_op (MINUS_EXPR,
+ comp_type,
+ convert (comp_type, hb),
+ convert (comp_type, lb)),
+ convert (comp_type, integer_one_node));
gnu_result
- = build3
- (COND_EXPR, gnu_compute_type,
- build_binary_op (LT_EXPR, get_base_type (index_type),
- TYPE_MAX_VALUE (index_type),
- TYPE_MIN_VALUE (index_type)),
- 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)));
+ = build_cond_expr (comp_type,
+ build_binary_op (GE_EXPR,
+ integer_type_node,
+ hb, lb),
+ gnu_result,
+ convert (comp_type, integer_zero_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);
+ 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
else
pa->length = gnu_result;
}
+
+ /* Set the source location onto the predicate of the condition in the
+ 'Length case but do not do it if the expression is cached to avoid
+ messing up the debug info. */
+ else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
+ && TREE_CODE (gnu_result) == COND_EXPR
+ && EXPR_P (TREE_OPERAND (gnu_result, 0)))
+ set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
+ gnat_node);
+
break;
}
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. */
+ 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)
break;
}
- /* If this has a PLACEHOLDER_EXPR, qualify it by the object
- we are handling. */
+ /* 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_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)))))
+ && 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);
break;
case Attr_Null_Parameter:
- /* This is just a zero cast to the pointer type for
- our prefix and dereferenced. */
+ /* 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,
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. */
+ 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;
/* 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). */
+ 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),
/* 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 ());
+ push_stack (&gnu_switch_label_stack, NULL_TREE,
+ create_artificial_label (input_location));
start_stmt_group ();
for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
Present (gnat_when);
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 ()),
+ add_stmt_with_node (build3
+ (CASE_LABEL_EXPR, void_type_node,
+ gnu_low, gnu_high,
+ create_artificial_label (input_location)),
gnat_choice);
choices_added++;
}
}
}
- /* Now emit a definition of the label all the cases branched to. */
+ /* 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,
TREE_TYPE (gnu_loop_stmt) = void_type_node;
TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
- LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
+ LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (input_location);
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)));
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_first, gnu_last, gnu_limit;
+ enum tree_code update_code, end_code;
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 must disable modulo reduction for the loop variable, if any,
+ in order for the loop comparison to be effective. */
+ if (Reverse_Present (gnat_loop_spec))
+ {
+ gnu_first = gnu_high;
+ gnu_last = gnu_low;
+ update_code = MINUS_NOMOD_EXPR;
+ end_code = GE_EXPR;
+ gnu_limit = TYPE_MIN_VALUE (gnu_base_type);
+ }
+ else
+ {
+ gnu_first = gnu_low;
+ gnu_last = gnu_high;
+ update_code = PLUS_NOMOD_EXPR;
+ end_code = LE_EXPR;
+ gnu_limit = 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
gnu_loop_var, gnu_last);
LOOP_STMT_UPDATE (gnu_loop_stmt)
- = build_binary_op (reversep ? PREDECREMENT_EXPR
- : PREINCREMENT_EXPR,
- TREE_TYPE (gnu_loop_var),
+ = build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_loop_var,
- convert (TREE_TYPE (gnu_loop_var),
- integer_one_node));
+ build_binary_op (update_code,
+ 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);
}
ptr_void_type_node,
NULL_TREE),
NULL_TREE, 0, 1, 1, 0, Empty);
+
+ /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */
+ DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE;
}
/* Do nothing if the establish builtin is not available, which might happen
? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
/* The FUNCTION_DECL node corresponding to the subprogram spec. */
tree gnu_subprog_decl;
+ /* Its RESULT_DECL node. */
+ tree gnu_result_decl;
/* The FUNCTION_TYPE node corresponding to the subprogram spec. */
tree gnu_subprog_type;
tree gnu_cico_list;
= gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
Acts_As_Spec (gnat_node)
&& !present_gnu_tree (gnat_subprog_id));
-
+ gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
+ /* If the function returns by invisible reference, make it explicit in the
+ function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
+ if (TREE_ADDRESSABLE (gnu_subprog_type))
+ {
+ TREE_TYPE (gnu_result_decl)
+ = build_reference_type (TREE_TYPE (gnu_result_decl));
+ relayout_decl (gnu_result_decl);
+ }
+
/* Propagate the debug mode. */
if (!Needs_Debug_Info (gnat_subprog_id))
DECL_IGNORED_P (gnu_subprog_decl) = 1;
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);
+ gnu_cico_list ? create_artificial_label (input_location)
+ : NULL_TREE);
/* Get a tree corresponding to the code for the subprogram. */
start_stmt_group ();
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)))
+ && (Has_Foreign_Convention (gnat_subprog_id)
+ || Is_Exported (gnat_subprog_id)))
establish_gnat_vms_condition_handler ();
process_decls (Declarations (gnat_node), Empty, Empty, true, true);
cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
if (cache)
{
- struct parm_attr *pa;
+ struct parm_attr_d *pa;
int i;
start_stmt_group ();
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 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 though.
+
+ 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.
+
+ We need to make a block that contains the definition of that label and
+ the copying of the return value. It first contains the function, then
+ the label and copy statement. */
if (TREE_VALUE (gnu_return_label_stack))
{
tree gnu_retval;
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),
- End_Label (Handled_Statement_Sequence (gnat_node)));
+ add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval),
+ End_Label (Handled_Statement_Sequence (gnat_node)));
gnat_poplevel ();
gnu_result = end_stmt_group ();
}
: Sloc (gnat_node)),
&DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
- end_subprog_body (gnu_result, false);
+ end_subprog_body (gnu_result);
- /* Disconnect the trees for parameters that we made variables for from the
- GNAT entities since these are unusable after we end the function. */
+ /* Finally annotate the parameters and disconnect the trees for parameters
+ that we have turned into variables since they are now unusable. */
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);
+ {
+ tree gnu_param = get_gnu_tree (gnat_param);
+ annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
+ DECL_BY_REF_P (gnu_param));
+ if (TREE_CODE (gnu_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);
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));
+ tree gnu_subprog = 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);
+ tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
+ tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog);
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)));
- }
+ tree gnu_call;
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))
+ /* If we are calling a stubbed function, raise Program_Error, but Elaborate
+ all our args first. */
+ if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog))
{
+ tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
+ gnat_node, N_Raise_Program_Error);
+
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)
+ if (Nkind (gnat_node) == N_Function_Call && !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_result_type_p = TREE_TYPE (gnu_subprog_type);
+ return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
}
- 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);
-
+ return call_expr;
}
/* 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
+ type the access type is pointing to. Otherwise, get the formals from the
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;
+ gnat_formal = Empty;
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. */
+ /* 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 an expression and the TREE_PURPOSE field is null. But skip Out
+ parameters not passed by reference and that need not 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 = 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
&& 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);
+ 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
+ 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. */
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
&& !addressable_p (gnu_name, gnu_name_type))
{
- tree gnu_copy = gnu_name, gnu_temp;
+ tree gnu_copy = gnu_name;
/* 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. */
+ /* 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 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
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))))))
+ /* If the actual type of the object is already the nominal type,
+ we have nothing to do, except if the size is self-referential
+ in which case we'll remove the unpadding below. */
+ if (TREE_TYPE (gnu_name) == gnu_name_type
+ && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
+ ;
+
+ /* Otherwise remove unpadding from the object and reset the copy. */
+ else if (TREE_CODE (gnu_name) == COMPONENT_REF
+ && 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
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_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. */
+ effects and handle the creation of a temporary. 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. */
+ /* Set up to move the copy back to the original if needed. */
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_node);
- append_to_statement_list (gnu_temp, &gnu_after_list);
+ tree stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_copy,
+ gnu_name);
+ set_expr_location_from_node (stmt, gnat_node);
+ append_to_statement_list (stmt, &gnu_after_list);
}
}
/* 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);
if (Ekind (gnat_formal) != E_Out_Parameter
&& Do_Range_Check (gnat_actual))
- gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
+ gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal),
+ gnat_actual);
}
else
{
if (Ekind (gnat_formal) != E_Out_Parameter
&& Do_Range_Check (gnat_actual))
- gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
+ gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal),
+ gnat_actual);
/* 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. */
+ of an awkward interaction with the check. */
if (TREE_CODE (gnu_actual) != SAVE_EXPR)
gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
gnu_actual);
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. */
+ Out parameter not passed by reference and that need not be copied in.
+ Otherwise, first see if the PARM_DECL is passed by reference. */
if (gnu_formal
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_REF_P (gnu_formal))
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))
+ if (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);
}
/* 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. */
+ 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);
}
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))
+ if (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);
&& TREE_CODE (gnu_formal) == PARM_DECL
&& DECL_BY_DESCRIPTOR_P (gnu_formal))
{
- /* If arg is 'Null_Parameter, pass zero descriptor. */
+ /* If this is 'Null_Parameter, pass a 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);
+ gnu_actual
+ = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node);
else
gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
fill_vms_descriptor (gnu_actual,
}
else
{
- tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
+ tree gnu_size;
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)
+ 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))
+ if (TREE_CODE (gnu_actual) == INDIRECT_REF
+ && TREE_PRIVATE (gnu_actual)
+ && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual)))
+ && TREE_CODE (gnu_size) == INTEGER_CST
+ && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0)
gnu_actual
= unchecked_convert (DECL_ARG_TYPE (gnu_formal),
convert (gnat_type_for_size
- (tree_low_cst (gnu_actual_size, 1),
- 1),
+ (TREE_INT_CST_LOW (gnu_size), 1),
integer_zero_node),
false);
else
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);
+ gnu_call = build_call_list (TREE_TYPE (gnu_subprog_type), gnu_subprog_addr,
+ nreverse (gnu_actual_list));
+ set_expr_location_from_node (gnu_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))
+ /* If it's 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. */
+ if (Nkind (gnat_node) == N_Function_Call)
{
- /* 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);
+ tree gnu_result = gnu_call;
+ enum tree_code op_code;
- *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))
+ /* If the function returns an unconstrained array or by direct reference,
+ we have to dereference the pointer. */
+ if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
+ || TYPE_RETURN_BY_DIRECT_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);
+ {
+ /* ??? If the return type has non-constant size, then force the
+ return slot optimization as we would not be able to generate
+ a temporary. That's what has been done historically. */
+ if (TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_subprog_type))))
+ op_code = MODIFY_EXPR;
+ else
+ op_code = INIT_EXPR;
+
+ gnu_result
+ = build_binary_op (op_code, 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)
+ /* If this is the case where the GNAT tree contains a procedure call but the
+ Ada procedure has copy-in/copy-out parameters, then the special parameter
+ passing mechanism must be used. */
+ if (TYPE_CI_CO_LIST (gnu_subprog_type))
{
/* List of FIELD_DECLs associated with the PARM_DECLs of the copy
in copy out parameters. */
{
tree gnu_name;
- gnu_subprog_call = save_expr (gnu_subprog_call);
+ /* The call sequence must contain one and only one call, even though
+ the function is const or pure. So force a SAVE_EXPR. */
+ gnu_call = build1 (SAVE_EXPR, TREE_TYPE (gnu_call), gnu_call);
+ TREE_SIDE_EFFECTS (gnu_call) = 1;
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;
+ 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),
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,
+ = length == 1
+ ? gnu_call
+ : build_component_ref (gnu_call, NULL_TREE,
TREE_PURPOSE (scalar_return_list),
false);
= 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 (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
(Etype (Expression (gnat_actual)), gnu_result,
Do_Overflow_Check (gnat_actual),
Do_Range_Check (Expression (gnat_actual)),
- Float_Truncate (gnat_actual));
+ Float_Truncate (gnat_actual), gnat_actual);
if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
else
{
if (Do_Range_Check (gnat_actual))
- gnu_result = emit_range_check (gnu_result,
- Etype (gnat_actual));
+ gnu_result
+ = emit_range_check (gnu_result, Etype (gnat_actual),
+ 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);
}
+ /* Undo wrapping of boolean rvalues. */
+ if (TREE_CODE (gnu_actual) == NE_EXPR
+ && TREE_CODE (get_base_type (TREE_TYPE (gnu_actual)))
+ == BOOLEAN_TYPE
+ && integer_zerop (TREE_OPERAND (gnu_actual, 1)))
+ gnu_actual = TREE_OPERAND (gnu_actual, 0);
gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_actual, gnu_result);
set_expr_location_from_node (gnu_result, gnat_node);
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_call, &gnu_before_list);
append_to_statement_list (gnu_after_list, &gnu_before_list);
+
return gnu_before_list;
}
\f
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);
+ set_expr_location_from_node
+ (gnu_expr,
+ Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
if (gnu_else_ptr)
*gnu_else_ptr = gnu_expr;
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
+ __builtin_eh_pointer 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
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_current_exc_ptr
+ = build_call_expr (built_in_decls [BUILT_IN_EH_POINTER],
+ 1, integer_zero_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,
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. */
+ /* 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)))
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. */
+/* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
+ as gigi is concerned. This is used to avoid conversions on the LHS. */
+
+static bool
+unchecked_conversion_nop (Node_Id gnat_node)
+{
+ Entity_Id from_type, to_type;
+
+ /* The conversion must be on the LHS of an assignment or an actual parameter
+ of a call. Otherwise, even if the conversion was essentially a no-op, it
+ could de facto ensure type consistency and this should be preserved. */
+ if (!(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))
+ return false;
+
+ from_type = Etype (Expression (gnat_node));
+
+ /* We're interested in artificial conversions generated by the front-end
+ to make private types explicit, e.g. in Expand_Assign_Array. */
+ if (!Is_Private_Type (from_type))
+ return false;
+
+ from_type = Underlying_Type (from_type);
+ to_type = Etype (gnat_node);
+
+ /* The direct conversion to the underlying type is a no-op. */
+ if (to_type == from_type)
+ return true;
+
+ /* For an array type, the conversion to the PAT is a no-op. */
+ if (Ekind (from_type) == E_Array_Subtype
+ && to_type == Packed_Array_Type (from_type))
+ return true;
+
+ return false;
+}
+
+/* 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 this
+ is a statement, return the statement or add it to the current statement
+ group, in which case anything returned is to be interpreted as occurring
+ after anything added. */
tree
gnat_to_gnu (Node_Id gnat_node)
{
+ const Node_Kind kind = Nkind (gnat_node);
bool went_into_elab_proc = false;
- tree gnu_result = error_mark_node; /* Default to no value. */
+ 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;
+ tree gnu_expr, 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))
+ /* If this node is a statement and we are only annotating types, return an
+ empty statement list. */
+ if (type_annotate_only && IN (kind, 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 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
+ && IN (kind, N_Subexpr)
+ && kind != 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 ((IN (kind, N_Statement_Other_Than_Procedure_Call)
+ && !IN (kind, N_SCIL_Node)
+ && kind != N_Null_Statement)
+ || kind == N_Procedure_Call_Statement
+ || kind == N_Label
+ || kind == N_Implicit_Label_Declaration
+ || kind == N_Handled_Sequence_Of_Statements
+ || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void))
{
+ /* 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 (!current_function_decl)
{
current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
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
+ /* If we are in the elaboration procedure, check if we are violating a
+ No_Elaboration_Code restriction by having a statement there. 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)
+ && kind != N_Handled_Sequence_Of_Statements)
Check_Elaboration_Code_Allowed (gnat_node);
}
- switch (Nkind (gnat_node))
+ switch (kind)
{
/********************************/
- /* Chapter 2: Lexical Elements: */
+ /* Chapter 2: Lexical Elements */
/********************************/
case N_Identifier:
}
/* We should never see a Vax_Float type literal, since the front end
- is supposed to transform these using appropriate conversions */
+ 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));
int i;
char *string;
if (length >= ALLOCA_THRESHOLD)
- string = XNEWVEC (char, length + 1); /* in case of large strings */
- else
- string = (char *) alloca (length + 1);
+ string = XNEWVEC (char, length + 1);
+ else
+ string = (char *) alloca (length + 1);
/* Build the string with the characters in the literal. Note
that Ada strings are 1-origin. */
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);
+ if (length >= ALLOCA_THRESHOLD)
+ free (string);
}
else
{
break;
/**************************************/
- /* Chapter 3: Declarations and Types: */
+ /* Chapter 3: Declarations and Types */
/**************************************/
case N_Subtype_Declaration:
break;
if (Present (Expression (gnat_node))
- && !(Nkind (gnat_node) == N_Object_Declaration
- && No_Initialization (gnat_node))
+ && !(kind == 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));
+ gnu_expr
+ = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node);
/* If this object has its elaboration delayed, we must force
evaluation of GNU_EXPR right now and save it for when the object
break;
/*************************************/
- /* Chapter 4: Names and Expressions: */
+ /* Chapter 4: Names and Expressions */
/*************************************/
case N_Explicit_Dereference:
Node_Id *gnat_expr_array;
gnu_array_object = maybe_implicit_deref (gnu_array_object);
+
+ /* Convert vector inputs to their representative array type, to fit
+ what the code below expects. */
+ gnu_array_object = maybe_vector_array (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)))
+ if (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);
= 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))));
+ TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
+ gnat_temp);
gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
gnu_result, gnu_expr);
case N_Slice:
{
- tree gnu_type;
Node_Id gnat_range_node = Discrete_Range (gnat_node);
+ tree gnu_type;
gnu_result = gnat_to_gnu (Prefix (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_max_expr = protect_multiple_eval (gnu_max_expr);
/* Derive a good type to convert everything to. */
- gnu_expr_type = get_base_type (TREE_TYPE (gnu_index_type));
+ gnu_expr_type = get_base_type (gnu_index_type);
/* Test whether the minimum slice value is too small. */
gnu_expr_l = build_binary_op (LT_EXPR, integer_type_node,
gnu_base_max_expr));
/* Build a slice index check that returns the low bound,
- assuming the slice is not empty. */
+ assuming the slice is not empty. */
gnu_expr = emit_check
(build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
gnu_expr_l, gnu_expr_h),
- gnu_min_expr, CE_Index_Check_Failed);
+ gnu_min_expr, CE_Index_Check_Failed, gnat_node);
/* Build a conditional expression that does the index checks and
returns the low bound if the slice is not empty (max >= min),
/* Simply return the naked low bound. */
gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
+ /* If this is a slice with non-constant size of an array with constant
+ size, set the maximum size for the allocation of temporaries. */
+ if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
+ && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type)))
+ TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type);
+
gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
gnu_result, gnu_expr);
}
gnu_prefix = maybe_implicit_deref (gnu_prefix);
/* For discriminant references in tagged types always substitute the
- corresponding discriminant as the actual selected component. */
-
+ 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. */
-
+ 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,
{
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 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)))
case N_Attribute_Reference:
{
- /* The attribute designator (like an enumeration value). */
- int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
+ /* 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
&& TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
gnu_aggr_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
+ else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
+ gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
if (Null_Record_Present (gnat_node))
gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
= 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));
+ kind == N_Type_Conversion
+ && Float_Truncate (gnat_node), gnat_node);
break;
case N_Unchecked_Type_Conversion:
gnu_result = gnat_to_gnu (Expression (gnat_node));
+
+ /* Skip further processing if the conversion is deemed a no-op. */
+ if (unchecked_conversion_nop (gnat_node))
+ {
+ gnu_result_type = TREE_TYPE (gnu_result);
+ break;
+ }
+
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* If the result is a pointer type, see if we are improperly
case N_In:
case N_Not_In:
{
- tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
+ tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
Node_Id gnat_range = Right_Opnd (gnat_node);
- tree gnu_low;
- tree gnu_high;
+ tree gnu_low, gnu_high;
- /* GNAT_RANGE is either an N_Range node or an identifier
- denoting a subtype. */
+ /* 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)
+ || Nkind (gnat_range) == N_Expanded_Name)
{
tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
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 LOW and HIGH are identical, perform an equality test. Otherwise,
+ ensure that GNU_OBJ is evaluated only 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);
+ gnu_result
+ = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
else
{
- gnu_object = protect_multiple_eval (gnu_object);
+ tree t1, t2;
+ gnu_obj = protect_multiple_eval (gnu_obj);
+ t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
+ if (EXPR_P (t1))
+ set_expr_location_from_node (t1, gnat_node);
+ t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
+ if (EXPR_P (t2))
+ set_expr_location_from_node (t2, gnat_node);
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));
+ = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
}
- if (Nkind (gnat_node) == N_Not_In)
+ if (kind == N_Not_In)
gnu_result = invert_truthvalue (gnu_result);
}
break;
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
+ = (kind == N_Op_Or ? BIT_IOR_EXPR
+ : kind == N_Op_And ? BIT_AND_EXPR
: BIT_XOR_EXPR);
gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
case N_Op_Shift_Right_Arithmetic:
case N_And_Then: case N_Or_Else:
{
- enum tree_code code = gnu_codes[Nkind (gnat_node)];
+ enum tree_code code = gnu_codes[kind];
bool ignore_lhs_overflow = false;
tree gnu_type;
gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ /* Pending generic support for efficient vector logical operations in
+ GCC, convert vectors to their representative array type view and
+ fallthrough. */
+ gnu_lhs = maybe_vector_array (gnu_lhs);
+ gnu_rhs = maybe_vector_array (gnu_rhs);
+
/* If this is a comparison operator, convert any references to
an unconstrained array value into a reference to the
actual array. */
/* 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)))
+ 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))
+ if (IN (kind, 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)
+ if (kind == N_Op_Rotate_Left || kind == 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)
+ else if (kind == N_Op_Shift_Right_Arithmetic)
gnu_rhs
= build_binary_op
(MIN_EXPR, gnu_count_type,
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))
+ if (kind == 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
+ else if (kind == N_Op_Shift_Right_Arithmetic
&& TYPE_UNSIGNED (gnu_type))
{
gnu_type = gnat_signed_type (gnu_type);
do overflow checking, do it here. The goal is to push
the expansions further into the back end over time. */
if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
- && (Nkind (gnat_node) == N_Op_Add
- || Nkind (gnat_node) == N_Op_Subtract
- || Nkind (gnat_node) == N_Op_Multiply)
+ && (kind == N_Op_Add
+ || kind == N_Op_Subtract
+ || kind == N_Op_Multiply)
&& !TYPE_UNSIGNED (gnu_type)
&& !FLOAT_TYPE_P (gnu_type))
- gnu_result
- = build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs);
+ gnu_result = build_binary_op_trapv (code, gnu_type,
+ gnu_lhs, gnu_rhs, gnat_node);
else
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)
+ if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
&& !Shift_Count_OK (gnat_node))
gnu_result
= build_cond_expr
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)))));
+ 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);
+ gnu_result
+ = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
}
break;
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));
+ 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_type = get_unpadded_type (Base_Type
+ (Full_View (Etype (gnat_node))));
if (Do_Overflow_Check (gnat_node)
&& !TYPE_UNSIGNED (gnu_result_type)
&& !FLOAT_TYPE_P (gnu_result_type))
- gnu_result = build_unary_op_trapv (gnu_codes[Nkind (gnat_node)],
- gnu_result_type, gnu_expr);
+ gnu_result
+ = build_unary_op_trapv (gnu_codes[kind],
+ gnu_result_type, gnu_expr, gnat_node);
else
- gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
+ gnu_result = build_unary_op (gnu_codes[kind],
gnu_result_type, gnu_expr);
break;
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 (Do_Range_Check (Expression (gnat_temp)))
+ gnu_init
+ = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
if (Is_Elementary_Type (gnat_desig_type)
|| Is_Constrained (gnat_desig_type))
}
break;
- /***************************/
- /* Chapter 5: Statements: */
- /***************************/
+ /**************************/
+ /* Chapter 5: Statements */
+ /**************************/
case N_Label:
gnu_result = build1 (LABEL_EXPR, void_type_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_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)),
+ gnat_node);
gnu_result
= build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
case N_If_Statement:
{
- tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
+ 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,
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. */
+ tree gnu_ret_val, gnu_ret_obj;
+ /* If we have a return label defined, convert this into a branch to
+ that label. The return proper will be handled elsewhere. */
if (TREE_VALUE (gnu_return_label_stack))
{
gnu_result = build1 (GOTO_EXPR, void_type_node,
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 subprogram is a function, we must return the expression. */
+ 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)
+ tree gnu_subprog_type = TREE_TYPE (current_function_decl);
+ tree gnu_result_decl = DECL_RESULT (current_function_decl);
+ gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
+
+ /* Do not remove the padding from GNU_RET_VAL if the inner type is
+ self-referential since we want to allocate the fixed size. */
+ if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
+ && 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 the subprogram returns by direct reference, return a pointer
+ to the return value. */
+ if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
+ || By_Ref (gnat_node))
+ gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
+
+ /* Otherwise, if it returns an unconstrained array, we have to
+ allocate a new version of the result and return it. */
+ else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
{
- 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);
+ 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 subprogram returns by invisible reference, dereference
+ the pointer it is passed using the type of the return value
+ and build the copy operation manually. This ensures that we
+ don't copy too much data, for example if the return type is
+ unconstrained with a maximum size. */
+ if (TREE_ADDRESSABLE (gnu_subprog_type))
{
- 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);
- }
+ gnu_ret_obj
+ = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
+ gnu_result_decl);
+ gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
+ gnu_ret_obj, gnu_ret_val);
+ add_stmt_with_node (gnu_result, gnat_node);
+ gnu_ret_val = NULL_TREE;
+ gnu_ret_obj = gnu_result_decl;
}
+
+ /* Otherwise, build a regular return. */
+ else
+ gnu_ret_obj = gnu_result_decl;
}
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_ret_val = NULL_TREE;
+ gnu_ret_obj = NULL_TREE;
}
- gnu_result = build_return_expr (gnu_lhs, gnu_ret_val);
+ gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
}
break;
gnat_to_gnu (Name (gnat_node)));
break;
- /****************************/
- /* Chapter 6: Subprograms: */
- /****************************/
+ /***************************/
+ /* 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. */
+ node here. */
if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
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. */
+ /* 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;
gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
break;
- /*************************/
- /* Chapter 7: Packages: */
- /*************************/
+ /************************/
+ /* Chapter 7: Packages */
+ /************************/
case N_Package_Declaration:
gnu_result = gnat_to_gnu (Specification (gnat_node));
case N_Package_Body:
- /* If this is the body of a generic package - do nothing */
+ /* 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 ();
gnu_result = end_stmt_group ();
break;
- /*********************************/
- /* Chapter 8: Visibility Rules: */
- /*********************************/
+ /********************************/
+ /* 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 */
+ /* Nothing to do here - but these may appear in list of declarations. */
gnu_result = alloc_stmt_list ();
break;
- /***********************/
- /* Chapter 9: Tasks: */
- /***********************/
+ /*********************/
+ /* Chapter 9: Tasks */
+ /*********************/
case N_Protected_Type_Declaration:
gnu_result = alloc_stmt_list ();
gnu_result = alloc_stmt_list ();
break;
- /***********************************************************/
- /* Chapter 10: Program Structure and Compilation Issues: */
- /***********************************************************/
+ /*********************************************************/
+ /* Chapter 10: Program Structure and Compilation Issues */
+ /*********************************************************/
case N_Compilation_Unit:
break;
/***************************/
- /* Chapter 11: Exceptions: */
+ /* Chapter 11: Exceptions */
/***************************/
case N_Handled_Sequence_Of_Statements:
= TREE_CHAIN (gnu_program_error_label_stack);
break;
- /*******************************/
- /* Chapter 12: Generic Units: */
- /*******************************/
+ /******************************/
+ /* Chapter 12: Generic Units */
+ /******************************/
case N_Generic_Function_Renaming_Declaration:
case N_Generic_Package_Renaming_Declaration:
gnu_result = alloc_stmt_list ();
break;
- /***************************************************/
- /* Chapter 13: Representation Clauses and */
- /* Implementation-Dependent Features: */
- /***************************************************/
+ /**************************************************/
+ /* Chapter 13: Representation Clauses and */
+ /* Implementation-Dependent Features */
+ /**************************************************/
case N_Attribute_Definition_Clause:
gnu_result = alloc_stmt_list ();
build_string (strlen (clobber) + 1, clobber),
gnu_clobbers);
- /* Then perform some standard checking and processing on the
+ /* 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);
TREE_VALUE (tail) = input;
}
- gnu_result = build4 (ASM_EXPR, void_type_node,
+ gnu_result = build5 (ASM_EXPR, void_type_node,
gnu_template, gnu_outputs,
- gnu_inputs, gnu_clobbers);
+ gnu_inputs, gnu_clobbers, NULL_TREE);
ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
}
else
break;
- /***************************************************/
- /* Added Nodes */
- /***************************************************/
+ /****************/
+ /* Added Nodes */
+ /****************/
case N_Freeze_Entity:
start_stmt_group ();
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)))
+ if (TYPE_IS_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));
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)))
+ if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
gnu_ptr
= convert (build_pointer_type
(TYPE_OBJECT_RECORD_TYPE
if (Present (Actual_Designated_Subtype (gnat_node)))
{
gnu_actual_obj_type
- = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
+ = 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"));
+ if (TYPE_IS_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))
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);
+ gnu_result
+ = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
+ Procedure_To_Call (gnat_node),
+ Storage_Pool (gnat_node),
+ gnat_node);
}
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));
+ = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node, kind);
/* If the type is VOID, this is a statement, so we need to
generate the code for the call. Handle a Condition, if there
if ((TYPE_DUMMY_P (gnu_target_desig_type)
|| get_alias_set (gnu_target_desig_type) != 0)
- && (!POINTER_TYPE_P (gnu_source_type)
+ && (!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))))
+ || !alias_sets_conflict_p
+ (get_alias_set (gnu_source_desig_type),
+ get_alias_set (gnu_target_desig_type))))
{
post_error_ne
("?possible aliasing problem for type&",
/* 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))
+ else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
{
tree gnu_source_array_type
- = TYPE_FAT_POINTER_P (gnu_source_type)
+ = TYPE_IS_FAT_POINTER_P (gnu_source_type)
? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
: NULL_TREE;
tree gnu_target_array_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_IS_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))))
+ || !alias_sets_conflict_p
+ (get_alias_set (gnu_source_array_type),
+ get_alias_set (gnu_target_array_type))))
{
post_error_ne
("?possible aliasing problem for type&",
gnu_result = alloc_stmt_list ();
break;
+ case N_SCIL_Dispatch_Table_Object_Init:
+ case N_SCIL_Dispatch_Table_Tag_Init:
+ case N_SCIL_Dispatching_Call:
+ case N_SCIL_Membership_Test:
+ case N_SCIL_Tag_Init:
+ /* SCIL nodes require no processing for GCC. */
+ gnu_result = alloc_stmt_list ();
+ break;
+
case N_Raise_Statement:
case N_Function_Specification:
case N_Procedure_Specification:
if (gnu_result
&& EXPR_P (gnu_result)
&& TREE_CODE (gnu_result) != NOP_EXPR
- && !REFERENCE_CLASS_P (gnu_result))
+ && !REFERENCE_CLASS_P (gnu_result)
+ && !EXPR_HAS_LOCATION (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
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))
+ /* If the result is a constant that overflowed, raise Constraint_Error. */
+ 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,
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
+ the result type has a simpler size. Likewise if there is just
+ a no-op unchecked conversion in-between. Similarly, don't convert
integral types that are the operands of an unchecked conversion
since we need to ignore those conversions (for 'Valid).
if (Present (Parent (gnat_node))
&& ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
&& Name (Parent (gnat_node)) == gnat_node)
+ || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
+ && unchecked_conversion_nop (Parent (gnat_node)))
|| (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
&& Name (Parent (gnat_node)) != gnat_node)
|| Nkind (Parent (gnat_node)) == N_Parameter_Association
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))
+ if (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))),
&& 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)))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
gnu_result);
}
/* 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);
+ 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));
+ 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 if (TREE_CODE (gnu_decl) == TYPE_DECL
+ && ((TREE_CODE (type) == RECORD_TYPE
+ && !TYPE_FAT_POINTER_P (type))
+ || TREE_CODE (type) == UNION_TYPE
+ || TREE_CODE (type) == QUAL_UNION_TYPE))
+ MARK_VISITED (TYPE_ADA_SIZE (type));
}
else
add_stmt_with_node (gnu_stmt, gnat_entity);
{
/* 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))
+ if (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);
+ gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
DECL_INITIAL (gnu_decl) = NULL_TREE;
if (TREE_READONLY (gnu_decl))
static tree
mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
{
- if (TREE_VISITED (*tp))
+ tree t = *tp;
+
+ if (TREE_VISITED (t))
*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;
+ else if (!TYPE_IS_DUMMY_P (t))
+ TREE_VISITED (t) = 1;
- if (TYPE_P (*tp))
- TYPE_SIZES_GIMPLIFIED (*tp) = 1;
+ if (TYPE_P (t))
+ TYPE_SIZES_GIMPLIFIED (t) = 1;
return NULL_TREE;
}
+/* Mark nodes rooted at T 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 t)
+{
+ walk_tree (&t, mark_visited_r, NULL, NULL);
+}
+
/* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
static tree
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. */
case ADDR_EXPR:
op = TREE_OPERAND (expr, 0);
- /* If we're taking the address of a constant CONSTRUCTOR, force it to
+ /* If we are 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. */
+ the semantics we have and it's required to be in static memory 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_ADDRESSABLE (new_var) = 1;
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;
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)
+ /* If we are taking the address of a SAVE_EXPR, we are typically dealing
+ with a misaligned argument to be passed by reference in a subprogram
+ call. We cannot let the common gimplifier code perform the creation
+ of the temporary and its initialization because, in order to ensure
+ that the final copy operation is a store and since the temporary made
+ for a SAVE_EXPR is not addressable, it may create another temporary,
+ addressable this time, which would break the back copy mechanism for
+ an IN OUT parameter. */
+ if (TREE_CODE (op) == SAVE_EXPR && !SAVE_EXPR_RESOLVED_P (op))
{
- 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 mod, val = TREE_OPERAND (op, 0);
+ tree new_var = create_tmp_var (TREE_TYPE (op), "S");
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));
+ mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, val);
+ if (EXPR_HAS_LOCATION (val))
+ SET_EXPR_LOCATION (mod, EXPR_LOCATION (val));
+ gimplify_and_add (mod, pre_p);
+ ggc_free (mod);
+
+ TREE_OPERAND (op, 0) = new_var;
+ SAVE_EXPR_RESOLVED_P (op) = 1;
TREE_OPERAND (expr, 0) = new_var;
recompute_tree_invariant_for_addr_expr (expr);
return GS_ALL_DONE;
}
+ return GS_UNHANDLED;
+
+ case DECL_EXPR:
+ op = DECL_EXPR_DECL (expr);
+
+ /* The expressions for the RM bounds must be gimplified to ensure that
+ they are properly elaborated. See gimplify_decl_expr. */
+ if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
+ && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
+ switch (TREE_CODE (TREE_TYPE (op)))
+ {
+ case INTEGER_TYPE:
+ case ENUMERAL_TYPE:
+ case BOOLEAN_TYPE:
+ case REAL_TYPE:
+ {
+ tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
+
+ val = TYPE_RM_MIN_VALUE (type);
+ if (val)
+ {
+ gimplify_one_sizepos (&val, pre_p);
+ for (t = type; t; t = TYPE_NEXT_VARIANT (t))
+ SET_TYPE_RM_MIN_VALUE (t, val);
+ }
+
+ val = TYPE_RM_MAX_VALUE (type);
+ if (val)
+ {
+ gimplify_one_sizepos (&val, pre_p);
+ for (t = type; t; t = TYPE_NEXT_VARIANT (t))
+ SET_TYPE_RM_MAX_VALUE (t, val);
+ }
+
+ }
+ break;
+
+ default:
+ break;
+ }
+
/* ... fall through ... */
default:
case LOOP_STMT:
{
- tree gnu_start_label = create_artificial_label ();
+ tree gnu_start_label = create_artificial_label (input_location);
tree gnu_end_label = LOOP_STMT_LABEL (stmt);
tree t;
&& !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
= 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. */
+ 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))))
+ /* Don't do anything for class-wide types as they are always transformed
+ into their root type. */
+ if (Ekind (gnat_entity) == E_Class_Wide_Type)
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. */
+ purposes. */
if (gnu_old
&& ((TREE_CODE (gnu_old) == FUNCTION_DECL
&& (Ekind (gnat_entity) == E_Function
/* 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. */
+ a class wide type or subtype. */
if (gnu_old)
{
save_gnu_tree (gnat_entity, NULL_TREE, false);
static void
process_decls (List_Id gnat_decls, List_Id gnat_decls2,
- Node_Id gnat_end_list, bool pass1p, bool pass2p)
+ Node_Id gnat_end_list, bool pass1p, bool pass2p)
{
List_Id gnat_decl_array[2];
Node_Id gnat_decl;
&& Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
record_code_position (gnat_decl);
- else if (Nkind (gnat_decl) == N_Package_Body_Stub
+ else if (Nkind (gnat_decl) == N_Package_Body_Stub
&& Present (Library_Unit (gnat_decl))
&& Present (Freeze_Node
(Corresponding_Spec
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. */
+
+ /* 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));
+ 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_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));
}
/* Make a unary operation of kind CODE using build_unary_op, but guard
the operation by an overflow check. CODE can be one of NEGATE_EXPR
or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
- the operation is to be performed in that type. */
+ the operation is to be performed in that type. GNAT_NODE is the gnat
+ node conveying the source location for which the error should be
+ signaled. */
static tree
-build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand)
+build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
+ Node_Id gnat_node)
{
gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
operand, TYPE_MIN_VALUE (gnu_type)),
build_unary_op (code, gnu_type, operand),
- CE_Overflow_Check_Failed);
+ CE_Overflow_Check_Failed, gnat_node);
}
/* Make a binary operation of kind CODE using build_binary_op, but guard
the operation by an overflow check. CODE can be one of PLUS_EXPR,
MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
- Usually the operation is to be performed in that type. */
+ Usually the operation is to be performed in that type. GNAT_NODE is
+ the GNAT node conveying the source location for which the error should
+ be signaled. */
static tree
build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
- tree right)
+ tree right, Node_Id gnat_node)
{
tree lhs = protect_multiple_eval (left);
tree rhs = protect_multiple_eval (right);
int needed_precision = precision * 2;
if (code == MULT_EXPR && precision == 64)
- {
+ {
tree int_64 = gnat_type_for_size (64, 0);
return convert (gnu_type, build_call_2_expr (mulv64_decl,
}
else if (needed_precision <= BITS_PER_WORD
- || (code == MULT_EXPR
+ || (code == MULT_EXPR
&& needed_precision <= LONG_LONG_TYPE_SIZE))
{
tree wide_type = gnat_type_for_size (needed_precision, 0);
tree result = convert (gnu_type, wide_result);
- return emit_check (check, result, CE_Overflow_Check_Failed);
+ return
+ emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
}
else if (code == PLUS_EXPR || code == MINUS_EXPR)
build_binary_op (code == PLUS_EXPR ? LT_EXPR : GT_EXPR,
integer_type_node, wrapped_expr, lhs));
- return emit_check (check, result, CE_Overflow_Check_Failed);
+ return
+ emit_check (check, result, CE_Overflow_Check_Failed, gnat_node);
}
}
case MULT_EXPR:
/* The check here is designed to be efficient if the rhs is constant,
- but it will work for any rhs by using integer division.
- Four different check expressions determine wether X * C overflows,
+ but it will work for any rhs by using integer division.
+ Four different check expressions determine wether X * C overflows,
depending on C.
C == 0 => false
C > 0 => X > type_max / C || X < type_min / C
check = fold_build3 (COND_EXPR, integer_type_node,
rhs_lt_zero, check_neg, check_pos);
- return emit_check (check, gnu_expr, CE_Overflow_Check_Failed);
+ return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
}
/* 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. */
+ which we have to check. GNAT_NODE is the GNAT node conveying the source
+ location for which the error should be signaled. */
static tree
-emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
+emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node)
{
tree gnu_range_type = get_unpadded_type (gnat_range_type);
tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
< TYPE_PRECISION (get_base_type (gnu_range_type))))
return gnu_expr;
- /* Checked expressions must be evaluated only once. */
+ /* 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. */
+ (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
convert (gnu_compare_type, gnu_expr),
convert (gnu_compare_type,
gnu_high)))),
- gnu_expr, CE_Range_Check_Failed);
+ gnu_expr, CE_Range_Check_Failed, gnat_node);
}
\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 */
+/* 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 simply 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 get
+ 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. GNAT_NODE is the GNAT node conveying the source
+ location for which the error should be signaled. */
static tree
-emit_index_check (tree gnu_array_object,
- tree gnu_expr,
- tree gnu_low,
- tree gnu_high)
+emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low,
+ tree gnu_high, Node_Id gnat_node)
{
tree gnu_expr_check;
- /* Checked expressions must be evaluated only once. */
+ /* 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
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. */
+ 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);
gnu_expr_check,
convert (TREE_TYPE (gnu_expr_check),
gnu_high))),
- gnu_expr, CE_Index_Check_Failed);
+ gnu_expr, CE_Index_Check_Failed, gnat_node);
}
\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. */
+ REASON is the code that says why the exception was raised. GNAT_NODE is
+ the GNAT node conveying the source location for which the error should be
+ signaled. */
static tree
-emit_check (tree gnu_cond, tree gnu_expr, int reason)
+emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
{
- tree gnu_call = build_call_raise (reason, Empty, N_Raise_Constraint_Error);
+ tree gnu_call
+ = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
tree gnu_result
= fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
return 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. */
+/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
+ checks if OVERFLOW_P is true and range checks if RANGE_P is true.
+ GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a
+ float to integer conversion with truncation; otherwise round.
+ GNAT_NODE is the GNAT node conveying the source location for which the
+ error should be signaled. */
static tree
convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
- bool rangep, bool truncatep)
+ bool rangep, bool truncatep, Node_Id gnat_node)
{
tree gnu_type = get_unpadded_type (gnat_type);
tree gnu_in_type = TREE_TYPE (gnu_expr);
if (!integer_zerop (gnu_cond))
gnu_result = emit_check (gnu_cond, gnu_input,
- CE_Overflow_Check_Failed);
+ CE_Overflow_Check_Failed, gnat_node);
}
/* Now convert to the result base type. If this is a non-truncating
&& !truncatep)
{
REAL_VALUE_TYPE half_minus_pred_half, pred_half;
- tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
+ tree gnu_conv, gnu_zero, gnu_comp, 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 if FP_ARITH_MAY_WIDEN is true. */
-
- calc_type = (FP_ARITH_MAY_WIDEN ? longest_float_type_node
- : gnu_in_basetype);
+ of each arithmetic operation. In order to prevent excess
+ precision from spoiling this property, use the widest hardware
+ floating-point type if FP_ARITH_MAY_WIDEN is true. */
+ calc_type
+ = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype;
- /* 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));
+ /* FIXME: Should not have padding in the first place. */
+ if (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. */
+ /* 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);
+ 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).
- */
+ 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_result = protect_multiple_eval (gnu_result);
+ gnu_conv = convert (calc_type, gnu_result);
+ gnu_comp
+ = fold_build2 (GE_EXPR, integer_type_node, gnu_result, gnu_zero);
gnu_add_pred_half
- = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
+ = fold_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);
+ = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
+ gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
+ gnu_add_pred_half, gnu_subtract_pred_half);
}
if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
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. */
-
+ /* 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);
+ gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node);
return convert (gnu_type, gnu_result);
}
case UNCONSTRAINED_ARRAY_REF:
case INDIRECT_REF:
+ return true;
+
case CONSTRUCTOR:
case STRING_CST:
case INTEGER_CST:
case NULL_EXPR:
case SAVE_EXPR:
case CALL_EXPR:
+ case PLUS_EXPR:
+ case MINUS_EXPR:
+ case BIT_IOR_EXPR:
+ case BIT_XOR_EXPR:
+ case BIT_AND_EXPR:
+ case BIT_NOT_EXPR:
+ /* All rvalues are deemed addressable since taking their address will
+ force a temporary to be created by the middle-end. */
return true;
case COND_EXPR:
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
+ && (!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))))
+ || TYPE_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:
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);
-
+ {
+ tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
save_gnu_tree (gnat_entity, gnu_decl, false);
if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity)))
/* 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. */
-
+ 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_expr = gnat_to_gnu (Expression (gnat_assoc));
/* The expander is supposed to put a single component selector name
- in every record component association */
+ in every record component association. */
gcc_assert (No (Next (gnat_field)));
/* Ignore fields that have Corresponding_Discriminants since we'll
/* 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 = emit_range_check (gnu_expr, Etype (gnat_field), Empty);
gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
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. */
+/* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
+ the first element of an array aggregate. It may itself be an aggregate.
+ GNU_ARRAY_TYPE is the GCC 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)
+ Entity_Id gnat_component_type)
{
tree gnu_expr_list = NULL_TREE;
tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
/* 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 = gnat_to_gnu (gnat_expr);
- /* before assigning the element to the array make sure it is
- in range */
+ /* 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 = emit_range_check (gnu_expr, gnat_component_type, Empty);
}
gnu_expr_list
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)))
+ if (POINTER_TYPE_P (TREE_TYPE (exp))
+ || TYPE_IS_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)))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
return exp;
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))
+ enum tree_code code = TREE_CODE (exp);
+
+ /* If EXP has no side effects, we theoritically don't need to do anything.
+ However, we may be recursively passed more and more complex expressions
+ involving checks which will be reused multiple times and eventually be
+ unshared for gimplification; in order to avoid a complexity explosion
+ at that point, we protect any expressions more complex than a simple
+ arithmetic expression. */
+ if (!TREE_SIDE_EFFECTS (exp)
+ && (CONSTANT_CLASS_P (exp)
+ || !EXPRESSION_CLASS_P (skip_simple_arithmetic (exp))))
return exp;
- /* If it is a conversion, protect what's inside the conversion.
+ /* If this 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)
+ need to protect the address since the data itself can't change
+ in these situations. */
+ if (code == NON_LVALUE_EXPR
+ || CONVERT_EXPR_CODE_P (code)
+ || code == VIEW_CONVERT_EXPR
+ || code == INDIRECT_REF
+ || code == UNCONSTRAINED_ARRAY_REF)
+ return build1 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0)));
+
+ /* 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_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
+ return build3 (code, type, protect_multiple_eval (TREE_OPERAND (exp, 0)),
+ TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
+
+ /* If this is a fat pointer or something that can be placed in a register,
+ just make a SAVE_EXPR. Likewise for a CALL_EXPR as large objects are
+ returned via invisible reference in most ABIs so the temporary will
+ directly be filled by the callee. */
+ if (TYPE_IS_FAT_POINTER_P (type)
+ || TYPE_MODE (type) != BLKmode
+ || code == CALL_EXPR)
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)));
+ /* Otherwise reference, protect the address and dereference. */
+ 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
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. */
+ case COMPOUND_EXPR:
result = gnat_stabilize_reference_1 (ref, force);
break;
case ERROR_MARK:
ref = error_mark_node;
- /* ... Fallthru to failure ... */
+ /* ... fall through to failure ... */
/* If arg isn't a kind of lvalue we recognize, make no change.
Caller should recognize the error for an invalid lvalue. */
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.
+ /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression
+ may not be sustained across some paths, such as the way via build1 for
+ INDIRECT_REF. We reset those flags here in 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);
+ paths introduce side-effects where there was none initially (e.g. if a
+ SAVE_EXPR is built) and we also want to keep track of that. */
+ TREE_READONLY (result) = TREE_READONLY (ref);
TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
+ TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
return result;
}
-/* Wrapper around maybe_stabilize_reference, for common uses without
- lvalue restrictions and without need to examine the success
- indication. */
+/* Wrapper around maybe_stabilize_reference, for common uses without lvalue
+ restrictions and without the need to examine the success indication. */
static tree
gnat_stabilize_reference (tree ref, bool force)
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:
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));
+ && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
+ result
+ = build3 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
+ TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
+ /* If the expression has side-effects, then encase it in a SAVE_EXPR
+ so that it will only be evaluated once. */
+ /* The tcc_reference and tcc_comparison classes could be handled as
+ below, but it is generally faster to only evaluate them once. */
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));
+ 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));
+ result
+ = build1 (code, type,
+ gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force));
break;
default:
gcc_unreachable ();
}
+ /* See similar handling in maybe_stabilize_reference. */
TREE_READONLY (result) = TREE_READONLY (e);
-
- TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
+ TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
+
return result;
}
\f
if (Sloc <= Standard_Location)
{
- if (*locus == UNKNOWN_LOCATION)
- *locus = BUILTINS_LOCATION;
+ *locus = BUILTINS_LOCATION;
return false;
}
else
extract_encoding (const char *name)
{
char *encoding = GGC_NEWVEC (char, strlen (name));
-
get_encoding (name, encoding);
-
return encoding;
}
decode_name (const char *name)
{
char *decoded = GGC_NEWVEC (char, strlen (name) * 2 + 60);
-
__gnat_decode (name, decoded, 0);
-
return decoded;
}
\f
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)
+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);
OSDN Git Service
