2009-04-07 Eric Botcazou <ebotcazou@adacore.com>
+ * gcc-interface/gigi.h (standard_datatypes): Remove ADT_void_type_decl.
+ (void_type_decl_node): Remove.
+ (init_gigi_decls): Likewise.
+ (gnat_install_builtins): Declare.
+ (record_builtin_type): Likewise.
+ (create_type_stub_decl): Likewise.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Void>: Use void_type.
+ (gnat_to_gnu_entity) <E_Array_Type>: Make fat and thin pointer types
+ artificial.
+ <E_Array_Subtype>: Use the index types, not only their name, in the
+ record giving the names of the bounds, if any.
+ For a packed array type, make it artificial only if the base type
+ was artificial as well. Remove redundant statement.
+ (gnat_to_gnu_entity) <E_Incomplete_Type>: Do not create TYPE_DECL for
+ dummy types.
+ Use create_type_stub_decl to build the TYPE_STUB_DECL of types.
+ (rest_of_type_decl_compilation_no_defer): Likewise.
+ * gcc-interface/misc.c (gnat_printable_name): Add missing guard.
+ * gcc-interface/utils.c (make_dummy_type): Always create TYPE_STUB_DECL
+ and use create_type_stub_decl to build it.
+ (gnat_pushdecl): Rewrite condition.
+ (gnat_install_builtins): Remove bogus declaration.
+ (record_builtin_type): New function.
+ (finish_record_type): Use create_type_stub_decl to build TYPE_STUB_DECL
+ of types.
+ (create_type_stub_decl): New function.
+ (create_type_decl): Assert that the type is not dummy. If the type
+ hasn't been named yet, equate the TYPE_STUB_DECL to the created node.
+ (build_vms_descriptor32): Do not create TYPE_DECL for the descriptor.
+ (build_vms_descriptor): Likewise.
+ (init_gigi_decls): Delete and move bulk of code to...
+ * gcc-interface/trans.c (gigi): ...here. Use record_builtin_type.
+ (emit_range_check): Add gnat_node parameter.
+ (emit_index_check): Likewise.
+ (emit_check): Likewise.
+ (build_unary_op_trapv): Likewise.
+ (build_binary_op_trapv): Likewise.
+ (convert_with_check): Likewise.
+ (Attribute_to_gnu): Adjust calls for above changes.
+ (call_to_gnu): Likewise.
+ (gnat_to_gnu): Likewise.
+ (assoc_to_constructor): Likewise.
+ (pos_to_constructor): Likewise.
+ (Sloc_to_locus): Set BUILTINS_LOCATION for Standard_Location nodes.
+ (process_type): Do not create TYPE_DECL for dummy types.
+
+2009-04-07 Eric Botcazou <ebotcazou@adacore.com>
+
* gcc-interface/decl.c (gnat_to_gnu_entity): Reorder local variables.
* gcc-interface/trans.c: Fix formatting throughout. Fix comments.
* gcc-interface/utils.c: Fix comments.
case E_Void:
/* Return a TYPE_DECL for "void" that we previously made. */
- gnu_decl = void_type_decl_node;
+ gnu_decl = TYPE_NAME (void_type_node);
break;
case E_Enumeration_Type:
/* Give the fat pointer type a name. */
create_type_decl (create_concat_name (gnat_entity, "XUP"),
- gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
+ gnu_fat_type, NULL, true,
debug_info_p, gnat_entity);
/* Create the type to be used as what a thin pointer designates: an
/* Give the thin pointer type a name. */
create_type_decl (create_concat_name (gnat_entity, "XUX"),
- build_pointer_type (tem), NULL,
- !Comes_From_Source (gnat_entity), debug_info_p,
- gnat_entity);
+ build_pointer_type (tem), NULL, true,
+ debug_info_p, gnat_entity);
}
break;
TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
}
+ /* Attach the TYPE_STUB_DECL in case we have a parallel type. */
+ if (need_index_type_struct)
+ TYPE_STUB_DECL (gnu_type)
+ = create_type_stub_decl (gnu_entity_id, gnu_type);
+
/* If we are at file level and this is a multi-dimensional array, we
need to make a variable corresponding to the stride of the
inner dimensions. */
}
/* If we need to write out a record type giving the names of
- the bounds, do it now. */
+ the bounds, do it now. Make sure to reference the index
+ types themselves, not just their names, as the debugger
+ may fall back on them in some cases. */
if (need_index_type_struct && debug_info_p)
{
- tree gnu_bound_rec_type = make_node (RECORD_TYPE);
+ tree gnu_bound_rec = make_node (RECORD_TYPE);
tree gnu_field_list = NULL_TREE;
tree gnu_field;
- TYPE_NAME (gnu_bound_rec_type)
+ TYPE_NAME (gnu_bound_rec)
= create_concat_name (gnat_entity, "XA");
for (index = array_dim - 1; index >= 0; index--)
{
- tree gnu_type_name
- = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
+ tree gnu_index = TYPE_INDEX_TYPE (gnu_index_type[index]);
+ tree gnu_index_name = TYPE_NAME (gnu_index);
- if (TREE_CODE (gnu_type_name) == TYPE_DECL)
- gnu_type_name = DECL_NAME (gnu_type_name);
+ if (TREE_CODE (gnu_index_name) == TYPE_DECL)
+ gnu_index_name = DECL_NAME (gnu_index_name);
- gnu_field = create_field_decl (gnu_type_name,
- integer_type_node,
- gnu_bound_rec_type,
+ gnu_field = create_field_decl (gnu_index_name, gnu_index,
+ gnu_bound_rec,
0, NULL_TREE, NULL_TREE, 0);
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
}
- finish_record_type (gnu_bound_rec_type, gnu_field_list,
- 0, false);
-
- TYPE_STUB_DECL (gnu_type)
- = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
-
- add_parallel_type
- (TYPE_STUB_DECL (gnu_type), gnu_bound_rec_type);
+ finish_record_type (gnu_bound_rec, gnu_field_list, 0, false);
+ add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
}
TYPE_CONVENTION_FORTRAN_P (gnu_type)
}
/* If this is a packed type, make this type the same as the packed
- array type, but do some adjusting in the type first. */
-
+ array type, but do some adjusting in the type first. */
if (Present (Packed_Array_Type (gnat_entity)))
{
Entity_Id gnat_index;
tree gnu_inner_type;
/* First finish the type we had been making so that we output
- debugging information for it */
+ debugging information for it. */
gnu_type
= build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| (TYPE_QUAL_VOLATILE
* Treat_As_Volatile (gnat_entity))));
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- if (!Comes_From_Source (gnat_entity))
- DECL_ARTIFICIAL (gnu_decl) = 1;
+
+ /* Make it artificial only if the base type was artificial as well.
+ That's sort of "morally" true and will make it possible for the
+ debugger to look it up by name in DWARF more easily. */
+ gnu_decl
+ = create_type_decl (gnu_entity_id, gnu_type, attr_list,
+ !Comes_From_Source (gnat_entity)
+ && !Comes_From_Source (Etype (gnat_entity)),
+ debug_info_p, gnat_entity);
/* Save it as our equivalent in case the call below elaborates
this type again. */
if (No (full_view))
{
if (kind == E_Incomplete_Type)
- gnu_type = make_dummy_type (gnat_entity);
+ {
+ gnu_type = make_dummy_type (gnat_entity);
+ gnu_decl = TYPE_STUB_DECL (gnu_type);
+ }
else
{
gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
}
/* For incomplete types, make a dummy type entry which will be
- replaced later. */
+ replaced later. Save it as the full declaration's type so
+ we can do any needed updates when we see it. */
gnu_type = make_dummy_type (gnat_entity);
-
- /* Save this type as the full declaration's type so we can do any
- needed updates when we see it. */
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
+ gnu_decl = TYPE_STUB_DECL (gnu_type);
save_gnu_tree (full_view, gnu_decl, 0);
break;
}
continue;
if (!TYPE_STUB_DECL (t))
- {
- TYPE_STUB_DECL (t) = build_decl (TYPE_DECL, DECL_NAME (decl), t);
- DECL_ARTIFICIAL (TYPE_STUB_DECL (t)) = 1;
- }
+ TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t);
rest_of_type_compilation (t, toplev);
}
* *
* C Header File *
* *
- * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2009, 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- *
/* Define the entries in the standard data array. */
enum standard_datatypes
{
-/* Various standard data types and nodes. */
+ /* The longest floating-point type. */
ADT_longest_float_type,
- ADT_void_type_decl,
/* The type of an exception. */
ADT_except_type,
extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
#define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type]
-#define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl]
#define except_type_node gnat_std_decls[(int) ADT_except_type]
#define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type]
#define void_ftype gnat_std_decls[(int) ADT_void_ftype]
extern void gnat_pushdecl (tree decl, Node_Id gnat_node);
extern void gnat_init_decl_processing (void);
-extern void init_gigi_decls (tree long_long_float_type, tree exception_type);
extern void gnat_init_gcc_eh (void);
+extern void gnat_install_builtins (void);
/* Return an integer type with the number of bits of precision given by
PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
/* Initialize tables for above routines. */
extern void init_gnat_to_gnu (void);
+/* Record TYPE as a builtin type for Ada. NAME is the name of the type. */
+extern void record_builtin_type (const char *name, tree type);
+
/* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST,
finish constructing the record or union type. If REP_LEVEL is zero, this
record has no representation clause and so will be entirely laid out here.
extern tree create_index_type (tree min, tree max, tree index,
Node_Id gnat_node);
-/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
- string) and TYPE is a ..._TYPE node giving its data type.
- ARTIFICIAL_P is true if this is a declaration that was generated
- by the compiler. DEBUG_INFO_P is true if we need to write debugging
- information about this type. GNAT_NODE is used for the position of
- the decl. */
+/* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type.
+ TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving
+ its data type. */
+extern tree create_type_stub_decl (tree type_name, tree type);
+
+/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE
+ is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this
+ is a declaration that was generated by the compiler. DEBUG_INFO_P is
+ true if we need to write debug information about this type. GNAT_NODE
+ is used for the position of the decl. */
extern tree create_type_decl (tree type_name, tree type,
struct attrib *attr_list,
bool artificial_p, bool debug_info_p,
__gnat_decode (coded_name, ada_name, 0);
- if (verbosity == 2)
+ if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
{
Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
return ggc_strdup (Name_Buffer);
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);
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;
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);
+ /* 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 (build_int_cst (NULL_TREE, 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);
+
+ 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);
+
+ /* 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);
+ null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
+ }
+
+ /* 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)))
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;
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
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.
(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_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
= 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);
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),
Do_Overflow_Check (gnat_node),
Do_Range_Check (Expression (gnat_node)),
Nkind (gnat_node) == N_Type_Conversion
- && Float_Truncate (gnat_node));
+ && Float_Truncate (gnat_node), gnat_node);
break;
case N_Unchecked_Type_Conversion:
|| Nkind (gnat_node) == 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 (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[Nkind (gnat_node)],
+ gnu_result_type, gnu_expr, gnat_node);
else
gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
gnu_result_type, gnu_expr);
gnu_init = maybe_unconstrained_array (gnu_init);
if (Do_Range_Check (Expression (gnat_temp)))
- gnu_init = emit_range_check (gnu_init, gnat_desig_type);
+ gnu_init
+ = emit_range_check (gnu_init, gnat_desig_type, gnat_temp);
if (Is_Elementary_Type (gnat_desig_type)
|| Is_Constrained (gnat_desig_type))
/* 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);
/* 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);
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);
}
}
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);
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
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. */
+ 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)
+ tree gnu_high, Node_Id gnat_node)
{
tree gnu_expr_check;
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 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. */
+ 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);
gnu_out_ub))));
if (!integer_zerop (gnu_cond))
- gnu_result
- = emit_check (gnu_cond, gnu_input, CE_Overflow_Check_Failed);
+ gnu_result = emit_check (gnu_cond, gnu_input,
+ CE_Overflow_Check_Failed, gnat_node);
}
/* Now convert to the result base type. If this is a non-truncating
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);
}
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)))
/* 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);
/* 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
+ /* 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
if (Sloc <= Standard_Location)
{
- if (*locus == UNKNOWN_LOCATION)
- *locus = BUILTINS_LOCATION;
+ *locus = BUILTINS_LOCATION;
return false;
}
else
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2009, 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- *
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
-static void gnat_install_builtins (void);
static tree merge_sizes (tree, tree, tree, bool, bool);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
: ENUMERAL_TYPE);
TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
TYPE_DUMMY_P (gnu_type) = 1;
+ TYPE_STUB_DECL (gnu_type)
+ = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
if (AGGREGATE_TYPE_P (gnu_type))
- {
- TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
- TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
- }
+ TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
SET_DUMMY_NODE (gnat_underlying, gnu_type);
}
/* For the declaration of a type, set its name if it either is not already
- set, was set to an IDENTIFIER_NODE, indicating an internal name,
- or if the previous type name was not derived from a source name.
+ set or if the previous type name was not derived from a source name.
We'd rather have the type named with a real name and all the pointer
types to the same object have the same POINTER_TYPE node. Code in the
equivalent function of c-decl.c makes a copy of the type node here, but
{
tree t = TREE_TYPE (decl);
- if (!TYPE_NAME (t) || TREE_CODE (TYPE_NAME (t)) == IDENTIFIER_NODE)
+ if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
;
else if (TYPE_FAT_POINTER_P (t))
{
ptr_void_type_node = build_pointer_type (void_type_node);
}
-
-/* Create the predefined scalar types such as `integer_type_node' needed
- in the gcc back-end and initialize the global binding level. */
+\f
+/* Record TYPE as a builtin type for Ada. NAME is the name of the type. */
void
-init_gigi_decls (tree long_long_float_type, tree exception_type)
+record_builtin_type (const char *name, tree type)
{
- tree endlink, decl;
- tree int64_type = gnat_type_for_size (64, 0);
- unsigned int i;
-
- /* Set the types that GCC and Gigi use from the front end. We would like
- to do this for char_type_node, but it needs to correspond to the C
- char type. */
- if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
- {
- /* In this case, the builtin floating point types are VAX float,
- so make up a type for use. */
- longest_float_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (longest_float_type_node);
- create_type_decl (get_identifier ("longest float type"),
- longest_float_type_node, NULL, false, true, Empty);
- }
- else
- longest_float_type_node = TREE_TYPE (long_long_float_type);
-
- except_type_node = TREE_TYPE (exception_type);
-
- unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
- create_type_decl (get_identifier ("unsigned int"), unsigned_type_node,
- NULL, false, true, Empty);
-
- void_type_decl_node = create_type_decl (get_identifier ("void"),
- void_type_node, NULL, false, true,
- Empty);
-
- void_ftype = build_function_type (void_type_node, NULL_TREE);
- ptr_void_ftype = build_pointer_type (void_ftype);
-
- /* Build the special descriptor type and its null node if needed. */
- if (TARGET_VTABLE_USES_DESCRIPTORS)
- {
- tree 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);
- null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
- }
+ tree type_decl = build_decl (TYPE_DECL, get_identifier (name), type);
- /* Now declare runtime functions. */
- endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
-
- /* malloc is a function declaration tree for a function to allocate
- memory. */
- malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"),
- NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype,
- endlink)),
- NULL_TREE, false, true, true, NULL,
- Empty);
- DECL_IS_MALLOC (malloc_decl) = 1;
-
- /* malloc32 is a function declaration tree for a function to allocate
- 32bit memory on a 64bit system. Needed only on 64bit VMS. */
- malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"),
- NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype,
- endlink)),
- NULL_TREE, false, true, true, NULL,
- Empty);
- DECL_IS_MALLOC (malloc32_decl) = 1;
-
- /* free is a function declaration tree for a function to free memory. */
- free_decl
- = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* 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 (build_int_cst (NULL_TREE, 5)));
- create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
- true, true, Empty);
- jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
-
- /* Functions to get and set the jumpbuf pointer for the current thread. */
- get_jmpbuf_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
- NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
- /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
- DECL_PURE_P (get_jmpbuf_decl) = 1;
-
- set_jmpbuf_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
- NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Function to get the current exception. */
- get_excptr_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__get_gnat_exception"),
- NULL_TREE,
- build_function_type (build_pointer_type (except_type_node), NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
- /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
- DECL_PURE_P (get_excptr_decl) = 1;
-
- /* Functions that raise exceptions. */
- raise_nodefer_decl
- = create_subprog_decl
- (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type (except_type_node),
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Dummy objects to materialize "others" and "all others" in the exception
- tables. These are exported by a-exexpr.adb, so see this unit for the
- types to use. */
-
- others_decl
- = create_var_decl (get_identifier ("OTHERS"),
- get_identifier ("__gnat_others_value"),
- integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
-
- all_others_decl
- = create_var_decl (get_identifier ("ALL_OTHERS"),
- get_identifier ("__gnat_all_others_value"),
- integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
-
- /* Hooks to call when entering/leaving an exception handler. */
- begin_handler_decl
- = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- end_handler_decl
- = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* If in no exception handlers mode, all raise statements are redirected to
- __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
- this procedure will never be called in this mode. */
- if (No_Exception_Handlers_Set ())
- {
- decl
- = create_subprog_decl
- (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type (char_type_node),
- tree_cons (NULL_TREE,
- integer_type_node,
- endlink))),
- NULL_TREE, false, true, true, NULL, Empty);
-
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- gnat_raise_decls[i] = decl;
- }
- else
- /* Otherwise, make one decl for each exception reason. */
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- {
- char name[17];
-
- sprintf (name, "__gnat_rcheck_%.2d", i);
- gnat_raise_decls[i]
- = create_subprog_decl
- (get_identifier (name), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type
- (char_type_node),
- tree_cons (NULL_TREE,
- integer_type_node,
- endlink))),
- NULL_TREE, false, true, true, NULL, Empty);
- }
-
- /* Indicate that these never return. */
- TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
- TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
- TREE_TYPE (raise_nodefer_decl)
- = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
- TYPE_QUAL_VOLATILE);
+ gnat_pushdecl (type_decl, Empty);
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- {
- TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
- TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
- TREE_TYPE (gnat_raise_decls[i])
- = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
- TYPE_QUAL_VOLATILE);
- }
-
- /* setjmp returns an integer and has one operand, which is a pointer to
- a jmpbuf. */
- setjmp_decl
- = create_subprog_decl
- (get_identifier ("__builtin_setjmp"), NULL_TREE,
- build_function_type (integer_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
- DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
-
- /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
- address. */
- update_setjmp_buf_decl
- = create_subprog_decl
- (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
- DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
-
- main_identifier_node = get_identifier ("main");
-
- /* Install the builtins we might need, either internally or as
- user available facilities for Intrinsic imports. */
- gnat_install_builtins ();
+ if (debug_hooks->type_decl)
+ debug_hooks->type_decl (type_decl, false);
}
\f
/* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST,
bool had_align = TYPE_ALIGN (record_type) != 0;
tree field;
- if (name && TREE_CODE (name) == TYPE_DECL)
- name = DECL_NAME (name);
-
TYPE_FIELDS (record_type) = fieldlist;
- TYPE_STUB_DECL (record_type) = build_decl (TYPE_DECL, name, record_type);
- /* We don't need both the typedef name and the record name output in
- the debugging information, since they are the same. */
- DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1;
+ /* Always attach the TYPE_STUB_DECL for a record type. It is required to
+ generate debug info and have a parallel type. */
+ if (name && TREE_CODE (name) == TYPE_DECL)
+ name = DECL_NAME (name);
+ TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type);
/* Globally initialize the record first. If this is a rep'ed record,
that just means some initializations; otherwise, layout the record. */
TYPE_NAME (new_record_type) = new_id;
TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
TYPE_STUB_DECL (new_record_type)
- = build_decl (TYPE_DECL, new_id, new_record_type);
- DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
+ = create_type_stub_decl (new_id, new_record_type);
DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
= DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
return type;
}
\f
-/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
- string) and TYPE is a ..._TYPE node giving its data type.
- ARTIFICIAL_P is true if this is a declaration that was generated
- by the compiler. DEBUG_INFO_P is true if we need to write debugging
- information about this type. GNAT_NODE is used for the position of
- the decl. */
+/* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type.
+ TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving
+ its data type. */
+
+tree
+create_type_stub_decl (tree type_name, tree type)
+{
+ /* Using a named TYPE_DECL ensures that a type name marker is emitted in
+ STABS while setting DECL_ARTIFICIAL ensures that no DW_TAG_typedef is
+ emitted in DWARF. */
+ tree type_decl = build_decl (TYPE_DECL, type_name, type);
+ DECL_ARTIFICIAL (type_decl) = 1;
+ return type_decl;
+}
+
+/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE
+ is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this
+ is a declaration that was generated by the compiler. DEBUG_INFO_P is
+ true if we need to write debug information about this type. GNAT_NODE
+ is used for the position of the decl. */
tree
create_type_decl (tree type_name, tree type, struct attrib *attr_list,
bool artificial_p, bool debug_info_p, Node_Id gnat_node)
{
- tree type_decl = build_decl (TYPE_DECL, type_name, type);
enum tree_code code = TREE_CODE (type);
+ bool named = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL;
+ tree type_decl;
- DECL_ARTIFICIAL (type_decl) = artificial_p;
+ /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */
+ gcc_assert (!TYPE_IS_DUMMY_P (type));
- if (!TYPE_IS_DUMMY_P (type))
- gnat_pushdecl (type_decl, gnat_node);
+ /* If the type hasn't been named yet, we're naming it; preserve an existing
+ TYPE_STUB_DECL that has been attached to it for some purpose. */
+ if (!named && TYPE_STUB_DECL (type))
+ {
+ type_decl = TYPE_STUB_DECL (type);
+ DECL_NAME (type_decl) = type_name;
+ }
+ else
+ type_decl = build_decl (TYPE_DECL, type_name, type);
+ DECL_ARTIFICIAL (type_decl) = artificial_p;
+ gnat_pushdecl (type_decl, gnat_node);
process_attributes (type_decl, attr_list);
- /* Pass type declaration information to the debugger unless this is an
- UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
- and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or
+ /* If we're naming the type, equate the TYPE_STUB_DECL to the name.
+ This causes the name to be also viewed as a "tag" by the debug
+ back-end, with the advantage that no DW_TAG_typedef is emitted
+ for artificial "tagged" types in DWARF. */
+ if (!named)
+ TYPE_STUB_DECL (type) = type_decl;
+
+ /* Pass the type declaration to the debug back-end unless this is an
+ UNCONSTRAINED_ARRAY_TYPE that the back-end does not support, an
+ ENUMERAL_TYPE or RECORD_TYPE which are handled separately, or a
type for which debugging information was not requested. */
if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
DECL_IGNORED_P (type_decl) = 1;
return type_decl;
}
-
+\f
/* Return a VAR_DECL or CONST_DECL node.
VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
gnat_gimplify_function (cgn->decl);
}
-\f
tree
gnat_builtin_function (tree decl)
post_error ("unsupported descriptor type for &", gnat_entity);
}
+ TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC");
finish_record_type (record_type, field_list, 0, true);
- create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
- NULL, true, false, gnat_entity);
-
return record_type;
}
post_error ("unsupported descriptor type for &", gnat_entity);
}
+ TYPE_NAME (record64_type) = create_concat_name (gnat_entity, "DESC64");
finish_record_type (record64_type, field_list64, 0, true);
- create_type_decl (create_concat_name (gnat_entity, "DESC64"), record64_type,
- NULL, true, false, gnat_entity);
-
return record64_type;
}
OSDN Git Service
