From 10069d53fb535c72d70e2c7dab53347d40a89f37 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 7 Apr 2009 09:41:40 +0000 Subject: [PATCH] gigi.h (standard_datatypes): Remove ADT_void_type_decl. * 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) : Use void_type. (gnat_to_gnu_entity) : Make fat and thin pointer types artificial. : 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) : 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. From-SVN: r145660 --- gcc/ada/ChangeLog | 48 ++++ gcc/ada/gcc-interface/decl.c | 84 ++++--- gcc/ada/gcc-interface/gigi.h | 27 ++- gcc/ada/gcc-interface/misc.c | 2 +- gcc/ada/gcc-interface/trans.c | 410 +++++++++++++++++++++++++++------- gcc/ada/gcc-interface/utils.c | 368 ++++++------------------------ 6 files changed, 505 insertions(+), 434 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a957d37b3865..9dbf5a51f91a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2009-04-07 Eric Botcazou + + * 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) : Use void_type. + (gnat_to_gnu_entity) : Make fat and thin pointer types + artificial. + : 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) : 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 * gcc-interface/decl.c (gnat_to_gnu_entity): Reorder local variables. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 9947777bc92c..6cf616e961ba 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -1384,7 +1384,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 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: @@ -2033,7 +2033,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* 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 @@ -2048,9 +2048,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* 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; @@ -2352,6 +2351,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 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. */ @@ -2395,40 +2399,35 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* 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) @@ -2459,25 +2458,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* 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. */ @@ -4195,7 +4197,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 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), @@ -4227,14 +4232,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* 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; } @@ -4790,10 +4791,7 @@ rest_of_type_decl_compilation_no_defer (tree decl) continue; if (!TYPE_STUB_DECL (t)) - { - TYPE_STUB_DECL (t) = build_decl (TYPE_DECL, DECL_NAME (decl), t); - DECL_ARTIFICIAL (TYPE_STUB_DECL (t)) = 1; - } + TYPE_STUB_DECL (t) = create_type_stub_decl (DECL_NAME (decl), t); rest_of_type_compilation (t, toplev); } diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 7b08f8dad4ef..ffd1767c12da 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -6,7 +6,7 @@ * * * 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- * @@ -363,9 +363,8 @@ extern const struct attribute_spec gnat_internal_attribute_table[]; /* Define the entries in the standard data array. */ enum standard_datatypes { -/* Various standard data types and nodes. */ + /* The longest floating-point type. */ ADT_longest_float_type, - ADT_void_type_decl, /* The type of an exception. */ ADT_except_type, @@ -418,7 +417,6 @@ extern GTY(()) tree gnat_std_decls[(int) ADT_LAST]; extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; #define longest_float_type_node gnat_std_decls[(int) ADT_longest_float_type] -#define void_type_decl_node gnat_std_decls[(int) ADT_void_type_decl] #define except_type_node gnat_std_decls[(int) ADT_except_type] #define ptr_void_type_node gnat_std_decls[(int) ADT_ptr_void_type] #define void_ftype gnat_std_decls[(int) ADT_void_ftype] @@ -468,8 +466,8 @@ extern tree get_block_jmpbuf_decl (void); 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 @@ -522,6 +520,9 @@ extern bool present_gnu_tree (Entity_Id gnat_entity); /* 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. @@ -569,12 +570,16 @@ extern tree copy_type (tree type); 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, diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 329f68eebb3b..4dc00fc977f6 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -610,7 +610,7 @@ gnat_printable_name (tree decl, int verbosity) __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); diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 44d335221189..96e7c80f659e 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -213,12 +213,12 @@ static void elaborate_all_entities (Node_Id); static void process_freeze_entity (Node_Id); static void process_inlined_subprograms (Node_Id); static void process_decls (List_Id, List_Id, Node_Id, bool, bool); -static tree emit_range_check (tree, Node_Id); -static tree emit_index_check (tree, tree, tree, tree); -static tree emit_check (tree, tree, int); -static tree 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); @@ -249,7 +249,8 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name, 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; @@ -321,17 +322,20 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name, 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), @@ -353,11 +357,249 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name, 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 @@ -365,13 +607,6 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name, 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))) @@ -873,7 +1108,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) 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; @@ -894,7 +1129,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) 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 @@ -2343,13 +2578,15 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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. @@ -2636,7 +2873,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) (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); @@ -2653,8 +2890,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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))))) @@ -3434,7 +3672,8 @@ gnat_to_gnu (Node_Id 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 @@ -3569,7 +3808,8 @@ gnat_to_gnu (Node_Id gnat_node) = 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); @@ -3633,7 +3873,7 @@ gnat_to_gnu (Node_Id gnat_node) 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), @@ -3813,7 +4053,7 @@ gnat_to_gnu (Node_Id gnat_node) 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: @@ -4028,8 +4268,8 @@ gnat_to_gnu (Node_Id gnat_node) || 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); @@ -4099,8 +4339,9 @@ gnat_to_gnu (Node_Id 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[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); @@ -4131,7 +4372,8 @@ gnat_to_gnu (Node_Id gnat_node) 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)) @@ -4196,7 +4438,8 @@ gnat_to_gnu (Node_Id gnat_node) /* If range check is needed, emit code to generate it. */ if (Do_Range_Check (Expression (gnat_node))) - gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node))); + gnu_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); @@ -6002,10 +6245,13 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, /* 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); @@ -6014,17 +6260,19 @@ build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand) 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); @@ -6098,7 +6346,8 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, 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) @@ -6119,7 +6368,8 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, 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); } } @@ -6191,15 +6441,16 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, 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); @@ -6238,7 +6489,7 @@ emit_range_check (tree gnu_expr, Entity_Id gnat_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); } /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which @@ -6250,11 +6501,12 @@ emit_range_check (tree gnu_expr, Entity_Id gnat_range_type) 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; @@ -6282,18 +6534,21 @@ emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low, 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); } /* 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, @@ -6313,11 +6568,13 @@ emit_check (tree gnu_cond, tree gnu_expr, int reason) /* 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); @@ -6408,8 +6665,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, 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 @@ -6484,7 +6741,7 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, 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); } @@ -6685,10 +6942,7 @@ process_type (Entity_Id 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))) @@ -6781,7 +7035,7 @@ assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type) /* 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); @@ -6823,7 +7077,6 @@ pos_to_constructor (Node_Id gnat_expr, tree 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))) @@ -6834,10 +7087,10 @@ pos_to_constructor (Node_Id gnat_expr, tree 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 @@ -7183,8 +7436,7 @@ Sloc_to_locus (Source_Ptr Sloc, location_t *locus) if (Sloc <= Standard_Location) { - if (*locus == UNKNOWN_LOCATION) - *locus = BUILTINS_LOCATION; + *locus = BUILTINS_LOCATION; return false; } else diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index bbf51969e844..78080b1909c4 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -6,7 +6,7 @@ * * * 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- * @@ -188,7 +188,6 @@ static GTY(()) VEC(tree,gc) *global_renaming_pointers; /* A chain of unused BLOCK nodes. */ static GTY((deletable)) tree free_block_chain; -static void gnat_install_builtins (void); static tree merge_sizes (tree, tree, tree, bool, bool); static tree compute_related_constant (tree, tree); static tree split_plus (tree, tree *); @@ -287,11 +286,10 @@ make_dummy_type (Entity_Id gnat_type) : 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); @@ -465,8 +463,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) } /* 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 @@ -478,7 +475,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) { 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)) { @@ -534,271 +531,18 @@ gnat_init_decl_processing (void) 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. */ + +/* 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; + tree type_decl = build_decl (TYPE_DECL, get_identifier (name), type); - /* 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); + gnat_pushdecl (type_decl, Empty); - 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); - } - - /* 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); - - 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); } /* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST, @@ -824,15 +568,13 @@ finish_record_type (tree record_type, tree fieldlist, int rep_level, bool had_align = TYPE_ALIGN (record_type) != 0; tree field; + TYPE_FIELDS (record_type) = fieldlist; + + /* 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_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; + 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. */ @@ -1075,8 +817,7 @@ rest_of_record_type_compilation (tree record_type) 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)); @@ -1448,30 +1189,62 @@ create_index_type (tree min, tree max, tree index, Node_Id gnat_node) return type; } -/* 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; + + /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */ + gcc_assert (!TYPE_IS_DUMMY_P (type)); + + /* 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; - - if (!TYPE_IS_DUMMY_P (type)) - gnat_pushdecl (type_decl, gnat_node); - + 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; @@ -1483,7 +1256,7 @@ create_type_decl (tree type_name, tree type, struct attrib *attr_list, return type_decl; } - + /* Return a VAR_DECL or CONST_DECL node. VAR_NAME gives the name of the variable. ASM_NAME is its assembler name @@ -2297,7 +2070,6 @@ gnat_gimplify_function (tree fndecl) for (cgn = cgn->nested; cgn; cgn = cgn->next_nested) gnat_gimplify_function (cgn->decl); } - tree gnat_builtin_function (tree decl) @@ -2966,10 +2738,8 @@ build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity) 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; } @@ -3282,10 +3052,8 @@ build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) 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; }