From f62ed60b214f15bdb21842816457e0a6ad09c056 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 20 Jul 2004 10:26:51 +0000 Subject: 2004-07-20 Olivier Hainque * a-elchha.adb (Last_Chance_Handler): Remove the bogus buffer dynamic allocation and potentially overflowing update with Tailored_Exception_Information. Use the sec-stack free procedural interface to output Exception_Information instead. * a-except.adb (To_Stderr): New subprogram for character, and string version moved from a-exextr to be visible from other separate units. (Tailored_Exception_Information): Remove the procedural version, previously used by the default Last_Chance_Handler and not any more. Adjust various comments. * a-exexda.adb: Generalize the exception information procedural interface, to minimize the use of secondary stack and the need for local buffers when the info is to be output to stderr: (Address_Image): Removed. (Append_Info_Character): New subprogram, checking for overflows and outputing to stderr if buffer to fill is of length 0. (Append_Info_String): Output to stderr if buffer to fill is of length 0. (Append_Info_Address, Append_Info_Exception_Name, Append_Info_Exception_Message, Append_Info_Basic_Exception_Information, Append_Info_Basic_Exception_Traceback, Append_Info_Exception_Information): New subprograms. (Append_Info_Nat, Append_Info_NL): Use Append_Info_Character. (Basic_Exception_Info_Maxlength, Basic_Exception_Tback_Maxlength, Exception_Info_Maxlength, Exception_Name_Length, Exception_Message_Length): New subprograms. (Exception_Information): Use Append_Info_Exception_Information. (Tailored_Exception_Information): Use Append_Info_Basic_Exception_Information. Export services for the default Last_Chance_Handler. * a-exextr.adb (To_Stderr): Remove. Now in a-except to be usable by other separate units. 2004-07-20 Vincent Celier * clean.adb, mlib-utl.adb, osint.adb, makegpr.adb: Minor reformatting. 2004-07-20 Ed Schonberg * freeze.adb (Freeze_Entity): If entity is a discriminated record type, emit itype references for the designated types of component types that are declared outside of the full record declaration, and that may denote a partial view of that record type. 2004-07-20 Ed Schonberg PR ada/15607 * sem_ch3.adb (Build_Discriminated_Subtype): Do not attach a subtype which is the designated type in an access component declaration, to the list of incomplete dependents of the parent type, to avoid elaboration issues with out-of-scope subtypes. (Complete_Private_Subtype): Recompute Has_Unknown_Discriminants from the full view of the parent. 2004-07-20 Ed Schonberg PR ada/15610 * sem_ch8.adb (Find_Expanded_Name): If name is overloaded, reject entities that are hidden, such as references to generic actuals outside an instance. 2004-07-20 Javier Miranda * sem_ch4.adb (Try_Object_Operation): New subprogram that gives support to the new notation. (Analyze_Selected_Component): Add call to Try_Object_Operation. 2004-07-20 Jose Ruiz * s-taprob.adb: Adding the elaboration code required for initializing the tasking soft links that are common to the full and the restricted run times. * s-tarest.adb (Init_RTS): Tasking soft links that are shared with the restricted run time has been moved to the package System.Soft_Links.Tasking. * s-tasini.adb (Init_RTS): Tasking soft links that are shared with the restricted run time has been moved to the package System.Soft_Links.Tasking. * Makefile.rtl: Add entry for s-solita.o in run-time library list. * s-solita.ads, s-solita.adb: New files. 2004-07-20 Richard Kenner * trans.c (Identifier_to_gnu, Pragma_to_gnu, Attribute_to_gnu, Case_Statement_to_gnu): Split off from gnat_to_gnu. (Loop_Statement_to_gnu, Subprogram_Body_to_gnu, call_to_gnu, Handled_Sequence_Of_Statements_to_gnu, Exception_Handler_to_gnu_sjlj, Exception_Handler_to_gnu_zcx): Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@84948 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/trans.c | 4229 +++++++++++++++++++++++++++---------------------------- 1 file changed, 2108 insertions(+), 2121 deletions(-) (limited to 'gcc/ada/trans.c') diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 903b314477a..6b7a174c369 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -297,6 +297,2036 @@ gnat_init_stmt_group () REAL_ARITHMETIC (dconstmp5, RDIV_EXPR, dconstm1, dconst2); } +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to + where we should place the result type. */ + +static tree +Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) +{ + tree gnu_result_type; + tree gnu_result; + Node_Id gnat_temp, gnat_temp_type; + + /* If the Etype of this node does not equal the Etype of the Entity, + something is wrong with the entity map, probably in generic + instantiation. However, this does not apply to types. Since we sometime + have strange Ekind's, just do this test for objects. Also, if the Etype of + the Entity is private, the Etype of the N_Identifier is allowed to be the + full type and also we consider a packed array type to be the same as the + original type. Similarly, a class-wide type is equivalent to a subtype of + itself. Finally, if the types are Itypes, one may be a copy of the other, + which is also legal. */ + gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier + ? gnat_node : Entity (gnat_node)); + gnat_temp_type = Etype (gnat_temp); + + if (Etype (gnat_node) != gnat_temp_type + && ! (Is_Packed (gnat_temp_type) + && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type)) + && ! (Is_Class_Wide_Type (Etype (gnat_node))) + && ! (IN (Ekind (gnat_temp_type), Private_Kind) + && Present (Full_View (gnat_temp_type)) + && ((Etype (gnat_node) == Full_View (gnat_temp_type)) + || (Is_Packed (Full_View (gnat_temp_type)) + && (Etype (gnat_node) + == Packed_Array_Type (Full_View (gnat_temp_type)))))) + && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (gnat_temp_type)) + && (Ekind (gnat_temp) == E_Variable + || Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Loop_Parameter + || IN (Ekind (gnat_temp), Formal_Kind))) + gigi_abort (304); + + /* If this is a reference to a deferred constant whose partial view is an + unconstrained private type, the proper type is on the full view of the + constant, not on the full view of the type, which may be unconstrained. + + This may be a reference to a type, for example in the prefix of the + attribute Position, generated for dispatching code (see Make_DT in + exp_disp,adb). In that case we need the type itself, not is parent, + in particular if it is a derived type */ + if (Is_Private_Type (gnat_temp_type) + && Has_Unknown_Discriminants (gnat_temp_type) + && Present (Full_View (gnat_temp)) + && ! Is_Type (gnat_temp)) + { + gnat_temp = Full_View (gnat_temp); + gnat_temp_type = Etype (gnat_temp); + gnu_result_type = get_unpadded_type (gnat_temp_type); + } + else + { + /* Expand the type of this identitier first, in case it is an enumeral + literal, which only get made when the type is expanded. There is no + order-of-elaboration issue here. We want to use the Actual_Subtype if + it has already been elaborated, otherwise the Etype. Avoid using + Actual_Subtype for packed arrays to simplify things. */ + if ((Ekind (gnat_temp) == E_Constant + || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) + && ! (Is_Array_Type (Etype (gnat_temp)) + && Present (Packed_Array_Type (Etype (gnat_temp)))) + && Present (Actual_Subtype (gnat_temp)) + && present_gnu_tree (Actual_Subtype (gnat_temp))) + gnat_temp_type = Actual_Subtype (gnat_temp); + else + gnat_temp_type = Etype (gnat_node); + + gnu_result_type = get_unpadded_type (gnat_temp_type); + } + + gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); + + /* If we are in an exception handler, force this variable into memory to + ensure optimization does not remove stores that appear redundant but are + actually needed in case an exception occurs. + + ??? Note that we need not do this if the variable is declared within the + handler, only if it is referenced in the handler and declared in an + enclosing block, but we have no way of testing that right now. + + ??? Also, for now all we can do is make it volatile. But we only + do this for SJLJ. */ + if (TREE_VALUE (gnu_except_ptr_stack) != 0 + && TREE_CODE (gnu_result) == VAR_DECL) + TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; + + /* Some objects (such as parameters passed by reference, globals of + variable size, and renamed objects) actually represent the address + of the object. In that case, we must do the dereference. Likewise, + deal with parameters to foreign convention subprograms. Call fold + here since GNU_RESULT may be a CONST_DECL. */ + if (DECL_P (gnu_result) + && (DECL_BY_REF_P (gnu_result) + || (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)))) + { + int ro = DECL_POINTS_TO_READONLY_P (gnu_result); + tree initial; + + if (TREE_CODE (gnu_result) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (gnu_result)) + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + gnu_result)); + + /* If the object is constant, we try to do the dereference directly + through the DECL_INITIAL. This is actually required in order to get + correct aliasing information for renamed objects that are components + of non-aliased aggregates, because the type of the renamed object and + that of the aggregate don't alias. + + Note that we expect the initial value to have been stabilized. + If it contains e.g. a variable reference, we certainly don't want + to re-evaluate the variable each time the renaming is used. + + Stabilization is currently not performed at the global level but + create_var_decl avoids setting DECL_INITIAL if the value is not + constant then, and we get to the pointer dereference below. + + ??? Couldn't the aliasing issue show up again in this case ? + There is no obvious reason why not. */ + else if (TREE_READONLY (gnu_result) + && DECL_INITIAL (gnu_result) + /* Strip possible conversion to reference type. */ + && ((initial = TREE_CODE (DECL_INITIAL (gnu_result)) + == NOP_EXPR + ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0) + : DECL_INITIAL (gnu_result), 1)) + && TREE_CODE (initial) == ADDR_EXPR + && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF + || (TREE_CODE (TREE_OPERAND (initial, 0)) + == COMPONENT_REF))) + gnu_result = TREE_OPERAND (initial, 0); + else + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, + fold (gnu_result)); + + TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro; + } + + /* The GNAT tree has the type of a function as the type of its result. Also + use the type of the result if the Etype is a subtype which is nominally + unconstrained. But remove any padding from the resulting type. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE + || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) + { + gnu_result_type = TREE_TYPE (gnu_result); + if (TREE_CODE (gnu_result_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_result_type)) + gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); + } + + /* We always want to return the underlying INTEGER_CST for an enumeration + literal to avoid the need to call fold in lots of places. But don't do + this is the parent will be taking the address of this object. */ + if (TREE_CODE (gnu_result) == CONST_DECL) + { + gnat_temp = Parent (gnat_node); + if (DECL_CONST_CORRESPONDING_VAR (gnu_result) == 0 + || (Nkind (gnat_temp) != N_Reference + && ! (Nkind (gnat_temp) == N_Attribute_Reference + && ((Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Address) + || (Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Access) + || (Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Unchecked_Access) + || (Get_Attribute_Id (Attribute_Name (gnat_temp)) + == Attr_Unrestricted_Access))))) + gnu_result = DECL_INITIAL (gnu_result); + } + + *gnu_result_type_p = gnu_result_type; + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. We don't + return anything. */ + +static void +Pragma_to_gnu (Node_Id gnat_node) +{ + Node_Id gnat_temp; + + /* Check for (and ignore) unrecognized pragma and do nothing if we are just + annotating types. */ + if (type_annotate_only + || ! Is_Pragma_Name (Chars (gnat_node))) + return; + + switch (Get_Pragma_Id (Chars (gnat_node))) + { + case Pragma_Inspection_Point: + /* Do nothing at top level: all such variables are already viewable. */ + if (global_bindings_p ()) + break; + + for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) + { + tree gnu_expr = gnat_to_gnu (Expression (gnat_temp)); + + if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) + gnu_expr = TREE_OPERAND (gnu_expr, 0); + + gnu_expr = build1 (USE_STMT, void_type_node, gnu_expr); + add_stmt (gnu_expr); + } + break; + + case Pragma_Optimize: + switch (Chars (Expression + (First (Pragma_Argument_Associations (gnat_node))))) + { + case Name_Time: case Name_Space: + if (optimize == 0) + post_error ("insufficient -O value?", gnat_node); + break; + + case Name_Off: + if (optimize != 0) + post_error ("must specify -O0?", gnat_node); + break; + + default: + gigi_abort (331); + break; + } + break; + + case Pragma_Reviewable: + if (write_symbols == NO_DEBUG) + post_error ("must specify -g?", gnat_node); + break; + } +} +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute, + to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to + where we should place the result type. ATTRIBUTE is the attribute ID. */ + +static tree +Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) +{ + tree gnu_result = error_mark_node; + tree gnu_result_type; + tree gnu_expr; + bool prefix_unused = false; + tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + tree gnu_type = TREE_TYPE (gnu_prefix); + + /* If the input is a NULL_EXPR, make a new one. */ + if (TREE_CODE (gnu_prefix) == NULL_EXPR) + { + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + return build1 (NULL_EXPR, *gnu_result_type_p, + TREE_OPERAND (gnu_prefix, 0)); + } + + switch (attribute) + { + case Attr_Pos: + case Attr_Val: + /* These are just conversions until since representation clauses for + enumerations are handled in the front end. */ + { + int check_p = Do_Range_Check (First (Expressions (gnat_node))); + + gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = convert_with_check (Etype (gnat_node), gnu_result, + check_p, check_p, 1); + } + break; + + case Attr_Pred: + case Attr_Succ: + /* These just add or subject the constant 1. Representation clauses for + enumerations are handled in the front-end. */ + gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (Do_Range_Check (First (Expressions (gnat_node)))) + { + gnu_expr = protect_multiple_eval (gnu_expr); + gnu_expr + = emit_check + (build_binary_op (EQ_EXPR, integer_type_node, + gnu_expr, + attribute == Attr_Pred + ? TYPE_MIN_VALUE (gnu_result_type) + : TYPE_MAX_VALUE (gnu_result_type)), + gnu_expr, CE_Range_Check_Failed); + } + + gnu_result + = build_binary_op (attribute == Attr_Pred + ? MINUS_EXPR : PLUS_EXPR, + gnu_result_type, gnu_expr, + convert (gnu_result_type, integer_one_node)); + break; + + case Attr_Address: + case Attr_Unrestricted_Access: + /* Conversions don't change something's address but can cause us to miss + the COMPONENT_REF case below, so strip them off. */ + gnu_prefix = remove_conversions (gnu_prefix, + ! Must_Be_Byte_Aligned (gnat_node)); + + /* If we are taking 'Address of an unconstrained object, this is the + pointer to the underlying array. */ + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + + /* ... fall through ... */ + + case Attr_Access: + case Attr_Unchecked_Access: + case Attr_Code_Address: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (((attribute == Attr_Address + || attribute == Attr_Unrestricted_Access) + && ! Must_Be_Byte_Aligned (gnat_node)) + ? ATTR_ADDR_EXPR : ADDR_EXPR, + gnu_result_type, gnu_prefix); + + /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we + don't try to build a trampoline. */ + if (attribute == Attr_Code_Address) + { + for (gnu_expr = gnu_result; + TREE_CODE (gnu_expr) == NOP_EXPR + || TREE_CODE (gnu_expr) == CONVERT_EXPR; + gnu_expr = TREE_OPERAND (gnu_expr, 0)) + TREE_CONSTANT (gnu_expr) = 1; + + if (TREE_CODE (gnu_expr) == ADDR_EXPR) + TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; + } + break; + + case Attr_Pool_Address: + { + tree gnu_obj_type; + tree gnu_ptr = gnu_prefix; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* If this is an unconstrained array, we know the object must have been + allocated with the template in front of the object. So compute the + template address.*/ + if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr + = convert (build_pointer_type + (TYPE_OBJECT_RECORD_TYPE + (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), + gnu_ptr); + + gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); + if (TREE_CODE (gnu_obj_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) + { + tree gnu_char_ptr_type = build_pointer_type (char_type_node); + tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); + tree gnu_byte_offset + = convert (gnu_char_ptr_type, + size_diffop (size_zero_node, gnu_pos)); + + gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); + gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type, + gnu_ptr, gnu_byte_offset); + } + + gnu_result = convert (gnu_result_type, gnu_ptr); + } + break; + + case Attr_Size: + case Attr_Object_Size: + case Attr_Value_Size: + case Attr_Max_Size_In_Storage_Elements: + gnu_expr = gnu_prefix; + + /* Remove NOPS from gnu_expr and conversions from gnu_prefix. + We only use GNU_EXPR to see if a COMPONENT_REF was involved. */ + while (TREE_CODE (gnu_expr) == NOP_EXPR) + gnu_expr = TREE_OPERAND (gnu_expr, 0) + ; + + gnu_prefix = remove_conversions (gnu_prefix, 1); + prefix_unused = true; + gnu_type = TREE_TYPE (gnu_prefix); + + /* Replace an unconstrained array type with the type of the underlying + array. We can't do this with a call to maybe_unconstrained_array + since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements, + use the record type that will be used to allocate the object and its + template. */ + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + { + gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); + if (attribute != Attr_Max_Size_In_Storage_Elements) + gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); + } + + /* If we're looking for the size of a field, return the field size. + Otherwise, if the prefix is an object, or if 'Object_Size or + 'Max_Size_In_Storage_Elements has been specified, the result is the + GCC size of the type. Otherwise, the result is the RM_Size of the + type. */ + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); + else if (TREE_CODE (gnu_prefix) != TYPE_DECL + || attribute == Attr_Object_Size + || attribute == Attr_Max_Size_In_Storage_Elements) + { + /* If this is a padded type, the GCC size isn't relevant to the + programmer. Normally, what we want is the RM_Size, which was set + from the specified size, but if it was not set, we want the size + of the relevant field. Using the MAX of those two produces the + right result in all case. Don't use the size of the field if it's + a self-referential type, since that's never what's wanted. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_type) + && TREE_CODE (gnu_expr) == COMPONENT_REF) + { + gnu_result = rm_size (gnu_type); + if (! (CONTAINS_PLACEHOLDER_P + (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))) + gnu_result + = size_binop (MAX_EXPR, gnu_result, + DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); + } + else + gnu_result = TYPE_SIZE (gnu_type); + } + else + gnu_result = rm_size (gnu_type); + + if (gnu_result == 0) + gigi_abort (325); + + /* Deal with a self-referential size by returning the maximum size for a + type and by qualifying the size with the object for 'Size of an + object. */ + if (CONTAINS_PLACEHOLDER_P (gnu_result)) + { + if (TREE_CODE (gnu_prefix) != TYPE_DECL) + gnu_result = substitute_placeholder_in_expr (gnu_result, + gnu_expr); + else + gnu_result = max_size (gnu_result, 1); + } + + /* If the type contains a template, subtract its size. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) + gnu_result = size_binop (MINUS_EXPR, gnu_result, + DECL_SIZE (TYPE_FIELDS (gnu_type))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + /* Always perform division using unsigned arithmetic as the size cannot + be negative, but may be an overflowed positive value. This provides + correct results for sizes up to 512 MB. + + ??? Size should be calculated in storage elements directly. */ + + if (attribute == Attr_Max_Size_In_Storage_Elements) + gnu_result = convert (sizetype, + fold (build (CEIL_DIV_EXPR, bitsizetype, + gnu_result, bitsize_unit_node))); + break; + + case Attr_Alignment: + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_type = TREE_TYPE (gnu_prefix); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + gnu_result = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))); + else + gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT); + break; + + case Attr_First: + case Attr_Last: + case Attr_Range_Length: + prefix_unused = true; + + if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE) + { + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (attribute == Attr_First) + gnu_result = TYPE_MIN_VALUE (gnu_type); + else if (attribute == Attr_Last) + gnu_result = TYPE_MAX_VALUE (gnu_type); + else + gnu_result + = build_binary_op + (MAX_EXPR, get_base_type (gnu_result_type), + build_binary_op + (PLUS_EXPR, get_base_type (gnu_result_type), + build_binary_op (MINUS_EXPR, + get_base_type (gnu_result_type), + convert (gnu_result_type, + TYPE_MAX_VALUE (gnu_type)), + convert (gnu_result_type, + TYPE_MIN_VALUE (gnu_type))), + convert (gnu_result_type, integer_one_node)), + convert (gnu_result_type, integer_zero_node)); + + break; + } + + /* ... fall through ... */ + + case Attr_Length: + { + int Dimension = (Present (Expressions (gnat_node)) + ? UI_To_Int (Intval (First (Expressions (gnat_node)))) + : 1); + + /* Make sure any implicit dereference gets done. */ + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_prefix = maybe_unconstrained_array (gnu_prefix); + gnu_type = TREE_TYPE (gnu_prefix); + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + + if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) + { + int ndim; + tree gnu_type_temp; + + for (ndim = 1, gnu_type_temp = gnu_type; + TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); + ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) + ; + + Dimension = ndim + 1 - Dimension; + } + + for (; Dimension > 1; Dimension--) + gnu_type = TREE_TYPE (gnu_type); + + if (TREE_CODE (gnu_type) != ARRAY_TYPE) + gigi_abort (309); + + if (attribute == Attr_First) + gnu_result + = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + else if (attribute == Attr_Last) + gnu_result + = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); + else + /* 'Length or 'Range_Length. */ + { + tree gnu_compute_type + = gnat_signed_or_unsigned_type (0, + get_base_type (gnu_result_type)); + + gnu_result + = build_binary_op + (MAX_EXPR, gnu_compute_type, + build_binary_op + (PLUS_EXPR, gnu_compute_type, + build_binary_op + (MINUS_EXPR, gnu_compute_type, + convert (gnu_compute_type, + TYPE_MAX_VALUE + (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))), + convert (gnu_compute_type, + TYPE_MIN_VALUE + (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))), + convert (gnu_compute_type, integer_one_node)), + convert (gnu_compute_type, integer_zero_node)); + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are + handling. Note that these attributes could not have been used on + an unconstrained array type. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, + gnu_prefix); + break; + } + + case Attr_Bit_Position: + case Attr_Position: + case Attr_First_Bit: + case Attr_Last_Bit: + case Attr_Bit: + { + HOST_WIDE_INT bitsize; + HOST_WIDE_INT bitpos; + tree gnu_offset; + tree gnu_field_bitpos; + tree gnu_field_offset; + tree gnu_inner; + enum machine_mode mode; + int unsignedp, volatilep; + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_prefix = remove_conversions (gnu_prefix, 1); + prefix_unused = true; + + /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF, + the result is 0. Don't allow 'Bit on a bare component, though. */ + if (attribute == Attr_Bit + && TREE_CODE (gnu_prefix) != COMPONENT_REF + && TREE_CODE (gnu_prefix) != FIELD_DECL) + { + gnu_result = integer_zero_node; + break; + } + + else if (TREE_CODE (gnu_prefix) != COMPONENT_REF + && ! (attribute == Attr_Bit_Position + && TREE_CODE (gnu_prefix) == FIELD_DECL)) + gigi_abort (310); + + get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, + &mode, &unsignedp, &volatilep); + + if (TREE_CODE (gnu_prefix) == COMPONENT_REF) + { + gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1)); + gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1)); + + for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); + TREE_CODE (gnu_inner) == COMPONENT_REF + && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); + gnu_inner = TREE_OPERAND (gnu_inner, 0)) + { + gnu_field_bitpos + = size_binop (PLUS_EXPR, gnu_field_bitpos, + bit_position (TREE_OPERAND (gnu_inner, 1))); + gnu_field_offset + = size_binop (PLUS_EXPR, gnu_field_offset, + byte_position (TREE_OPERAND (gnu_inner, 1))); + } + } + else if (TREE_CODE (gnu_prefix) == FIELD_DECL) + { + gnu_field_bitpos = bit_position (gnu_prefix); + gnu_field_offset = byte_position (gnu_prefix); + } + else + { + gnu_field_bitpos = bitsize_zero_node; + gnu_field_offset = size_zero_node; + } + + switch (attribute) + { + case Attr_Position: + gnu_result = gnu_field_offset; + break; + + case Attr_First_Bit: + case Attr_Bit: + gnu_result = size_int (bitpos % BITS_PER_UNIT); + break; + + case Attr_Last_Bit: + gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); + gnu_result = size_binop (PLUS_EXPR, gnu_result, + TYPE_SIZE (TREE_TYPE (gnu_prefix))); + gnu_result = size_binop (MINUS_EXPR, gnu_result, + bitsize_one_node); + break; + + case Attr_Bit_Position: + gnu_result = gnu_field_bitpos; + break; + } + + /* If this has a PLACEHOLDER_EXPR, qualify it by the object + we are handling. */ + gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); + break; + } + + case Attr_Min: + case Attr_Max: + { + tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); + tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); + + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = build_binary_op (attribute == Attr_Min + ? MIN_EXPR : MAX_EXPR, + gnu_result_type, gnu_lhs, gnu_rhs); + } + break; + + case Attr_Passed_By_Reference: + gnu_result = size_int (default_pass_by_ref (gnu_type) + || must_pass_by_ref (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + break; + + case Attr_Component_Size: + if (TREE_CODE (gnu_prefix) == COMPONENT_REF + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) + gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + + gnu_prefix = maybe_implicit_deref (gnu_prefix); + gnu_type = TREE_TYPE (gnu_prefix); + + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) + gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); + + while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE + && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) + gnu_type = TREE_TYPE (gnu_type); + + if (TREE_CODE (gnu_type) != ARRAY_TYPE) + gigi_abort (330); + + /* Note this size cannot be self-referential. */ + gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + prefix_unused = true; + break; + + case Attr_Null_Parameter: + /* This is just a zero cast to the pointer type for + our prefix and dereferenced. */ + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result + = build_unary_op (INDIRECT_REF, NULL_TREE, + convert (build_pointer_type (gnu_result_type), + integer_zero_node)); + TREE_PRIVATE (gnu_result) = 1; + break; + + case Attr_Mechanism_Code: + { + int code; + Entity_Id gnat_obj = Entity (Prefix (gnat_node)); + + prefix_unused = true; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + if (Present (Expressions (gnat_node))) + { + int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); + + for (gnat_obj = First_Formal (gnat_obj); i > 1; + i--, gnat_obj = Next_Formal (gnat_obj)) + ; + } + + code = Mechanism (gnat_obj); + if (code == Default) + code = ((present_gnu_tree (gnat_obj) + && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) + || ((TREE_CODE (get_gnu_tree (gnat_obj)) + == PARM_DECL) + && (DECL_BY_COMPONENT_PTR_P + (get_gnu_tree (gnat_obj)))))) + ? By_Reference : By_Copy); + gnu_result = convert (gnu_result_type, size_int (- code)); + } + break; + + default: + /* Say we have an unimplemented attribute. Then set the value to be + returned to be a zero and hope that's something we can convert to the + type of this attribute. */ + post_error ("unimplemented attribute", gnat_node); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = integer_zero_node; + break; + } + + /* If this is an attribute where the prefix was unused, force a use of it if + it has a side-effect. But don't do it if the prefix is just an entity + name. However, if an access check is needed, we must do it. See second + example in AARM 11.6(5.e). */ + if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) + && ! Is_Entity_Name (Prefix (gnat_node))) + gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result), + gnu_prefix, gnu_result)); + + *gnu_result_type_p = gnu_result_type; + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement, + to a GCC tree, which is returned. */ + +static tree +Case_Statement_to_gnu (Node_Id gnat_node) +{ + tree gnu_result; + tree gnu_expr; + Node_Id gnat_when; + + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* The range of values in a case statement is determined by the rules in + RM 5.4(7-9). In almost all cases, this range is represented by the Etype + of the expression. One exception arises in the case of a simple name that + is parenthesized. This still has the Etype of the name, but since it is + not a name, para 7 does not apply, and we need to go to the base type. + This is the only case where parenthesization affects the dynamic + semantics (i.e. the range of possible values at runtime that is covered + by the others alternative. + + Another exception is if the subtype of the expression is non-static. In + that case, we also have to use the base type. */ + if (Paren_Count (Expression (gnat_node)) != 0 + || !Is_OK_Static_Subtype (Underlying_Type + (Etype (Expression (gnat_node))))) + gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); + + /* We build a SWITCH_EXPR that contains the code with interspersed + CASE_LABEL_EXPRs for each label. */ + + push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ()); + start_stmt_group (); + for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); + Present (gnat_when); + gnat_when = Next_Non_Pragma (gnat_when)) + { + Node_Id gnat_choice; + + /* First compile all the different case choices for the current WHEN + alternative. */ + for (gnat_choice = First (Discrete_Choices (gnat_when)); + Present (gnat_choice); gnat_choice = Next (gnat_choice)) + { + tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + + switch (Nkind (gnat_choice)) + { + case N_Range: + gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); + gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); + break; + + case N_Subtype_Indication: + gnu_low = gnat_to_gnu (Low_Bound (Range_Expression + (Constraint (gnat_choice)))); + gnu_high = gnat_to_gnu (High_Bound (Range_Expression + (Constraint (gnat_choice)))); + break; + + case N_Identifier: + case N_Expanded_Name: + /* This represents either a subtype range or a static value of + some kind; Ekind says which. If a static value, fall through + to the next case. */ + if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) + { + tree gnu_type = get_unpadded_type (Entity (gnat_choice)); + + gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); + gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); + break; + } + + /* ... fall through ... */ + + case N_Character_Literal: + case N_Integer_Literal: + gnu_low = gnat_to_gnu (gnat_choice); + break; + + case N_Others_Choice: + break; + + default: + gigi_abort (316); + } + + add_stmt_with_node (build (CASE_LABEL_EXPR, void_type_node, + gnu_low, gnu_high, + create_artificial_label ()), + gnat_choice); + } + + /* Push a binding level here in case variables are declared since we want + them to be local to this set of statements instead of the block + containing the Case statement. */ + add_stmt (build_stmt_group (Statements (gnat_when), true)); + add_stmt (build1 (GOTO_EXPR, void_type_node, + TREE_VALUE (gnu_switch_label_stack))); + } + + /* Now emit a definition of the label all the cases branched to. */ + add_stmt (build1 (LABEL_EXPR, void_type_node, + TREE_VALUE (gnu_switch_label_stack))); + gnu_result = build (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, + end_stmt_group (), NULL_TREE); + pop_stack (&gnu_switch_label_stack); + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, + to a GCC tree, which is returned. */ + +static tree +Loop_Statement_to_gnu (Node_Id gnat_node) +{ + /* ??? It would be nice to use "build" here, but there's no build5. */ + tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + tree gnu_loop_var = NULL_TREE; + Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); + tree gnu_cond_expr = NULL_TREE; + tree gnu_result; + + TREE_TYPE (gnu_loop_stmt) = void_type_node; + TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; + LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (); + annotate_with_node (gnu_loop_stmt, gnat_node); + + /* Save the end label of this LOOP_STMT in a stack so that the corresponding + N_Exit_Statement can find it. */ + push_stack (&gnu_loop_label_stack, NULL_TREE, + LOOP_STMT_LABEL (gnu_loop_stmt)); + + /* Set the condition that under which the loop should continue. + For "LOOP .... END LOOP;" the condition is always true. */ + if (No (gnat_iter_scheme)) + ; + /* The case "WHILE condition LOOP ..... END LOOP;" */ + else if (Present (Condition (gnat_iter_scheme))) + LOOP_STMT_TOP_COND (gnu_loop_stmt) + = gnat_to_gnu (Condition (gnat_iter_scheme)); + else + { + /* We have an iteration scheme. */ + Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme); + Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); + Entity_Id gnat_type = Etype (gnat_loop_var); + tree gnu_type = get_unpadded_type (gnat_type); + tree gnu_low = TYPE_MIN_VALUE (gnu_type); + tree gnu_high = TYPE_MAX_VALUE (gnu_type); + bool reversep = Reverse_Present (gnat_loop_spec); + tree gnu_first = reversep ? gnu_high : gnu_low; + tree gnu_last = reversep ? gnu_low : gnu_high; + enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR; + tree gnu_base_type = get_base_type (gnu_type); + tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type) + : TYPE_MAX_VALUE (gnu_base_type)); + + /* We know the loop variable will not overflow if GNU_LAST is a constant + and is not equal to GNU_LIMIT. If it might overflow, we have to move + the limit test to the end of the loop. In that case, we have to test + for an empty loop outside the loop. */ + if (TREE_CODE (gnu_last) != INTEGER_CST + || TREE_CODE (gnu_limit) != INTEGER_CST + || tree_int_cst_equal (gnu_last, gnu_limit)) + { + gnu_cond_expr + = build (COND_EXPR, void_type_node, + build_binary_op (LE_EXPR, integer_type_node, + gnu_low, gnu_high), + NULL_TREE, alloc_stmt_list ()); + annotate_with_node (gnu_cond_expr, gnat_loop_spec); + } + + /* Open a new nesting level that will surround the loop to declare the + loop index variable. */ + start_stmt_group (); + gnat_pushlevel (); + + /* Declare the loop index and set it to its initial value. */ + gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); + if (DECL_BY_REF_P (gnu_loop_var)) + gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); + + /* The loop variable might be a padded type, so use `convert' to get a + reference to the inner variable if so. */ + gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var); + + /* Set either the top or bottom exit condition as appropriate depending + on whether or not we know an overflow cannot occur. */ + if (gnu_cond_expr) + LOOP_STMT_BOT_COND (gnu_loop_stmt) + = build_binary_op (NE_EXPR, integer_type_node, + gnu_loop_var, gnu_last); + else + LOOP_STMT_TOP_COND (gnu_loop_stmt) + = build_binary_op (end_code, integer_type_node, + gnu_loop_var, gnu_last); + + LOOP_STMT_UPDATE (gnu_loop_stmt) + = build_binary_op (reversep ? PREDECREMENT_EXPR + : PREINCREMENT_EXPR, + TREE_TYPE (gnu_loop_var), + gnu_loop_var, + convert (TREE_TYPE (gnu_loop_var), + integer_one_node)); + annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt), + gnat_iter_scheme); + } + + /* If the loop was named, have the name point to this loop. In this case, + the association is not a ..._DECL node, but the end label from this + LOOP_STMT. */ + if (Present (Identifier (gnat_node))) + save_gnu_tree (Entity (Identifier (gnat_node)), + LOOP_STMT_LABEL (gnu_loop_stmt), 1); + + /* Make the loop body into its own block, so any allocated storage will be + released every iteration. This is needed for stack allocation. */ + LOOP_STMT_BODY (gnu_loop_stmt) + = build_stmt_group (Statements (gnat_node), true); + + /* If we declared a variable, then we are in a statement group for that + declaration. Add the LOOP_STMT to it and make that the "loop". */ + if (gnu_loop_var) + { + add_stmt (gnu_loop_stmt); + gnat_poplevel (); + gnu_loop_stmt = end_stmt_group (); + } + + /* If we have an outer COND_EXPR, that's our result and this loop is its + "true" statement. Otherwise, the result is the LOOP_STMT. */ + if (gnu_cond_expr) + { + COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; + gnu_result = gnu_cond_expr; + recalculate_side_effects (gnu_cond_expr); + } + else + gnu_result = gnu_loop_stmt; + + pop_stack (&gnu_loop_label_stack); + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We + don't return anything. */ + +static void +Subprogram_Body_to_gnu (Node_Id gnat_node) +{ + /* Save debug output mode in case it is reset. */ + enum debug_info_type save_write_symbols = write_symbols; + const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks; + /* Definining identifier of a parameter to the subprogram. */ + Entity_Id gnat_param; + /* The defining identifier for the subprogram body. Note that if a + specification has appeared before for this body, then the identifier + occurring in that specification will also be a defining identifier and all + the calls to this subprogram will point to that specification. */ + Entity_Id gnat_subprog_id + = (Present (Corresponding_Spec (gnat_node)) + ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); + /* The FUNCTION_DECL node corresponding to the subprogram spec. */ + tree gnu_subprog_decl; + /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ + tree gnu_subprog_type; + tree gnu_cico_list; + tree gnu_result; + + /* If this is a generic object or if it has been eliminated, + ignore it. */ + if (Ekind (gnat_subprog_id) == E_Generic_Procedure + || Ekind (gnat_subprog_id) == E_Generic_Function + || Is_Eliminated (gnat_subprog_id)) + return; + + /* If debug information is suppressed for the subprogram, turn debug + mode off for the duration of processing. */ + if (!Needs_Debug_Info (gnat_subprog_id)) + { + write_symbols = NO_DEBUG; + debug_hooks = &do_nothing_debug_hooks; + } + + /* If this subprogram acts as its own spec, define it. Otherwise, just get + the already-elaborated tree node. However, if this subprogram had its + elaboration deferred, we will already have made a tree node for it. So + treat it as not being defined in that case. Such a subprogram cannot + have an address clause or a freeze node, so this test is safe, though it + does disable some otherwise-useful error checking. */ + gnu_subprog_decl + = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, + Acts_As_Spec (gnat_node) + && ! present_gnu_tree (gnat_subprog_id)); + + gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); + + /* Set the line number in the decl to correspond to that of the body so that + the line number notes are written + correctly. */ + Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl)); + + begin_subprog_body (gnu_subprog_decl); + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + + /* If there are OUT parameters, we need to ensure that the return statement + properly copies them out. We do this by making a new block and converting + any inner return into a goto to a label at the end of the block. */ + push_stack (&gnu_return_label_stack, NULL_TREE, + gnu_cico_list ? create_artificial_label () : NULL_TREE); + + /* Get a tree corresponding to the code for the subprogram. */ + start_stmt_group (); + gnat_pushlevel (); + + /* See if there are any parameters for which we don't yet have GCC entities. + These must be for OUT parameters for which we will be making VAR_DECL + nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty + entry as well. We can match up the entries because TYPE_CI_CO_LIST is in + the order of the parameters. */ + for (gnat_param = First_Formal (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (!present_gnu_tree (gnat_param)) + { + /* Skip any entries that have been already filled in; they must + correspond to IN OUT parameters. */ + for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0; + gnu_cico_list = TREE_CHAIN (gnu_cico_list)) + ; + + /* Do any needed references for padded types. */ + TREE_VALUE (gnu_cico_list) + = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)), + gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); + } + + process_decls (Declarations (gnat_node), Empty, Empty, 1, 1); + + /* Generate the code of the subprogram itself. A return statement will be + present and any OUT parameters will be handled there. */ + add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + + /* If we made a special return label, we need to make a block that contains + the definition of that label and the copying to the return value. That + block first contains the function, then the label and copy statement. */ + if (TREE_VALUE (gnu_return_label_stack) != 0) + { + tree gnu_retval; + + start_stmt_group (); + gnat_pushlevel (); + add_stmt (gnu_result); + add_stmt (build1 (LABEL_EXPR, void_type_node, + TREE_VALUE (gnu_return_label_stack))); + + gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); + if (list_length (gnu_cico_list) == 1) + gnu_retval = TREE_VALUE (gnu_cico_list); + else + gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); + + if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval)) + gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval); + + add_stmt_with_node + (build1 (RETURN_EXPR, void_type_node, + build (MODIFY_EXPR, TREE_TYPE (gnu_retval), + DECL_RESULT (current_function_decl), gnu_retval)), + gnat_node); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + pop_stack (&gnu_return_label_stack); + + /* Initialize the information node for the function and set the + end location. */ + allocate_struct_function (current_function_decl); + Sloc_to_locus + ((Present (End_Label (Handled_Statement_Sequence (gnat_node))) + ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node))) + : Sloc (gnat_node)), + &cfun->function_end_locus); + + end_subprog_body (gnu_result); + + /* Disconnect the trees for parameters that we made variables for from the + GNAT entities since these are unusable after we end the function. */ + for (gnat_param = First_Formal (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) + save_gnu_tree (gnat_param, NULL_TREE, 0); + + mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); + write_symbols = save_write_symbols; + debug_hooks = save_debug_hooks; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call + or an N_Procedure_Call_Statement, to a GCC tree, which is returned. + GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */ + +static tree +call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) +{ + tree gnu_result; + /* The GCC node corresponding to the GNAT subprogram name. This can either + be a FUNCTION_DECL node if we are dealing with a standard subprogram call, + or an indirect reference expression (an INDIRECT_REF node) pointing to a + subprogram. */ + tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); + /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ + tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); + tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_subprog_node); + Entity_Id gnat_formal; + Node_Id gnat_actual; + tree gnu_actual_list = NULL_TREE; + tree gnu_name_list = NULL_TREE; + tree gnu_before_list = NULL_TREE; + tree gnu_after_list = NULL_TREE; + tree gnu_subprog_call; + + switch (Nkind (Name (gnat_node))) + { + case N_Identifier: + case N_Operator_Symbol: + case N_Expanded_Name: + case N_Attribute_Reference: + if (Is_Eliminated (Entity (Name (gnat_node)))) + Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node))); + } + + if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE) + gigi_abort (317); + + /* If we are calling a stubbed function, make this into a raise of + Program_Error. Elaborate all our args first. */ + if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL + && DECL_STUBBED_P (gnu_subprog_node)) + { + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_actual = Next_Actual (gnat_actual)) + add_stmt (gnat_to_gnu (gnat_actual)); + + if (Nkind (gnat_node) == N_Function_Call) + { + *gnu_result_type_p = TREE_TYPE (gnu_subprog_type); + return build1 (NULL_EXPR, *gnu_result_type_p, + build_call_raise (PE_Stubbed_Subprogram_Called)); + } + else + return build_call_raise (PE_Stubbed_Subprogram_Called); + } + + /* The only way we can be making a call via an access type is if Name is an + explicit dereference. In that case, get the list of formal args from the + type the access type is pointing to. Otherwise, get the formals from + entity being called. */ + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal (Etype (Name (gnat_node))); + else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) + /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ + gnat_formal = 0; + else + gnat_formal = First_Formal (Entity (Name (gnat_node))); + + /* Create the list of the actual parameters as GCC expects it, namely a chain + of TREE_LIST nodes in which the TREE_VALUE field of each node is a + parameter-expression and the TREE_PURPOSE field is null. Skip OUT + parameters not passed by reference and don't need to be copied in. */ + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + { + tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); + /* We treat a conversion between aggregate types as if it is an + unchecked conversion. */ + bool unchecked_convert_p + = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion + || (Nkind (gnat_actual) == N_Type_Conversion + && Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))); + Node_Id gnat_name = (unchecked_convert_p + ? Expression (gnat_actual) : gnat_actual); + tree gnu_name = gnat_to_gnu (gnat_name); + tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)); + tree gnu_actual; + + /* If it's possible we may need to use this expression twice, make sure + than any side-effects are handled via SAVE_EXPRs. Likewise if we need + to force side-effects before the call. + + ??? This is more conservative than we need since we don't need to do + this for pass-by-ref with no conversion. If we are passing a + non-addressable Out or In Out parameter by reference, pass the address + of a copy and set up to copy back out after the call. */ + if (Ekind (gnat_formal) != E_In_Parameter) + { + gnu_name = gnat_stabilize_reference (gnu_name, 1); + if (! addressable_p (gnu_name) + && present_gnu_tree (gnat_formal) + && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) + || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && (DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)) + || (DECL_BY_DESCRIPTOR_P + (get_gnu_tree (gnat_formal))))))) + { + tree gnu_copy = gnu_name; + tree gnu_temp; + + /* Remove any unpadding on the actual and make a copy. But if + the actual is a left-justified modular type, first convert + to it. */ + if (TREE_CODE (gnu_name) == COMPONENT_REF + && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) + == RECORD_TYPE) + && (TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) + gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0); + else if (TREE_CODE (gnu_name_type) == RECORD_TYPE + && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_name_type))) + gnu_name = convert (gnu_name_type, gnu_name); + + gnu_actual = save_expr (gnu_name); + + /* Since we're going to take the address of the SAVE_EXPR, we + don't want it to be marked as unchanging. So set + TREE_ADDRESSABLE. */ + gnu_temp = skip_simple_arithmetic (gnu_actual); + if (TREE_CODE (gnu_temp) == SAVE_EXPR) + { + TREE_ADDRESSABLE (gnu_temp) = 1; + TREE_READONLY (gnu_temp) = 0; + } + + /* Set up to move the copy back to the original. */ + gnu_temp = build (MODIFY_EXPR, TREE_TYPE (gnu_copy), + gnu_copy, gnu_actual); + annotate_with_node (gnu_temp, gnat_actual); + append_to_statement_list (gnu_temp, &gnu_after_list); + } + } + + /* If this was a procedure call, we may not have removed any padding. + So do it here for the part we will use as an input, if any. */ + gnu_actual = gnu_name; + if (Ekind (gnat_formal) != E_Out_Parameter + && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) + gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), + gnu_actual); + + /* Unless this is an In parameter, we must remove any LJM building + from GNU_NAME. */ + if (Ekind (gnat_formal) != E_In_Parameter + && TREE_CODE (gnu_name) == CONSTRUCTOR + && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE + && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) + gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), + gnu_name); + + if (Ekind (gnat_formal) != E_Out_Parameter + && ! unchecked_convert_p + && Do_Range_Check (gnat_actual)) + gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); + + /* Do any needed conversions. We need only check for unchecked + conversion since normal conversions will be handled by just + converting to the formal type. */ + if (unchecked_convert_p) + { + gnu_actual + = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual, + (Nkind (gnat_actual) + == N_Unchecked_Type_Conversion) + && No_Truncation (gnat_actual)); + + /* One we've done the unchecked conversion, we still must ensure that + the object is in range of the formal's type. */ + if (Ekind (gnat_formal) != E_Out_Parameter + && Do_Range_Check (gnat_actual)) + gnu_actual = emit_range_check (gnu_actual, + Etype (gnat_formal)); + } + else if (TREE_CODE (gnu_actual) != SAVE_EXPR) + /* We may have suppressed a conversion to the Etype of the actual since + the parent is a procedure call. So add the conversion here. */ + gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), + gnu_actual); + + if (TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (gnu_formal_type, gnu_actual); + + /* If we have not saved a GCC object for the formal, it means it is an + OUT parameter not passed by reference and that does not need to be + copied in. Otherwise, look at the PARM_DECL to see if it is passed by + reference. */ + if (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && DECL_BY_REF_P (get_gnu_tree (gnat_formal))) + { + if (Ekind (gnat_formal) != E_In_Parameter) + { + gnu_actual = gnu_name; + + /* If we have a padded type, be sure we've removed padding. */ + if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) + && TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), + gnu_actual); + } + + /* Otherwise, if we have a non-addressable COMPONENT_REF of a + variable-size type see if it's doing a unpadding operation. If + so, remove that operation since we have no way of allocating the + required temporary. */ + if (TREE_CODE (gnu_actual) == COMPONENT_REF + && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0))) + == RECORD_TYPE) + && TYPE_IS_PADDING_P (TREE_TYPE + (TREE_OPERAND (gnu_actual, 0))) + && !addressable_p (gnu_actual)) + gnu_actual = TREE_OPERAND (gnu_actual, 0); + + /* The symmetry of the paths to the type of an entity is broken here + since arguments don't know that they will be passed by ref. */ + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); + } + else if (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))) + { + gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); + gnu_actual = maybe_implicit_deref (gnu_actual); + gnu_actual = maybe_unconstrained_array (gnu_actual); + + if (TREE_CODE (gnu_formal_type) == RECORD_TYPE + && TYPE_IS_PADDING_P (gnu_formal_type)) + { + gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); + gnu_actual = convert (gnu_formal_type, gnu_actual); + } + + /* Take the address of the object and convert to the proper pointer + type. We'd like to actually compute the address of the beginning + of the array using an ADDR_EXPR of an ARRAY_REF, but there's a + possibility that the ARRAY_REF might return a constant and we'd be + getting the wrong address. Neither approach is exactly correct, + but this is the most likely to work in all cases. */ + gnu_actual = convert (gnu_formal_type, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_actual)); + } + else if (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))) + { + /* If arg is 'Null_Parameter, pass zero descriptor. */ + if ((TREE_CODE (gnu_actual) == INDIRECT_REF + || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) + && TREE_PRIVATE (gnu_actual)) + gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), + integer_zero_node); + else + gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, + fill_vms_descriptor (gnu_actual, + gnat_formal)); + } + else + { + tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual)); + + if (Ekind (gnat_formal) != E_In_Parameter) + gnu_name_list = chainon (gnu_name_list, + build_tree_list (NULL_TREE, gnu_name)); + + if (! present_gnu_tree (gnat_formal) + || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL) + continue; + + /* If this is 'Null_Parameter, pass a zero even though we are + dereferencing it. */ + else if (TREE_CODE (gnu_actual) == INDIRECT_REF + && TREE_PRIVATE (gnu_actual) + && host_integerp (gnu_actual_size, 1) + && 0 >= compare_tree_int (gnu_actual_size, + BITS_PER_WORD)) + gnu_actual + = unchecked_convert + (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), + convert (gnat_type_for_size + (tree_low_cst (gnu_actual_size, 1), 1), + integer_zero_node), 0); + else + gnu_actual = convert (TYPE_MAIN_VARIANT + (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))), + gnu_actual); + } + + gnu_actual_list = chainon (gnu_actual_list, + build_tree_list (NULL_TREE, gnu_actual)); + } + + gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type), + gnu_subprog_addr, gnu_actual_list, NULL_TREE); + TREE_SIDE_EFFECTS (gnu_subprog_call) = 1; + + /* If it is a function call, the result is the call expression. */ + if (Nkind (gnat_node) == N_Function_Call) + { + gnu_result = gnu_subprog_call; + + /* If the function returns an unconstrained array or by reference, + we have to de-dereference the pointer. */ + if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type) + || TYPE_RETURNS_BY_REF_P (gnu_subprog_type)) + gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); + + *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); + return gnu_result; + } + + /* If this is the case where the GNAT tree contains a procedure call + but the Ada procedure has copy in copy out parameters, the special + parameter passing mechanism must be used. */ + else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) + { + /* List of FIELD_DECLs associated with the PARM_DECLs of the copy + in copy out parameters. */ + tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type); + int length = list_length (scalar_return_list); + + if (length > 1) + { + tree gnu_name; + + gnu_subprog_call = protect_multiple_eval (gnu_subprog_call); + + /* If any of the names had side-effects, ensure they are all + evaluated before the call. */ + for (gnu_name = gnu_name_list; gnu_name; + gnu_name = TREE_CHAIN (gnu_name)) + if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name))) + add_stmt (TREE_VALUE (gnu_name)); + } + + if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) + gnat_formal = First_Formal (Etype (Name (gnat_node))); + else + gnat_formal = First_Formal (Entity (Name (gnat_node))); + + for (gnat_actual = First_Actual (gnat_node); + Present (gnat_actual); + gnat_formal = Next_Formal_With_Extras (gnat_formal), + gnat_actual = Next_Actual (gnat_actual)) + /* If we are dealing with a copy in copy out parameter, we must + retrieve its value from the record returned in the call. */ + if (! (present_gnu_tree (gnat_formal) + && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) + || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL + && ((DECL_BY_COMPONENT_PTR_P + (get_gnu_tree (gnat_formal)) + || (DECL_BY_DESCRIPTOR_P + (get_gnu_tree (gnat_formal)))))))) + && Ekind (gnat_formal) != E_In_Parameter) + { + /* Get the value to assign to this OUT or IN OUT parameter. It is + either the result of the function if there is only a single such + parameter or the appropriate field from the record returned. */ + tree gnu_result + = length == 1 ? gnu_subprog_call + : build_component_ref (gnu_subprog_call, NULL_TREE, + TREE_PURPOSE (scalar_return_list), 0); + bool unchecked_conversion = (Nkind (gnat_actual) + == N_Unchecked_Type_Conversion); + /* If the actual is a conversion, get the inner expression, which + will be the real destination, and convert the result to the + type of the actual parameter. */ + tree gnu_actual + = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); + + /* If the result is a padded type, remove the padding. */ + if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE + && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) + gnu_result = convert (TREE_TYPE (TYPE_FIELDS + (TREE_TYPE (gnu_result))), + gnu_result); + + /* If the result is a type conversion, do it. */ + if (Nkind (gnat_actual) == N_Type_Conversion) + gnu_result + = convert_with_check + (Etype (Expression (gnat_actual)), gnu_result, + Do_Overflow_Check (gnat_actual), + Do_Range_Check (Expression (gnat_actual)), + Float_Truncate (gnat_actual)); + + else if (unchecked_conversion) + gnu_result = unchecked_convert (TREE_TYPE (gnu_actual), + gnu_result, + No_Truncation (gnat_actual)); + else + { + if (Do_Range_Check (gnat_actual)) + gnu_result = emit_range_check (gnu_result, + Etype (gnat_actual)); + + if (! (! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) + && TREE_CONSTANT (TYPE_SIZE + (TREE_TYPE (gnu_result))))) + gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); + } + + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, + gnu_actual, gnu_result); + annotate_with_node (gnu_result, gnat_actual); + append_to_statement_list (gnu_result, &gnu_before_list); + scalar_return_list = TREE_CHAIN (scalar_return_list); + gnu_name_list = TREE_CHAIN (gnu_name_list); + } + } + else + { + annotate_with_node (gnu_subprog_call, gnat_node); + append_to_statement_list (gnu_subprog_call, &gnu_before_list); + } + + append_to_statement_list (gnu_after_list, &gnu_before_list); + return gnu_before_list; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an + N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */ + +static tree +Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) +{ + tree gnu_jmpsave_decl = NULL_TREE; + tree gnu_jmpbuf_decl = NULL_TREE; + /* If just annotating, ignore all EH and cleanups. */ + bool gcc_zcx = (!type_annotate_only + && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == GCC_ZCX); + bool setjmp_longjmp + = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) + && Exception_Mechanism == Setjmp_Longjmp); + bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); + bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); + tree gnu_inner_block; /* The statement(s) for the block itself. */ + tree gnu_result; + tree gnu_expr; + Node_Id gnat_temp; + + /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes + and we have our own SJLJ mechanism. To call the GCC mechanism, we call + add_cleanup, and when we leave the binding, end_stmt_group will create + the TRY_FINALLY_EXPR. + + ??? The region level calls down there have been specifically put in place + for a ZCX context and currently the order in which things are emitted + (region/handlers) is different from the SJLJ case. Instead of putting + other calls with different conditions at other places for the SJLJ case, + it seems cleaner to reorder things for the SJLJ case and generalize the + condition to make it not ZCX specific. + + If there are any exceptions or cleanup processing involved, we need an + outer statement group (for Setjmp_Longjmp) and binding level. */ + if (binding_for_block) + { + start_stmt_group (); + gnat_pushlevel (); + } + + /* If we are to call a function when exiting this block add a cleanup + to the binding level we made above. */ + if (at_end) + add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)))); + + /* If using setjmp_longjmp, make the variables for the setjmp buffer and save + area for address of previous buffer. Do this first since we need to have + the setjmp buf known for any decls in this block. */ + if (setjmp_longjmp) + { + gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"), + NULL_TREE, jmpbuf_ptr_type, + build_call_0_expr (get_jmpbuf_decl), + 0, 0, 0, 0, 0, gnat_node); + gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"), + NULL_TREE, jmpbuf_type, + NULL_TREE, 0, 0, 0, 0, 0, gnat_node); + + set_block_jmpbuf_decl (gnu_jmpbuf_decl); + + /* When we exit this block, restore the saved value. */ + add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl)); + } + + /* Now build the tree for the declarations and statements inside this block. + If this is SJLJ, set our jmp_buf as the current buffer. */ + start_stmt_group (); + + if (setjmp_longjmp) + add_stmt (build_call_1_expr (set_jmpbuf_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))); + + + if (Present (First_Real_Statement (gnat_node))) + process_decls (Statements (gnat_node), Empty, + First_Real_Statement (gnat_node), 1, 1); + + /* Generate code for each statement in the block. */ + for (gnat_temp = (Present (First_Real_Statement (gnat_node)) + ? First_Real_Statement (gnat_node) + : First (Statements (gnat_node))); + Present (gnat_temp); gnat_temp = Next (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_inner_block = end_stmt_group (); + + /* Now generate code for the two exception models, if either is relevant for + this block. */ + if (setjmp_longjmp) + { + tree *gnu_else_ptr = 0; + tree gnu_handler; + + /* Make a binding level for the exception handling declarations and code + and set up gnu_except_ptr_stack for the handlers to use. */ + start_stmt_group (); + gnat_pushlevel (); + + push_stack (&gnu_except_ptr_stack, NULL_TREE, + create_var_decl (get_identifier ("EXCEPT_PTR"), + NULL_TREE, + build_pointer_type (except_type_node), + build_call_0_expr (get_excptr_decl), + 0, 0, 0, 0, 0, gnat_node)); + + /* Generate code for each handler. The N_Exception_Handler case does the + real work and returns a COND_EXPR for each handler, which we chain + together here. */ + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp)) + { + gnu_expr = gnat_to_gnu (gnat_temp); + + /* If this is the first one, set it as the outer one. Otherwise, + point the "else" part of the previous handler to us. Then point + to our "else" part. */ + if (!gnu_else_ptr) + add_stmt (gnu_expr); + else + *gnu_else_ptr = gnu_expr; + + gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); + } + + /* If none of the exception handlers did anything, re-raise but do not + defer abortion. */ + gnu_expr = build_call_1_expr (raise_nodefer_decl, + TREE_VALUE (gnu_except_ptr_stack)); + annotate_with_node (gnu_expr, gnat_node); + + if (gnu_else_ptr) + *gnu_else_ptr = gnu_expr; + else + add_stmt (gnu_expr); + + /* End the binding level dedicated to the exception handlers and get the + whole statement group. */ + pop_stack (&gnu_except_ptr_stack); + gnat_poplevel (); + gnu_handler = end_stmt_group (); + + /* If the setjmp returns 1, we restore our incoming longjmp value and + then check the handlers. */ + start_stmt_group (); + add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl, + gnu_jmpsave_decl), + gnat_node); + add_stmt (gnu_handler); + gnu_handler = end_stmt_group (); + + /* This block is now "if (setjmp) ... else ". */ + gnu_result = build (COND_EXPR, void_type_node, + (build_call_1_expr + (setjmp_decl, + build_unary_op (ADDR_EXPR, NULL_TREE, + gnu_jmpbuf_decl))), + gnu_handler, gnu_inner_block); + } + else if (gcc_zcx) + { + tree gnu_handlers; + + /* First make a block containing the handlers. */ + start_stmt_group (); + for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); + Present (gnat_temp); + gnat_temp = Next_Non_Pragma (gnat_temp)) + add_stmt (gnat_to_gnu (gnat_temp)); + gnu_handlers = end_stmt_group (); + + /* Now make the TRY_CATCH_EXPR for the block. */ + gnu_result = build (TRY_CATCH_EXPR, void_type_node, + gnu_inner_block, gnu_handlers); + } + else + gnu_result = gnu_inner_block; + + /* Now close our outer block, if we had to make one. */ + if (binding_for_block) + { + add_stmt (gnu_result); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + return gnu_result; +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp + exception handling. */ + +static tree +Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) +{ + /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make + an "if" statement to select the proper exceptions. For "Others", exclude + exceptions where Handled_By_Others is nonzero unless the All_Others flag + is set. For "Non-ada", accept an exception if "Lang" is 'V'. */ + tree gnu_choice = integer_zero_node; + tree gnu_body = build_stmt_group (Statements (gnat_node), false); + Node_Id gnat_temp; + + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + tree this_choice; + + if (Nkind (gnat_temp) == N_Others_Choice) + { + if (All_Others (gnat_temp)) + this_choice = integer_one_node; + else + this_choice + = build_binary_op + (EQ_EXPR, integer_type_node, + convert + (integer_type_node, + build_component_ref + (build_unary_op + (INDIRECT_REF, NULL_TREE, + TREE_VALUE (gnu_except_ptr_stack)), + get_identifier ("not_handled_by_others"), NULL_TREE, + 0)), + integer_zero_node); + } + + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + tree gnu_expr + = gnat_to_gnu_entity (Entity (gnat_temp), NULL_TREE, 0); + + this_choice + = build_binary_op + (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack), + convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), + build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); + + /* If this is the distinguished exception "Non_Ada_Error" (and we are + in VMS mode), also allow a non-Ada exception (a VMS condition) t + match. */ + if (Is_Non_Ada_Error (Entity (gnat_temp))) + { + tree gnu_comp + = build_component_ref + (build_unary_op (INDIRECT_REF, NULL_TREE, + TREE_VALUE (gnu_except_ptr_stack)), + get_identifier ("lang"), NULL_TREE, 0); + + this_choice + = build_binary_op + (TRUTH_ORIF_EXPR, integer_type_node, + build_binary_op (EQ_EXPR, integer_type_node, gnu_comp, + convert (TREE_TYPE (gnu_comp), + build_int_2 ('V', 0))), + this_choice); + } + } + else + gigi_abort (318); + + gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, + gnu_choice, this_choice); + } + + return build (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); +} + +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, + to a GCC tree, which is returned. This is the variant for ZCX. */ + +static tree +Exception_Handler_to_gnu_zcx (Node_Id gnat_node) +{ + tree gnu_etypes_list = NULL_TREE; + tree gnu_expr; + tree gnu_etype; + tree gnu_current_exc_ptr; + tree gnu_incoming_exc_ptr; + Node_Id gnat_temp; + + /* We build a TREE_LIST of nodes representing what exception types this + handler can catch, with special cases for others and all others cases. + + Each exception type is actually identified by a pointer to the exception + id, with special value zero for "others" and one for "all others". Beware + that these special values are known and used by the personality routine to + identify the corresponding specific kinds of handlers. + + ??? For initial time frame reasons, the others and all_others cases have + been handled using specific type trees, but this somehow hides information + from the back-end, which expects NULL to be passed for catch all and + end_cleanup to be used for cleanups. + + Care should be taken to ensure that the control flow impact of such + clauses is rendered in some way. lang_eh_type_covers is doing the trick + currently. */ + for (gnat_temp = First (Exception_Choices (gnat_node)); + gnat_temp; gnat_temp = Next (gnat_temp)) + { + if (Nkind (gnat_temp) == N_Others_Choice) + gnu_etype = (All_Others (gnat_temp) ? integer_one_node + : integer_zero_node); + else if (Nkind (gnat_temp) == N_Identifier + || Nkind (gnat_temp) == N_Expanded_Name) + { + Entity_Id gnat_ex_id = Entity (gnat_temp); + + /* Exception may be a renaming. Recover original exception which is + the one elaborated and registered. */ + if (Present (Renamed_Object (gnat_ex_id))) + gnat_ex_id = Renamed_Object (gnat_ex_id); + + gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); + gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); + + /* The Non_Ada_Error case for VMS exceptions is handled + by the personality routine. */ + } + else + gigi_abort (337); + + /* The GCC interface expects NULL to be passed for catch all handlers, so + it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype + is integer_zero_node. It would not work, however, because GCC's + notion of "catch all" is stronger than our notion of "others". Until + we correctly use the cleanup interface as well, doing that would + prevent the "all others" handlers from beeing seen, because nothing + can be caught beyond a catch all from GCC's point of view. */ + gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); + } + + start_stmt_group (); + gnat_pushlevel (); + + /* Expand a call to the begin_handler hook at the beginning of the handler, + and arrange for a call to the end_handler hook to occur on every possible + exit path. + + The hooks expect a pointer to the low level occurrence. This is required + for our stack management scheme because a raise inside the handler pushes + a new occurrence on top of the stack, which means that this top does not + necessarily match the occurrence this handler was dealing with. + + The EXC_PTR_EXPR object references the exception occurrence being + propagated. Upon handler entry, this is the exception for which the + handler is triggered. This might not be the case upon handler exit, + however, as we might have a new occurrence propagated by the handler's + body, and the end_handler hook called as a cleanup in this context. + + We use a local variable to retrieve the incoming value at handler entry + time, and reuse it to feed the end_handler hook's argument at exit. */ + gnu_current_exc_ptr = build (EXC_PTR_EXPR, ptr_type_node); + gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, + ptr_type_node, gnu_current_exc_ptr, + 0, 0, 0, 0, 0, gnat_node); + + add_stmt_with_node (build_call_1_expr (begin_handler_decl, + gnu_incoming_exc_ptr), + gnat_node); + add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr)); + add_stmt_list (Statements (gnat_node)); + gnat_poplevel (); + + return build (CATCH_EXPR, void_type_node, gnu_etypes_list, + end_stmt_group ()); +} + /* This function is the driver of the GNAT to GCC tree transformation process. It is the entry point of the tree transformer. GNAT_NODE is the root of some GNAT tree. Return the root of the corresponding GCC tree. @@ -315,7 +2345,6 @@ gnat_to_gnu (Node_Id gnat_node) tree gnu_expr; tree gnu_lhs, gnu_rhs; Node_Id gnat_temp; - Entity_Id gnat_temp_type; /* Save node number for error message and set location information. */ error_gnat_node = gnat_node; @@ -354,7 +2383,6 @@ gnat_to_gnu (Node_Id gnat_node) went_into_elab_proc = true; } - switch (Nkind (gnat_node)) { /********************************/ @@ -365,182 +2393,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Expanded_Name: case N_Operator_Symbol: case N_Defining_Identifier: - - /* If the Etype of this node does not equal the Etype of the Entity, - something is wrong with the entity map, probably in generic - instantiation. However, this does not apply to types. Since we - sometime have strange Ekind's, just do this test for objects. Also, - if the Etype of the Entity is private, the Etype of the N_Identifier - is allowed to be the full type and also we consider a packed array - type to be the same as the original type. Similarly, a class-wide - type is equivalent to a subtype of itself. Finally, if the types are - Itypes, one may be a copy of the other, which is also legal. */ - gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier - ? gnat_node : Entity (gnat_node)); - gnat_temp_type = Etype (gnat_temp); - - if (Etype (gnat_node) != gnat_temp_type - && ! (Is_Packed (gnat_temp_type) - && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type)) - && ! (Is_Class_Wide_Type (Etype (gnat_node))) - && ! (IN (Ekind (gnat_temp_type), Private_Kind) - && Present (Full_View (gnat_temp_type)) - && ((Etype (gnat_node) == Full_View (gnat_temp_type)) - || (Is_Packed (Full_View (gnat_temp_type)) - && Etype (gnat_node) == - Packed_Array_Type (Full_View (gnat_temp_type))))) - && (!Is_Itype (Etype (gnat_node)) || !Is_Itype (gnat_temp_type)) - && (Ekind (gnat_temp) == E_Variable - || Ekind (gnat_temp) == E_Component - || Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Loop_Parameter - || IN (Ekind (gnat_temp), Formal_Kind))) - gigi_abort (304); - - /* If this is a reference to a deferred constant whose partial view - is an unconstrained private type, the proper type is on the full - view of the constant, not on the full view of the type, which may - be unconstrained. - - This may be a reference to a type, for example in the prefix of the - attribute Position, generated for dispatching code (see Make_DT in - exp_disp,adb). In that case we need the type itself, not is parent, - in particular if it is a derived type */ - if (Is_Private_Type (gnat_temp_type) - && Has_Unknown_Discriminants (gnat_temp_type) - && Present (Full_View (gnat_temp)) - && ! Is_Type (gnat_temp)) - { - gnat_temp = Full_View (gnat_temp); - gnat_temp_type = Etype (gnat_temp); - gnu_result_type = get_unpadded_type (gnat_temp_type); - } - else - { - /* Expand the type of this identitier first, in case it is - an enumeral literal, which only get made when the type - is expanded. There is no order-of-elaboration issue here. - We want to use the Actual_Subtype if it has already been - elaborated, otherwise the Etype. Avoid using Actual_Subtype - for packed arrays to simplify things. */ - if ((Ekind (gnat_temp) == E_Constant - || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) - && ! (Is_Array_Type (Etype (gnat_temp)) - && Present (Packed_Array_Type (Etype (gnat_temp)))) - && Present (Actual_Subtype (gnat_temp)) - && present_gnu_tree (Actual_Subtype (gnat_temp))) - gnat_temp_type = Actual_Subtype (gnat_temp); - else - gnat_temp_type = Etype (gnat_node); - - gnu_result_type = get_unpadded_type (gnat_temp_type); - } - - gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); - - /* If we are in an exception handler, force this variable into memory - to ensure optimization does not remove stores that appear - redundant but are actually needed in case an exception occurs. - - ??? Note that we need not do this if the variable is declared within - the handler, only if it is referenced in the handler and declared - in an enclosing block, but we have no way of testing that - right now. - - ??? Also, for now all we can do is make it volatile. But we only - do this for SJLJ. */ - if (TREE_VALUE (gnu_except_ptr_stack) != 0 - && TREE_CODE (gnu_result) == VAR_DECL) - TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; - - /* Some objects (such as parameters passed by reference, globals of - variable size, and renamed objects) actually represent the address - of the object. In that case, we must do the dereference. Likewise, - deal with parameters to foreign convention subprograms. Call fold - here since GNU_RESULT may be a CONST_DECL. */ - if (DECL_P (gnu_result) - && (DECL_BY_REF_P (gnu_result) - || (TREE_CODE (gnu_result) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (gnu_result)))) - { - int ro = DECL_POINTS_TO_READONLY_P (gnu_result); - tree initial; - - if (TREE_CODE (gnu_result) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (gnu_result)) - gnu_result - = build_unary_op (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (gnu_result_type), - gnu_result)); - - /* If the object is constant, we try to do the dereference directly - through the DECL_INITIAL. This is actually required in order to - get correct aliasing information for renamed objects that are - components of non-aliased aggregates, because the type of the - renamed object and that of the aggregate don't alias. - - Note that we expect the initial value to have been stabilized. - If it contains e.g. a variable reference, we certainly don't want - to re-evaluate the variable each time the renaming is used. - - Stabilization is currently not performed at the global level but - create_var_decl avoids setting DECL_INITIAL if the value is not - constant then, and we get to the pointer dereference below. - - ??? Couldn't the aliasing issue show up again in this case ? - There is no obvious reason why not. */ - else if (TREE_READONLY (gnu_result) - && DECL_INITIAL (gnu_result) - /* Strip possible conversion to reference type. */ - && ((initial = TREE_CODE (DECL_INITIAL (gnu_result)) - == NOP_EXPR - ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0) - : DECL_INITIAL (gnu_result), 1)) - && TREE_CODE (initial) == ADDR_EXPR - && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF - || (TREE_CODE (TREE_OPERAND (initial, 0)) - == COMPONENT_REF))) - gnu_result = TREE_OPERAND (initial, 0); - else - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, - fold (gnu_result)); - - TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro; - } - - /* The GNAT tree has the type of a function as the type of its result. - Also use the type of the result if the Etype is a subtype which - is nominally unconstrained. But remove any padding from the - resulting type. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE - || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type)) - { - gnu_result_type = TREE_TYPE (gnu_result); - if (TREE_CODE (gnu_result_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_result_type)) - gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); - } - - /* We always want to return the underlying INTEGER_CST for an - enumeration literal to avoid the need to call fold in lots - of places. But don't do this is the parent will be taking - the address of this object. */ - if (TREE_CODE (gnu_result) == CONST_DECL) - { - gnat_temp = Parent (gnat_node); - if (DECL_CONST_CORRESPONDING_VAR (gnu_result) == 0 - || (Nkind (gnat_temp) != N_Reference - && ! (Nkind (gnat_temp) == N_Attribute_Reference - && ((Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Address) - || (Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Access) - || (Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Unchecked_Access) - || (Get_Attribute_Id (Attribute_Name (gnat_temp)) - == Attr_Unrestricted_Access))))) - gnu_result = DECL_INITIAL (gnu_result); - } + gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type); break; case N_Integer_Literal: @@ -657,9 +2510,6 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result_type = get_unpadded_type (Etype (gnat_node)); if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR) { - /* We assume here that all strings are of type standard.string. - "Weird" types of string have been converted to an aggregate - by the expander. */ String_Id gnat_string = Strval (gnat_node); int length = String_Length (gnat_string); char *string = (char *) alloca (length + 1); @@ -711,58 +2561,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Pragma: gnu_result = alloc_stmt_list (); - /* Check for (and ignore) unrecognized pragma and do nothing if - we are just annotating types. */ - if (type_annotate_only - || ! Is_Pragma_Name (Chars (gnat_node))) - break; - - switch (Get_Pragma_Id (Chars (gnat_node))) - { - case Pragma_Inspection_Point: - /* Do nothing at top level: all such variables are already - viewable. */ - if (global_bindings_p ()) - break; - - for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); - Present (gnat_temp); - gnat_temp = Next (gnat_temp)) - { - gnu_expr = gnat_to_gnu (Expression (gnat_temp)); - if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) - gnu_expr = TREE_OPERAND (gnu_expr, 0); - - gnu_expr = build1 (USE_STMT, void_type_node, gnu_expr); - add_stmt (gnu_expr); - } - break; - - case Pragma_Optimize: - switch (Chars (Expression - (First (Pragma_Argument_Associations (gnat_node))))) - { - case Name_Time: case Name_Space: - if (optimize == 0) - post_error ("insufficient -O value?", gnat_node); - break; - - case Name_Off: - if (optimize != 0) - post_error ("must specify -O0?", gnat_node); - break; - - default: - gigi_abort (331); - break; - } - break; - - case Pragma_Reviewable: - if (write_symbols == NO_DEBUG) - post_error ("must specify -g?", gnat_node); - break; - } + Pragma_to_gnu (gnat_node); break; /**************************************/ @@ -1003,659 +2802,88 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type, gnu_result, gnu_expr); } - break; - - case N_Selected_Component: - { - tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); - Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); - Entity_Id gnat_pref_type = Etype (Prefix (gnat_node)); - tree gnu_field; - - while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind) - || IN (Ekind (gnat_pref_type), Access_Kind)) - { - if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)) - gnat_pref_type = Underlying_Type (gnat_pref_type); - else if (IN (Ekind (gnat_pref_type), Access_Kind)) - gnat_pref_type = Designated_Type (gnat_pref_type); - } - - gnu_prefix = maybe_implicit_deref (gnu_prefix); - - /* For discriminant references in tagged types always substitute the - corresponding discriminant as the actual selected component. */ - - if (Is_Tagged_Type (gnat_pref_type)) - while (Present (Corresponding_Discriminant (gnat_field))) - gnat_field = Corresponding_Discriminant (gnat_field); - - /* For discriminant references of untagged types always substitute the - corresponding stored discriminant. */ - - else if (Present (Corresponding_Discriminant (gnat_field))) - gnat_field = Original_Record_Component (gnat_field); - - /* Handle extracting the real or imaginary part of a complex. - The real part is the first field and the imaginary the last. */ - - if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE) - gnu_result = build_unary_op (Present (Next_Entity (gnat_field)) - ? REALPART_EXPR : IMAGPART_EXPR, - NULL_TREE, gnu_prefix); - else - { - gnu_field = gnat_to_gnu_entity (gnat_field, NULL_TREE, 0); - - /* If there are discriminants, the prefix might be - evaluated more than once, which is a problem if it has - side-effects. */ - if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node))) - ? Designated_Type (Etype - (Prefix (gnat_node))) - : Etype (Prefix (gnat_node)))) - gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0); - - gnu_result - = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, - (Nkind (Parent (gnat_node)) - == N_Attribute_Reference)); - } - - if (gnu_result == 0) - gigi_abort (308); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - } - break; - - case N_Attribute_Reference: - { - /* The attribute designator (like an enumeration value). */ - int attribute = Get_Attribute_Id (Attribute_Name (gnat_node)); - int prefix_unused = 0; - tree gnu_prefix; - tree gnu_type; - - /* The Elab_Spec and Elab_Body attributes are special in that - Prefix is a unit, not an object with a GCC equivalent. Similarly - for Elaborated, since that variable isn't otherwise known. */ - if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec) - return (create_subprog_decl - (create_concat_name (Entity (Prefix (gnat_node)), - attribute == Attr_Elab_Body - ? "elabb" : "elabs"), - NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0, gnat_node)); - - gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); - gnu_type = TREE_TYPE (gnu_prefix); - - /* If the input is a NULL_EXPR, make a new one. */ - if (TREE_CODE (gnu_prefix) == NULL_EXPR) - { - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build1 (NULL_EXPR, gnu_result_type, - TREE_OPERAND (gnu_prefix, 0)); - break; - } - - switch (attribute) - { - case Attr_Pos: - case Attr_Val: - /* These are just conversions until since representation - clauses for enumerations are handled in the front end. */ - { - int check_p = Do_Range_Check (First (Expressions (gnat_node))); - - gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = convert_with_check (Etype (gnat_node), gnu_result, - check_p, check_p, 1); - } - break; - - case Attr_Pred: - case Attr_Succ: - /* These just add or subject the constant 1. Representation - clauses for enumerations are handled in the front-end. */ - gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (Do_Range_Check (First (Expressions (gnat_node)))) - { - gnu_expr = protect_multiple_eval (gnu_expr); - gnu_expr - = emit_check - (build_binary_op (EQ_EXPR, integer_type_node, - gnu_expr, - attribute == Attr_Pred - ? TYPE_MIN_VALUE (gnu_result_type) - : TYPE_MAX_VALUE (gnu_result_type)), - gnu_expr, CE_Range_Check_Failed); - } - - gnu_result - = build_binary_op (attribute == Attr_Pred - ? MINUS_EXPR : PLUS_EXPR, - gnu_result_type, gnu_expr, - convert (gnu_result_type, integer_one_node)); - break; - - case Attr_Address: - case Attr_Unrestricted_Access: - - /* Conversions don't change something's address but can cause - us to miss the COMPONENT_REF case below, so strip them off. */ - gnu_prefix - = remove_conversions (gnu_prefix, - ! Must_Be_Byte_Aligned (gnat_node)); - - /* If we are taking 'Address of an unconstrained object, - this is the pointer to the underlying array. */ - gnu_prefix = maybe_unconstrained_array (gnu_prefix); - - /* ... fall through ... */ - - case Attr_Access: - case Attr_Unchecked_Access: - case Attr_Code_Address: - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_unary_op (((attribute == Attr_Address - || attribute == Attr_Unrestricted_Access) - && ! Must_Be_Byte_Aligned (gnat_node)) - ? ATTR_ADDR_EXPR : ADDR_EXPR, - gnu_result_type, gnu_prefix); - - /* For 'Code_Address, find an inner ADDR_EXPR and mark it - so that we don't try to build a trampoline. */ - if (attribute == Attr_Code_Address) - { - for (gnu_expr = gnu_result; - TREE_CODE (gnu_expr) == NOP_EXPR - || TREE_CODE (gnu_expr) == CONVERT_EXPR; - gnu_expr = TREE_OPERAND (gnu_expr, 0)) - TREE_CONSTANT (gnu_expr) = 1; - ; - - if (TREE_CODE (gnu_expr) == ADDR_EXPR) - TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; - } - - break; - - case Attr_Pool_Address: - { - tree gnu_obj_type; - tree gnu_ptr = gnu_prefix; - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* If this is an unconstrained array, we know the object must - have been allocated with the template in front of the object. - So compute the template address.*/ - - if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) - gnu_ptr - = convert (build_pointer_type - (TYPE_OBJECT_RECORD_TYPE - (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), - gnu_ptr); - - gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); - if (TREE_CODE (gnu_obj_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type)) - { - tree gnu_char_ptr_type = build_pointer_type (char_type_node); - tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type)); - tree gnu_byte_offset - = convert (gnu_char_ptr_type, - size_diffop (size_zero_node, gnu_pos)); - - gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr); - gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type, - gnu_ptr, gnu_byte_offset); - } - - gnu_result = convert (gnu_result_type, gnu_ptr); - } - break; - - case Attr_Size: - case Attr_Object_Size: - case Attr_Value_Size: - case Attr_Max_Size_In_Storage_Elements: - - gnu_expr = gnu_prefix; - - /* Remove NOPS from gnu_expr and conversions from gnu_prefix. - We only use GNU_EXPR to see if a COMPONENT_REF was involved. */ - while (TREE_CODE (gnu_expr) == NOP_EXPR) - gnu_expr = TREE_OPERAND (gnu_expr, 0); - - gnu_prefix = remove_conversions (gnu_prefix, 1); - prefix_unused = 1; - gnu_type = TREE_TYPE (gnu_prefix); - - /* Replace an unconstrained array type with the type of the - underlying array. We can't do this with a call to - maybe_unconstrained_array since we may have a TYPE_DECL. - For 'Max_Size_In_Storage_Elements, use the record type - that will be used to allocate the object and its template. */ - - if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - { - gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); - if (attribute != Attr_Max_Size_In_Storage_Elements) - gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))); - } - - /* If we are looking for the size of a field, return the - field size. Otherwise, if the prefix is an object, - or if 'Object_Size or 'Max_Size_In_Storage_Elements has - been specified, the result is the GCC size of the type. - Otherwise, the result is the RM_Size of the type. */ - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); - else if (TREE_CODE (gnu_prefix) != TYPE_DECL - || attribute == Attr_Object_Size - || attribute == Attr_Max_Size_In_Storage_Elements) - { - /* If this is a padded type, the GCC size isn't relevant - to the programmer. Normally, what we want is the RM_Size, - which was set from the specified size, but if it was not - set, we want the size of the relevant field. Using the MAX - of those two produces the right result in all case. Don't - use the size of the field if it's a self-referential type, - since that's never what's wanted. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_type) - && TREE_CODE (gnu_expr) == COMPONENT_REF) - { - gnu_result = rm_size (gnu_type); - if (! (CONTAINS_PLACEHOLDER_P - (DECL_SIZE (TREE_OPERAND (gnu_expr, 1))))) - gnu_result - = size_binop (MAX_EXPR, gnu_result, - DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); - } - else - gnu_result = TYPE_SIZE (gnu_type); - } - else - gnu_result = rm_size (gnu_type); - - if (gnu_result == 0) - gigi_abort (325); - - /* Deal with a self-referential size by returning the maximum - size for a type and by qualifying the size with - the object for 'Size of an object. */ - - if (CONTAINS_PLACEHOLDER_P (gnu_result)) - { - if (TREE_CODE (gnu_prefix) != TYPE_DECL) - gnu_result = substitute_placeholder_in_expr (gnu_result, - gnu_expr); - else - gnu_result = max_size (gnu_result, 1); - } - - /* If the type contains a template, subtract the size of the - template. */ - if (TREE_CODE (gnu_type) == RECORD_TYPE - && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) - gnu_result = size_binop (MINUS_EXPR, gnu_result, - DECL_SIZE (TYPE_FIELDS (gnu_type))); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - /* Always perform division using unsigned arithmetic as the - size cannot be negative, but may be an overflowed positive - value. This provides correct results for sizes up to 512 MB. - ??? Size should be calculated in storage elements directly. */ - - if (attribute == Attr_Max_Size_In_Storage_Elements) - gnu_result = convert (sizetype, - fold (build (CEIL_DIV_EXPR, bitsizetype, - gnu_result, - bitsize_unit_node))); - break; - - case Attr_Alignment: - if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) - gnu_prefix = TREE_OPERAND (gnu_prefix, 0); - - gnu_type = TREE_TYPE (gnu_prefix); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - prefix_unused = 1; - - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - gnu_result - = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))); - else - gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT); - break; - - case Attr_First: - case Attr_Last: - case Attr_Range_Length: - prefix_unused = 1; - - if (INTEGRAL_TYPE_P (gnu_type) - || TREE_CODE (gnu_type) == REAL_TYPE) - { - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (attribute == Attr_First) - gnu_result = TYPE_MIN_VALUE (gnu_type); - else if (attribute == Attr_Last) - gnu_result = TYPE_MAX_VALUE (gnu_type); - else - gnu_result - = build_binary_op - (MAX_EXPR, get_base_type (gnu_result_type), - build_binary_op - (PLUS_EXPR, get_base_type (gnu_result_type), - build_binary_op (MINUS_EXPR, - get_base_type (gnu_result_type), - convert (gnu_result_type, - TYPE_MAX_VALUE (gnu_type)), - convert (gnu_result_type, - TYPE_MIN_VALUE (gnu_type))), - convert (gnu_result_type, integer_one_node)), - convert (gnu_result_type, integer_zero_node)); - - break; - } - /* ... fall through ... */ - case Attr_Length: - { - int Dimension - = (Present (Expressions (gnat_node)) - ? UI_To_Int (Intval (First (Expressions (gnat_node)))) - : 1); - - /* Make sure any implicit dereference gets done. */ - gnu_prefix = maybe_implicit_deref (gnu_prefix); - gnu_prefix = maybe_unconstrained_array (gnu_prefix); - gnu_type = TREE_TYPE (gnu_prefix); - prefix_unused = 1; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - - if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) - { - int ndim; - tree gnu_type_temp; - - for (ndim = 1, gnu_type_temp = gnu_type; - TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); - ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) - ; - - Dimension = ndim + 1 - Dimension; - } - - for (; Dimension > 1; Dimension--) - gnu_type = TREE_TYPE (gnu_type); - - if (TREE_CODE (gnu_type) != ARRAY_TYPE) - gigi_abort (309); - - if (attribute == Attr_First) - gnu_result - = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); - else if (attribute == Attr_Last) - gnu_result - = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); - else - /* 'Length or 'Range_Length. */ - { - tree gnu_compute_type - = gnat_signed_or_unsigned_type - (0, get_base_type (gnu_result_type)); - - gnu_result - = build_binary_op - (MAX_EXPR, gnu_compute_type, - build_binary_op - (PLUS_EXPR, gnu_compute_type, - build_binary_op - (MINUS_EXPR, gnu_compute_type, - convert (gnu_compute_type, - TYPE_MAX_VALUE - (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))), - convert (gnu_compute_type, - TYPE_MIN_VALUE - (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))), - convert (gnu_compute_type, integer_one_node)), - convert (gnu_compute_type, integer_zero_node)); - } - - /* If this has a PLACEHOLDER_EXPR, qualify it by the object - we are handling. Note that these attributes could not - have been used on an unconstrained array type. */ - gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, - gnu_prefix); - - break; - } - - case Attr_Bit_Position: - case Attr_Position: - case Attr_First_Bit: - case Attr_Last_Bit: - case Attr_Bit: - { - HOST_WIDE_INT bitsize; - HOST_WIDE_INT bitpos; - tree gnu_offset; - tree gnu_field_bitpos; - tree gnu_field_offset; - tree gnu_inner; - enum machine_mode mode; - int unsignedp, volatilep; - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_prefix = remove_conversions (gnu_prefix, 1); - prefix_unused = 1; - - /* We can have 'Bit on any object, but if it isn't a - COMPONENT_REF, the result is zero. Do not allow - 'Bit on a bare component, though. */ - if (attribute == Attr_Bit - && TREE_CODE (gnu_prefix) != COMPONENT_REF - && TREE_CODE (gnu_prefix) != FIELD_DECL) - { - gnu_result = integer_zero_node; - break; - } - - else if (TREE_CODE (gnu_prefix) != COMPONENT_REF - && ! (attribute == Attr_Bit_Position - && TREE_CODE (gnu_prefix) == FIELD_DECL)) - gigi_abort (310); - - get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, - &mode, &unsignedp, &volatilep); - - if (TREE_CODE (gnu_prefix) == COMPONENT_REF) - { - gnu_field_bitpos - = bit_position (TREE_OPERAND (gnu_prefix, 1)); - gnu_field_offset - = byte_position (TREE_OPERAND (gnu_prefix, 1)); - - for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); - TREE_CODE (gnu_inner) == COMPONENT_REF - && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); - gnu_inner = TREE_OPERAND (gnu_inner, 0)) - { - gnu_field_bitpos - = size_binop (PLUS_EXPR, gnu_field_bitpos, - bit_position (TREE_OPERAND (gnu_inner, - 1))); - gnu_field_offset - = size_binop (PLUS_EXPR, gnu_field_offset, - byte_position (TREE_OPERAND (gnu_inner, - 1))); - } - } - else if (TREE_CODE (gnu_prefix) == FIELD_DECL) - { - gnu_field_bitpos = bit_position (gnu_prefix); - gnu_field_offset = byte_position (gnu_prefix); - } - else - { - gnu_field_bitpos = bitsize_zero_node; - gnu_field_offset = size_zero_node; - } - - switch (attribute) - { - case Attr_Position: - gnu_result = gnu_field_offset; - break; - - case Attr_First_Bit: - case Attr_Bit: - gnu_result = size_int (bitpos % BITS_PER_UNIT); - break; - - case Attr_Last_Bit: - gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); - gnu_result - = size_binop (PLUS_EXPR, gnu_result, - TYPE_SIZE (TREE_TYPE (gnu_prefix))); - gnu_result = size_binop (MINUS_EXPR, gnu_result, - bitsize_one_node); - break; - - case Attr_Bit_Position: - gnu_result = gnu_field_bitpos; - break; - } - - /* If this has a PLACEHOLDER_EXPR, qualify it by the object - we are handling. */ - gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, - gnu_prefix); - - break; - } - - case Attr_Min: - case Attr_Max: - gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); - gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); + break; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = build_binary_op (attribute == Attr_Min - ? MIN_EXPR : MAX_EXPR, - gnu_result_type, gnu_lhs, gnu_rhs); - break; + case N_Selected_Component: + { + tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); + Entity_Id gnat_pref_type = Etype (Prefix (gnat_node)); + tree gnu_field; - case Attr_Passed_By_Reference: - gnu_result = size_int (default_pass_by_ref (gnu_type) - || must_pass_by_ref (gnu_type)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; + while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind) + || IN (Ekind (gnat_pref_type), Access_Kind)) + { + if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)) + gnat_pref_type = Underlying_Type (gnat_pref_type); + else if (IN (Ekind (gnat_pref_type), Access_Kind)) + gnat_pref_type = Designated_Type (gnat_pref_type); + } - case Attr_Component_Size: - if (TREE_CODE (gnu_prefix) == COMPONENT_REF - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) - gnu_prefix = TREE_OPERAND (gnu_prefix, 0); + gnu_prefix = maybe_implicit_deref (gnu_prefix); - gnu_prefix = maybe_implicit_deref (gnu_prefix); - gnu_type = TREE_TYPE (gnu_prefix); + /* For discriminant references in tagged types always substitute the + corresponding discriminant as the actual selected component. */ - if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) - gnu_type - = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); + if (Is_Tagged_Type (gnat_pref_type)) + while (Present (Corresponding_Discriminant (gnat_field))) + gnat_field = Corresponding_Discriminant (gnat_field); - while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) - gnu_type = TREE_TYPE (gnu_type); + /* For discriminant references of untagged types always substitute the + corresponding stored discriminant. */ - if (TREE_CODE (gnu_type) != ARRAY_TYPE) - gigi_abort (330); + else if (Present (Corresponding_Discriminant (gnat_field))) + gnat_field = Original_Record_Component (gnat_field); - /* Note this size cannot be self-referential. */ - gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - prefix_unused = 1; - break; + /* Handle extracting the real or imaginary part of a complex. + The real part is the first field and the imaginary the last. */ - case Attr_Null_Parameter: - /* This is just a zero cast to the pointer type for - our prefix and dereferenced. */ - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result - = build_unary_op (INDIRECT_REF, NULL_TREE, - convert (build_pointer_type (gnu_result_type), - integer_zero_node)); - TREE_PRIVATE (gnu_result) = 1; - break; + if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE) + gnu_result = build_unary_op (Present (Next_Entity (gnat_field)) + ? REALPART_EXPR : IMAGPART_EXPR, + NULL_TREE, gnu_prefix); + else + { + gnu_field = gnat_to_gnu_entity (gnat_field, NULL_TREE, 0); - case Attr_Mechanism_Code: - { - int code; - Entity_Id gnat_obj = Entity (Prefix (gnat_node)); + /* If there are discriminants, the prefix might be + evaluated more than once, which is a problem if it has + side-effects. */ + if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node))) + ? Designated_Type (Etype + (Prefix (gnat_node))) + : Etype (Prefix (gnat_node)))) + gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0); - prefix_unused = 1; - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - if (Present (Expressions (gnat_node))) - { - int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); + gnu_result + = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, + (Nkind (Parent (gnat_node)) + == N_Attribute_Reference)); + } - for (gnat_obj = First_Formal (gnat_obj); i > 1; - i--, gnat_obj = Next_Formal (gnat_obj)) - ; - } + if (gnu_result == 0) + gigi_abort (308); - code = Mechanism (gnat_obj); - if (code == Default) - code = ((present_gnu_tree (gnat_obj) - && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) - || ((TREE_CODE (get_gnu_tree (gnat_obj)) - == PARM_DECL) - && (DECL_BY_COMPONENT_PTR_P - (get_gnu_tree (gnat_obj)))))) - ? By_Reference : By_Copy); - gnu_result = convert (gnu_result_type, size_int (- code)); - } - break; + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + } + break; - default: - /* Say we have an unimplemented attribute. Then set the - value to be returned to be a zero and hope that's something - we can convert to the type of this attribute. */ + case N_Attribute_Reference: + { + /* The attribute designator (like an enumeration value). */ + int attribute = Get_Attribute_Id (Attribute_Name (gnat_node)); - post_error ("unimplemented attribute", gnat_node); - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - gnu_result = integer_zero_node; - break; - } + /* The Elab_Spec and Elab_Body attributes are special in that + Prefix is a unit, not an object with a GCC equivalent. Similarly + for Elaborated, since that variable isn't otherwise known. */ + if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec) + return (create_subprog_decl + (create_concat_name (Entity (Prefix (gnat_node)), + attribute == Attr_Elab_Body + ? "elabb" : "elabs"), + NULL_TREE, void_ftype, NULL_TREE, 0, 1, 1, 0, gnat_node)); - /* If this is an attribute where the prefix was unused, - force a use of it if it has a side-effect. But don't do it if - the prefix is just an entity name. However, if an access check - is needed, we must do it. See second example in AARM 11.6(5.e). */ - if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix) - && ! Is_Entity_Name (Prefix (gnat_node))) - gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result), - gnu_prefix, gnu_result)); + gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute); } break; @@ -2114,253 +3342,11 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Case_Statement: - { - Node_Id gnat_when; - - gnu_expr = gnat_to_gnu (Expression (gnat_node)); - gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); - - /* The range of values in a case statement is determined by the - rules in RM 5.4(7-9). In almost all cases, this range is - represented by the Etype of the expression. One exception arises - in the case of a simple name that is parenthesized. This still - has the Etype of the name, but since it is not a name, para 7 - does not apply, and we need to go to the base type. This is the - only case where parenthesization affects the dynamic semantics - (i.e. the range of possible values at runtime that is covered by - the others alternative. - - Another exception is if the subtype of the expression is - non-static. In that case, we also have to use the base type. */ - if (Paren_Count (Expression (gnat_node)) != 0 - || !Is_OK_Static_Subtype (Underlying_Type - (Etype (Expression (gnat_node))))) - gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); - - /* We build a SWITCH_EXPR that contains the code with interspersed - CASE_LABEL_EXPRs for each label. */ - - push_stack (&gnu_switch_label_stack, NULL_TREE, - create_artificial_label ()); - start_stmt_group (); - for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); - Present (gnat_when); - gnat_when = Next_Non_Pragma (gnat_when)) - { - Node_Id gnat_choice; - - /* First compile all the different case choices for the current - WHEN alternative. */ - for (gnat_choice = First (Discrete_Choices (gnat_when)); - Present (gnat_choice); gnat_choice = Next (gnat_choice)) - { - tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; - - switch (Nkind (gnat_choice)) - { - case N_Range: - gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); - gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); - break; - - case N_Subtype_Indication: - gnu_low = gnat_to_gnu (Low_Bound - (Range_Expression - (Constraint (gnat_choice)))); - gnu_high = gnat_to_gnu (High_Bound - (Range_Expression - (Constraint (gnat_choice)))); - break; - - case N_Identifier: - case N_Expanded_Name: - /* This represents either a subtype range or a static value - of some kind; Ekind says which. If a static value, - fall through to the next case. */ - if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) - { - tree gnu_type - = get_unpadded_type (Entity (gnat_choice)); - - gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); - gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); - break; - } - - /* ... fall through ... */ - case N_Character_Literal: - case N_Integer_Literal: - gnu_low = gnat_to_gnu (gnat_choice); - break; - - case N_Others_Choice: - break; - - default: - gigi_abort (316); - } - - add_stmt_with_node (build (CASE_LABEL_EXPR, void_type_node, - gnu_low, gnu_high, - create_artificial_label ()), - gnat_choice); - } - - /* Push a binding level here in case variables are declared since - we want them to be local to this set of statements instead of - the block containing the Case statement. */ - add_stmt (build_stmt_group (Statements (gnat_when), true)); - add_stmt (build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); - - } - - /* Now emit a definition of the label all the cases branched to. */ - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); - gnu_result = build (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, - end_stmt_group (), NULL_TREE); - pop_stack (&gnu_switch_label_stack); - break; - } + gnu_result = Case_Statement_to_gnu (gnat_node); + break; case N_Loop_Statement: - { - /* ??? It would be nice to use "build" here, but there's no build5. */ - tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE); - tree gnu_loop_var = NULL_TREE; - Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); - tree gnu_cond_expr = NULL_TREE; - - TREE_TYPE (gnu_loop_stmt) = void_type_node; - TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; - LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label (); - annotate_with_node (gnu_loop_stmt, gnat_node); - - /* Save the end label of this LOOP_STMT in a stack so that the - corresponding N_Exit_Statement can find it. */ - push_stack (&gnu_loop_label_stack, NULL_TREE, - LOOP_STMT_LABEL (gnu_loop_stmt)); - - /* Set the condition that under which the loop should continue. - For "LOOP .... END LOOP;" the condition is always true. */ - if (No (gnat_iter_scheme)) - ; - /* The case "WHILE condition LOOP ..... END LOOP;" */ - else if (Present (Condition (gnat_iter_scheme))) - LOOP_STMT_TOP_COND (gnu_loop_stmt) - = gnat_to_gnu (Condition (gnat_iter_scheme)); - else - { - /* We have an iteration scheme. */ - Node_Id gnat_loop_spec - = Loop_Parameter_Specification (gnat_iter_scheme); - Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); - Entity_Id gnat_type = Etype (gnat_loop_var); - tree gnu_type = get_unpadded_type (gnat_type); - tree gnu_low = TYPE_MIN_VALUE (gnu_type); - tree gnu_high = TYPE_MAX_VALUE (gnu_type); - int reversep = Reverse_Present (gnat_loop_spec); - tree gnu_first = reversep ? gnu_high : gnu_low; - tree gnu_last = reversep ? gnu_low : gnu_high; - enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR; - tree gnu_base_type = get_base_type (gnu_type); - tree gnu_limit - = (reversep ? TYPE_MIN_VALUE (gnu_base_type) - : TYPE_MAX_VALUE (gnu_base_type)); - - /* We know the loop variable will not overflow if GNU_LAST is - a constant and is not equal to GNU_LIMIT. If it might - overflow, we have to move the limit test to the end of - the loop. In that case, we have to test for an - empty loop outside the loop. */ - if (TREE_CODE (gnu_last) != INTEGER_CST - || TREE_CODE (gnu_limit) != INTEGER_CST - || tree_int_cst_equal (gnu_last, gnu_limit)) - { - gnu_cond_expr - = build (COND_EXPR, void_type_node, - build_binary_op (LE_EXPR, integer_type_node, - gnu_low, gnu_high), - NULL_TREE, alloc_stmt_list ()); - annotate_with_node (gnu_cond_expr, gnat_loop_spec); - } - - /* Open a new nesting level that will surround the loop to declare - the loop index variable. */ - start_stmt_group (); - gnat_pushlevel (); - - /* Declare the loop index and set it to its initial value. */ - gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); - if (DECL_BY_REF_P (gnu_loop_var)) - gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_loop_var); - - /* The loop variable might be a padded type, so use `convert' to - get a reference to the inner variable if so. */ - gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var); - - /* Set either the top or bottom exit condition as - appropriate depending on whether we know an overflow - cannot occur or not. */ - if (gnu_cond_expr) - LOOP_STMT_BOT_COND (gnu_loop_stmt) - = build_binary_op (NE_EXPR, integer_type_node, - gnu_loop_var, gnu_last); - else - LOOP_STMT_TOP_COND (gnu_loop_stmt) - = build_binary_op (end_code, integer_type_node, - gnu_loop_var, gnu_last); - - LOOP_STMT_UPDATE (gnu_loop_stmt) - = build_binary_op (reversep ? PREDECREMENT_EXPR - : PREINCREMENT_EXPR, - TREE_TYPE (gnu_loop_var), - gnu_loop_var, - convert (TREE_TYPE (gnu_loop_var), - integer_one_node)); - annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt), - gnat_iter_scheme); - } - - /* If the loop was named, have the name point to this loop. In this case, - the association is not a ..._DECL node, but the end label from this - LOOP_STMT. */ - if (Present (Identifier (gnat_node))) - save_gnu_tree (Entity (Identifier (gnat_node)), - LOOP_STMT_LABEL (gnu_loop_stmt), 1); - - /* Make the loop body into its own block, so any allocated storage - will be released every iteration. This is needed for stack - allocation. */ - LOOP_STMT_BODY (gnu_loop_stmt) - = build_stmt_group (Statements (gnat_node), true); - - /* If we declared a variable, then we are in a statement group for - that declaration. Add the LOOP_STMT to it and make that the - "loop". */ - if (gnu_loop_var) - { - add_stmt (gnu_loop_stmt); - gnat_poplevel (); - gnu_loop_stmt = end_stmt_group (); - } - - /* If we have an outer COND_EXPR, that's our result and this loop - is its "true" statement. Otherwise, the result is the LOOP_STMT. */ - if (gnu_cond_expr) - { - COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; - gnu_result = gnu_cond_expr; - recalculate_side_effects (gnu_cond_expr); - } - else - gnu_result = gnu_loop_stmt; - - pop_stack (&gnu_loop_label_stack); - } + gnu_result = Loop_Statement_to_gnu (gnat_node); break; case N_Block_Statement: @@ -2522,643 +3508,13 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Subprogram_Body: - { - /* Save debug output mode in case it is reset. */ - enum debug_info_type save_write_symbols = write_symbols; - const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks; - /* Definining identifier of a parameter to the subprogram. */ - Entity_Id gnat_param; - /* The defining identifier for the subprogram body. Note that if a - specification has appeared before for this body, then the identifier - occurring in that specification will also be a defining identifier - and all the calls to this subprogram will point to that - specification. */ - Entity_Id gnat_subprog_id - = (Present (Corresponding_Spec (gnat_node)) - ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); - - /* The FUNCTION_DECL node corresponding to the subprogram spec. */ - tree gnu_subprog_decl; - /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ - tree gnu_subprog_type; - tree gnu_cico_list; - - /* If this is a generic object or if it has been eliminated, - ignore it. */ - if (Ekind (gnat_subprog_id) == E_Generic_Procedure - || Ekind (gnat_subprog_id) == E_Generic_Function - || Is_Eliminated (gnat_subprog_id)) - return alloc_stmt_list (); - - /* If debug information is suppressed for the subprogram, turn debug - mode off for the duration of processing. */ - if (!Needs_Debug_Info (gnat_subprog_id)) - { - write_symbols = NO_DEBUG; - debug_hooks = &do_nothing_debug_hooks; - } - - /* If this subprogram acts as its own spec, define it. Otherwise, - just get the already-elaborated tree node. However, if this - subprogram had its elaboration deferred, we will already have made - a tree node for it. So treat it as not being defined in that - case. Such a subprogram cannot have an address clause or a freeze - node, so this test is safe, though it does disable some - otherwise-useful error checking. */ - gnu_subprog_decl - = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, - Acts_As_Spec (gnat_node) - && ! present_gnu_tree (gnat_subprog_id)); - - gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); - - /* Set the line number in the decl to correspond to that of - the body so that the line number notes are written - correctly. */ - Sloc_to_locus (Sloc (gnat_node), - &DECL_SOURCE_LOCATION (gnu_subprog_decl)); - - begin_subprog_body (gnu_subprog_decl); - - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - - /* If there are OUT parameters, we need to ensure that the return - statement properly copies them out. We do this by making a new - block and converting any inner return into a goto to a label at - the end of the block. */ - push_stack (&gnu_return_label_stack, NULL_TREE, - gnu_cico_list ? create_artificial_label () : NULL_TREE); - - /* Get a tree corresponding to the code for the subprogram. */ - start_stmt_group (); - gnat_pushlevel (); - - /* See if there are any parameters for which we don't yet have - GCC entities. These must be for OUT parameters for which we - will be making VAR_DECL nodes here. Fill them in to - TYPE_CI_CO_LIST, which must contain the empty entry as well. - We can match up the entries because TYPE_CI_CO_LIST is in the - order of the parameters. */ - for (gnat_param = First_Formal (gnat_subprog_id); - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param)) - if (!present_gnu_tree (gnat_param)) - { - /* Skip any entries that have been already filled in; they - must correspond to IN OUT parameters. */ - for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0; - gnu_cico_list = TREE_CHAIN (gnu_cico_list)) - ; - - /* Do any needed references for padded types. */ - TREE_VALUE (gnu_cico_list) - = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)), - gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); - } - - process_decls (Declarations (gnat_node), Empty, Empty, 1, 1); - - /* Generate the code of the subprogram itself. A return statement - will be present and any OUT parameters will be handled there. */ - add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - gnat_poplevel (); - gnu_result = end_stmt_group (); - - /* If we made a special return label, we need to make a block that - contains the definition of that label and the copying to the - return value. That block first contains the function, then - the label and copy statement. */ - if (TREE_VALUE (gnu_return_label_stack) != 0) - { - tree gnu_retval; - - start_stmt_group (); - gnat_pushlevel (); - add_stmt (gnu_result); - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack))); - - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - if (list_length (gnu_cico_list) == 1) - gnu_retval = TREE_VALUE (gnu_cico_list); - else - gnu_retval - = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), - gnu_cico_list); - - if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval)) - gnu_retval - = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval); - - add_stmt_with_node - (build1 (RETURN_EXPR, void_type_node, - build (MODIFY_EXPR, TREE_TYPE (gnu_retval), - DECL_RESULT (current_function_decl), - gnu_retval)), - gnat_node); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - - pop_stack (&gnu_return_label_stack); - - /* Initialize the information node for the function and set the - end location. */ - allocate_struct_function (current_function_decl); - Sloc_to_locus - ((Present (End_Label (Handled_Statement_Sequence (gnat_node))) - ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node))) - : Sloc (gnat_node)), - &cfun->function_end_locus); - - end_subprog_body (gnu_result); - - /* Disconnect the trees for parameters that we made variables for - from the GNAT entities since these will become unusable after - we end the function. */ - for (gnat_param = First_Formal (gnat_subprog_id); - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param)) - if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL) - save_gnu_tree (gnat_param, NULL_TREE, 0); - - mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node))); - write_symbols = save_write_symbols; - debug_hooks = save_debug_hooks; - gnu_result = alloc_stmt_list (); - } + Subprogram_Body_to_gnu (gnat_node); + gnu_result = alloc_stmt_list (); break; case N_Function_Call: case N_Procedure_Call_Statement: - { - /* The GCC node corresponding to the GNAT subprogram name. This can - either be a FUNCTION_DECL node if we are dealing with a standard - subprogram call, or an indirect reference expression (an - INDIRECT_REF node) pointing to a subprogram. */ - tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); - /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ - tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); - tree gnu_subprog_addr - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node); - Entity_Id gnat_formal; - Node_Id gnat_actual; - tree gnu_actual_list = NULL_TREE; - tree gnu_name_list = NULL_TREE; - tree gnu_before_list = NULL_TREE; - tree gnu_after_list = NULL_TREE; - tree gnu_subprog_call; - - switch (Nkind (Name (gnat_node))) - { - case N_Identifier: - case N_Operator_Symbol: - case N_Expanded_Name: - case N_Attribute_Reference: - if (Is_Eliminated (Entity (Name (gnat_node)))) - Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node))); - } - - if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE) - gigi_abort (317); - - /* If we are calling a stubbed function, make this into a - raise of Program_Error. Elaborate all our args first. */ - - if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL - && DECL_STUBBED_P (gnu_subprog_node)) - { - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_actual = Next_Actual (gnat_actual)) - add_stmt (gnat_to_gnu (gnat_actual)); - - if (Nkind (gnat_node) == N_Function_Call) - { - gnu_result_type = TREE_TYPE (gnu_subprog_type); - gnu_result - = build1 (NULL_EXPR, gnu_result_type, - build_call_raise (PE_Stubbed_Subprogram_Called)); - } - else - gnu_result = build_call_raise (PE_Stubbed_Subprogram_Called); - break; - } - - /* The only way we can be making a call via an access type is - if Name is an explicit dereference. In that case, get the - list of formal args from the type the access type is pointing - to. Otherwise, get the formals from entity being called. */ - if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) - gnat_formal = First_Formal (Etype (Name (gnat_node))); - else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) - /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ - gnat_formal = 0; - else - gnat_formal = First_Formal (Entity (Name (gnat_node))); - - /* Create the list of the actual parameters as GCC expects it, namely - a chain of TREE_LIST nodes in which the TREE_VALUE field of each - node is a parameter-expression and the TREE_PURPOSE field is - null. Skip OUT parameters that are not passed by reference and - don't need to be copied in. */ - - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_formal = Next_Formal_With_Extras (gnat_formal), - gnat_actual = Next_Actual (gnat_actual)) - { - tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); - /* We treat a conversion between aggregate types as if it - is an unchecked conversion. */ - int unchecked_convert_p - = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion - || (Nkind (gnat_actual) == N_Type_Conversion - && Is_Composite_Type (Underlying_Type - (Etype (gnat_formal))))); - Node_Id gnat_name - = unchecked_convert_p ? Expression (gnat_actual) : gnat_actual; - tree gnu_name = gnat_to_gnu (gnat_name); - tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)); - tree gnu_actual; - - /* If it's possible we may need to use this expression twice, - make sure than any side-effects are handled via SAVE_EXPRs. - Likewise if we need to force side-effects before the call. - ??? This is more conservative than we need since we don't - need to do this for pass-by-ref with no conversion. - If we are passing a non-addressable Out or In Out parameter by - reference, pass the address of a copy and set up to copy back - out after the call. */ - - if (Ekind (gnat_formal) != E_In_Parameter) - { - gnu_name = gnat_stabilize_reference (gnu_name, 1); - if (! addressable_p (gnu_name) - && present_gnu_tree (gnat_formal) - && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) - || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && (DECL_BY_COMPONENT_PTR_P - (get_gnu_tree (gnat_formal)) - || DECL_BY_DESCRIPTOR_P - (get_gnu_tree (gnat_formal)))))) - { - tree gnu_copy = gnu_name; - tree gnu_temp; - - /* Remove any unpadding on the actual and make a copy. - But if the actual is a left-justified modular type, - first convert to it. */ - if (TREE_CODE (gnu_name) == COMPONENT_REF - && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0))) - == RECORD_TYPE) - && (TYPE_IS_PADDING_P - (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))) - gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0); - else if (TREE_CODE (gnu_name_type) == RECORD_TYPE - && (TYPE_LEFT_JUSTIFIED_MODULAR_P - (gnu_name_type))) - gnu_name = convert (gnu_name_type, gnu_name); - - gnu_actual = save_expr (gnu_name); - - /* Since we're going to take the address of the SAVE_EXPR, - we don't want it to be marked as unchanging. - So set TREE_ADDRESSABLE. */ - gnu_temp = skip_simple_arithmetic (gnu_actual); - if (TREE_CODE (gnu_temp) == SAVE_EXPR) - { - TREE_ADDRESSABLE (gnu_temp) = 1; - TREE_READONLY (gnu_temp) = 0; - } - - /* Set up to move the copy back to the original. */ - gnu_temp = build (MODIFY_EXPR, TREE_TYPE (gnu_copy), - gnu_copy, gnu_actual); - annotate_with_node (gnu_temp, gnat_actual); - append_to_statement_list (gnu_temp, &gnu_after_list); - } - } - - /* If this was a procedure call, we may not have removed any - padding. So do it here for the part we will use as an - input, if any. */ - gnu_actual = gnu_name; - if (Ekind (gnat_formal) != E_Out_Parameter - && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) - gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), - gnu_actual); - - /* Unless this is an In parameter, we must remove any LJM building - from GNU_NAME. */ - if (Ekind (gnat_formal) != E_In_Parameter - && TREE_CODE (gnu_name) == CONSTRUCTOR - && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE - && TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) - gnu_name - = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), - gnu_name); - - if (Ekind (gnat_formal) != E_Out_Parameter - && ! unchecked_convert_p - && Do_Range_Check (gnat_actual)) - gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); - - /* Do any needed conversions. We need only check for - unchecked conversion since normal conversions will be handled - by just converting to the formal type. */ - if (unchecked_convert_p) - { - gnu_actual - = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), - gnu_actual, - (Nkind (gnat_actual) - == N_Unchecked_Type_Conversion) - && No_Truncation (gnat_actual)); - - /* One we've done the unchecked conversion, we still - must ensure that the object is in range of the formal's - type. */ - if (Ekind (gnat_formal) != E_Out_Parameter - && Do_Range_Check (gnat_actual)) - gnu_actual = emit_range_check (gnu_actual, - Etype (gnat_formal)); - } - else if (TREE_CODE (gnu_actual) != SAVE_EXPR) - /* We may have suppressed a conversion to the Etype of the - actual since the parent is a procedure call. So add the - conversion here. */ - gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), - gnu_actual); - - if (TREE_CODE (gnu_actual) != SAVE_EXPR) - gnu_actual = convert (gnu_formal_type, gnu_actual); - - /* If we have not saved a GCC object for the formal, it means it - is an OUT parameter not passed by reference and that does not - need to be copied in. Otherwise, look at the PARM_DECL to see - if it is passed by reference. */ - if (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && DECL_BY_REF_P (get_gnu_tree (gnat_formal))) - { - if (Ekind (gnat_formal) != E_In_Parameter) - { - gnu_actual = gnu_name; - - /* If we have a padded type, be sure we've removed the - padding. */ - if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)) - && TREE_CODE (gnu_actual) != SAVE_EXPR) - gnu_actual - = convert (get_unpadded_type (Etype (gnat_actual)), - gnu_actual); - } - - /* Otherwise, if we have a non-addressable COMPONENT_REF of a - variable-size type see if it's doing a unpadding operation. - If so, remove that operation since we have no way of - allocating the required temporary. */ - if (TREE_CODE (gnu_actual) == COMPONENT_REF - && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) - && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0))) - == RECORD_TYPE) - && TYPE_IS_PADDING_P (TREE_TYPE - (TREE_OPERAND (gnu_actual, 0))) - && !addressable_p (gnu_actual)) - gnu_actual = TREE_OPERAND (gnu_actual, 0); - - /* The symmetry of the paths to the type of an entity is - broken here since arguments don't know that they will - be passed by ref. */ - gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); - gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, - gnu_actual); - } - else if (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))) - { - gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); - gnu_actual = maybe_implicit_deref (gnu_actual); - gnu_actual = maybe_unconstrained_array (gnu_actual); - - if (TREE_CODE (gnu_formal_type) == RECORD_TYPE - && TYPE_IS_PADDING_P (gnu_formal_type)) - { - gnu_formal_type - = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); - gnu_actual = convert (gnu_formal_type, gnu_actual); - } - - /* Take the address of the object and convert to the - proper pointer type. We'd like to actually compute - the address of the beginning of the array using - an ADDR_EXPR of an ARRAY_REF, but there's a possibility - that the ARRAY_REF might return a constant and we'd - be getting the wrong address. Neither approach is - exactly correct, but this is the most likely to work - in all cases. */ - gnu_actual = convert (gnu_formal_type, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_actual)); - } - else if (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))) - { - /* If arg is 'Null_Parameter, pass zero descriptor. */ - if ((TREE_CODE (gnu_actual) == INDIRECT_REF - || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) - && TREE_PRIVATE (gnu_actual)) - gnu_actual - = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), - integer_zero_node); - else - gnu_actual - = build_unary_op (ADDR_EXPR, NULL_TREE, - fill_vms_descriptor (gnu_actual, - gnat_formal)); - } - else - { - tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual)); - - if (Ekind (gnat_formal) != E_In_Parameter) - gnu_name_list - = chainon (gnu_name_list, - build_tree_list (NULL_TREE, gnu_name)); - - if (! present_gnu_tree (gnat_formal) - || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL) - continue; - - /* If this is 'Null_Parameter, pass a zero even though we are - dereferencing it. */ - else if (TREE_CODE (gnu_actual) == INDIRECT_REF - && TREE_PRIVATE (gnu_actual) - && host_integerp (gnu_actual_size, 1) - && 0 >= compare_tree_int (gnu_actual_size, - BITS_PER_WORD)) - gnu_actual - = unchecked_convert - (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)), - convert (gnat_type_for_size - (tree_low_cst (gnu_actual_size, 1), 1), - integer_zero_node), 0); - else - gnu_actual - = convert (TYPE_MAIN_VARIANT - (DECL_ARG_TYPE (get_gnu_tree (gnat_formal))), - gnu_actual); - } - - gnu_actual_list - = chainon (gnu_actual_list, - build_tree_list (NULL_TREE, gnu_actual)); - } - - gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type), - gnu_subprog_addr, gnu_actual_list, - NULL_TREE); - TREE_SIDE_EFFECTS (gnu_subprog_call) = 1; - - /* If it is a function call, the result is the call expression. */ - if (Nkind (gnat_node) == N_Function_Call) - { - gnu_result = gnu_subprog_call; - - /* If the function returns an unconstrained array or by reference, - we have to de-dereference the pointer. */ - if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type) - || TYPE_RETURNS_BY_REF_P (gnu_subprog_type)) - gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_result); - - gnu_result_type = get_unpadded_type (Etype (gnat_node)); - break; - } - - /* If this is the case where the GNAT tree contains a procedure call - but the Ada procedure has copy in copy out parameters, the special - parameter passing mechanism must be used. */ - else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) - { - /* List of FIELD_DECLs associated with the PARM_DECLs of the copy - in copy out parameters. */ - tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type); - int length = list_length (scalar_return_list); - - if (length > 1) - { - tree gnu_name; - - gnu_subprog_call = protect_multiple_eval (gnu_subprog_call); - - /* If any of the names had side-effects, ensure they are - all evaluated before the call. */ - for (gnu_name = gnu_name_list; gnu_name; - gnu_name = TREE_CHAIN (gnu_name)) - if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name))) - gnu_subprog_call - = build (COMPOUND_EXPR, TREE_TYPE (gnu_subprog_call), - TREE_VALUE (gnu_name), gnu_subprog_call); - } - - if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) - gnat_formal = First_Formal (Etype (Name (gnat_node))); - else - gnat_formal = First_Formal (Entity (Name (gnat_node))); - - for (gnat_actual = First_Actual (gnat_node); - Present (gnat_actual); - gnat_formal = Next_Formal_With_Extras (gnat_formal), - gnat_actual = Next_Actual (gnat_actual)) - /* If we are dealing with a copy in copy out parameter, we must - retrieve its value from the record returned in the function - call. */ - if (! (present_gnu_tree (gnat_formal) - && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) - || ((TREE_CODE (get_gnu_tree (gnat_formal)) - == PARM_DECL) - && ((DECL_BY_COMPONENT_PTR_P - (get_gnu_tree (gnat_formal)) - || (DECL_BY_DESCRIPTOR_P - (get_gnu_tree (gnat_formal)))))))) - && Ekind (gnat_formal) != E_In_Parameter) - { - /* Get the value to assign to this OUT or IN OUT - parameter. It is either the result of the function if - there is only a single such parameter or the appropriate - field from the record returned. */ - tree gnu_result - = length == 1 ? gnu_subprog_call - : build_component_ref - (gnu_subprog_call, NULL_TREE, - TREE_PURPOSE (scalar_return_list), 0); - int unchecked_conversion - = Nkind (gnat_actual) == N_Unchecked_Type_Conversion; - /* If the actual is a conversion, get the inner expression, - which will be the real destination, and convert the - result to the type of the actual parameter. */ - tree gnu_actual - = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); - - /* If the result is a padded type, remove the padding. */ - if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE - && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) - gnu_result - = convert (TREE_TYPE (TYPE_FIELDS - (TREE_TYPE (gnu_result))), - gnu_result); - - /* If the result is a type conversion, do it. */ - if (Nkind (gnat_actual) == N_Type_Conversion) - gnu_result - = convert_with_check - (Etype (Expression (gnat_actual)), gnu_result, - Do_Overflow_Check (gnat_actual), - Do_Range_Check (Expression (gnat_actual)), - Float_Truncate (gnat_actual)); - - else if (unchecked_conversion) - gnu_result - = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result, - No_Truncation (gnat_actual)); - else - { - if (Do_Range_Check (gnat_actual)) - gnu_result = emit_range_check (gnu_result, - Etype (gnat_actual)); - - if (! (! TREE_CONSTANT (TYPE_SIZE - (TREE_TYPE (gnu_actual))) - && TREE_CONSTANT (TYPE_SIZE - (TREE_TYPE (gnu_result))))) - gnu_result = convert (TREE_TYPE (gnu_actual), - gnu_result); - } - - gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, - gnu_actual, gnu_result); - annotate_with_node (gnu_result, gnat_actual); - append_to_statement_list (gnu_result, &gnu_before_list); - scalar_return_list = TREE_CHAIN (scalar_return_list); - gnu_name_list = TREE_CHAIN (gnu_name_list); - } - } - else - { - annotate_with_node (gnu_subprog_call, gnat_node); - append_to_statement_list (gnu_subprog_call, &gnu_before_list); - } - - append_to_statement_list (gnu_after_list, &gnu_before_list); - gnu_result = gnu_before_list; - } + gnu_result = call_to_gnu (gnat_node, &gnu_result_type); break; /*************************/ @@ -3264,20 +3620,7 @@ gnat_to_gnu (Node_Id gnat_node) /***************************/ case N_Handled_Sequence_Of_Statements: - - /* The GCC exception handling mechanism can handle both ZCX and SJLJ - schemes and we have our own SJLJ mechanism. To call the GCC - mechanism, we call add_cleanup, and when we leave the binding, - end_stmt_group will create the TRY_FINALLY_EXPR. - - ??? The region level calls down there have been specifically put in - place for a ZCX context and currently the order in which things are - emitted (region/handlers) is different from the SJLJ case. Instead of - putting other calls with different conditions at other places for the - SJLJ case, it seems cleaner to reorder things for the SJLJ case and - generalize the condition to make it not ZCX specific. */ - - /* If there is an At_End procedure attached to this node, and the eh + /* If there is an At_End procedure attached to this node, and the EH mechanism is SJLJ, we must have at least a corresponding At_End handler, unless the No_Exception_Handlers restriction is set. */ if (! type_annotate_only @@ -3287,370 +3630,14 @@ gnat_to_gnu (Node_Id gnat_node) && ! No_Exception_Handlers_Set()) gigi_abort (335); - { - tree gnu_jmpsave_decl = NULL_TREE; - tree gnu_jmpbuf_decl = NULL_TREE; - /* If just annotating, ignore all EH and cleanups. */ - bool gcc_zcx - = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) - && Exception_Mechanism == GCC_ZCX); - bool setjmp_longjmp - = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) - && Exception_Mechanism == Setjmp_Longjmp); - bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); - bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); - tree gnu_inner_block; /* The statement(s) for the block itself. */ - - /* If there are any exceptions or cleanup processing involved, we need - an outer statement group (for Setjmp_Longjmp) and binding level. */ - if (binding_for_block) - { - start_stmt_group (); - gnat_pushlevel (); - } - - /* If we are to call a function when exiting this block add a cleanup - to the binding level we made above. */ - if (at_end) - add_cleanup (build_call_0_expr - (gnat_to_gnu (At_End_Proc (gnat_node)))); - - /* If using setjmp_longjmp, make the variables for the setjmp - buffer and save area for address of previous buffer. Do this - first since we need to have the setjmp buf known for any decls - in this block. */ - if (setjmp_longjmp) - { - gnu_jmpsave_decl - = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE, - jmpbuf_ptr_type, - build_call_0_expr (get_jmpbuf_decl), - 0, 0, 0, 0, 0, gnat_node); - gnu_jmpbuf_decl - = create_var_decl (get_identifier ("JMP_BUF"), - NULL_TREE, jmpbuf_type, - NULL_TREE, 0, 0, 0, 0, 0, gnat_node); - - set_block_jmpbuf_decl (gnu_jmpbuf_decl); - - /* When we exit this block, restore the saved value. */ - add_cleanup (build_call_1_expr (set_jmpbuf_decl, - gnu_jmpsave_decl)); - } - - /* Now build the tree for the declarations and statements inside this - block. If this is SJLJ, set our jmp_buf as the current buffer. */ - start_stmt_group (); - - if (setjmp_longjmp) - add_stmt (build_call_1_expr - (set_jmpbuf_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, gnu_jmpbuf_decl))); - - - if (Present (First_Real_Statement (gnat_node))) - process_decls (Statements (gnat_node), Empty, - First_Real_Statement (gnat_node), 1, 1); - - /* Generate code for each statement in the block. */ - for (gnat_temp = (Present (First_Real_Statement (gnat_node)) - ? First_Real_Statement (gnat_node) - : First (Statements (gnat_node))); - Present (gnat_temp); gnat_temp = Next (gnat_temp)) - add_stmt (gnat_to_gnu (gnat_temp)); - gnu_inner_block = end_stmt_group (); - - /* Now generate code for the two exception models, if either is - relevant for this block. */ - if (setjmp_longjmp) - { - tree *gnu_else_ptr = 0; - tree gnu_handler; - - /* Make a binding level for the exception handling declarations - and code and set up gnu_except_ptr_stack for the handlers - to use. */ - start_stmt_group (); - gnat_pushlevel (); - - push_stack (&gnu_except_ptr_stack, NULL_TREE, - create_var_decl (get_identifier ("EXCEPT_PTR"), - NULL_TREE, - build_pointer_type (except_type_node), - build_call_0_expr (get_excptr_decl), - 0, 0, 0, 0, 0, gnat_node)); - - /* Generate code for each handler. The N_Exception_Handler case - below does the real work and returns a COND_EXPR for each - handler, which we chain together here. */ - for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); - Present (gnat_temp); - gnat_temp = Next_Non_Pragma (gnat_temp)) - { - gnu_expr = gnat_to_gnu (gnat_temp); - - /* If this is the first one, set it as the outer one. - Otherwise, point the "else" part of the previous handler - to us. Then point to our "else" part. */ - if (!gnu_else_ptr) - add_stmt (gnu_expr); - else - *gnu_else_ptr = gnu_expr; - - gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); - } - - /* If none of the exception handlers did anything, re-raise but - do not defer abortion. */ - gnu_expr = build_call_1_expr (raise_nodefer_decl, - TREE_VALUE (gnu_except_ptr_stack)); - annotate_with_node (gnu_expr, gnat_node); - - if (gnu_else_ptr) - *gnu_else_ptr = gnu_expr; - else - add_stmt (gnu_expr); - - /* End the binding level dedicated to the exception handlers - and get the whole statement group. */ - pop_stack (&gnu_except_ptr_stack); - gnat_poplevel (); - gnu_handler = end_stmt_group (); - - /* If the setjmp returns 1, we restore our incoming longjmp value - and then check the handlers. */ - start_stmt_group (); - add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl, - gnu_jmpsave_decl), - gnat_node); - add_stmt (gnu_handler); - gnu_handler = end_stmt_group (); - - /* This block is now "if (setjmp) ... else ". */ - gnu_result = build (COND_EXPR, void_type_node, - (build_call_1_expr - (setjmp_decl, - build_unary_op (ADDR_EXPR, NULL_TREE, - gnu_jmpbuf_decl))), - gnu_handler, gnu_inner_block); - } - else if (gcc_zcx) - { - tree gnu_handlers; - - /* First make a block containing the handlers. */ - start_stmt_group (); - for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); - Present (gnat_temp); - gnat_temp = Next_Non_Pragma (gnat_temp)) - add_stmt (gnat_to_gnu (gnat_temp)); - gnu_handlers = end_stmt_group (); - - /* Now make the TRY_CATCH_EXPR for the block. */ - gnu_result = build (TRY_CATCH_EXPR, void_type_node, - gnu_inner_block, gnu_handlers); - } - else - gnu_result = gnu_inner_block; - - /* Now close our outer block, if we had to make one. */ - if (binding_for_block) - { - add_stmt (gnu_result); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - } + gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node); break; case N_Exception_Handler: if (Exception_Mechanism == Setjmp_Longjmp) - { - /* Unless this is "Others" or the special "Non-Ada" exception - for Ada, make an "if" statement to select the proper - exceptions. For "Others", exclude exceptions where - Handled_By_Others is nonzero unless the All_Others flag is set. - For "Non-ada", accept an exception if "Lang" is 'V'. */ - tree gnu_choice = integer_zero_node; - tree gnu_body = build_stmt_group (Statements (gnat_node), false); - - for (gnat_temp = First (Exception_Choices (gnat_node)); - gnat_temp; gnat_temp = Next (gnat_temp)) - { - tree this_choice; - - if (Nkind (gnat_temp) == N_Others_Choice) - { - if (All_Others (gnat_temp)) - this_choice = integer_one_node; - else - this_choice - = build_binary_op - (EQ_EXPR, integer_type_node, - convert - (integer_type_node, - build_component_ref - (build_unary_op - (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("not_handled_by_others"), NULL_TREE, - 0)), - integer_zero_node); - } - - else if (Nkind (gnat_temp) == N_Identifier - || Nkind (gnat_temp) == N_Expanded_Name) - { - gnu_expr - = gnat_to_gnu_entity (Entity (gnat_temp), NULL_TREE, 0); - - this_choice - = build_binary_op - (EQ_EXPR, integer_type_node, - TREE_VALUE (gnu_except_ptr_stack), - convert - (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), - build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); - - /* If this is the distinguished exception "Non_Ada_Error" - (and we are in VMS mode), also allow a non-Ada - exception (a VMS condition) to match. */ - if (Is_Non_Ada_Error (Entity (gnat_temp))) - { - tree gnu_comp - = build_component_ref - (build_unary_op - (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), - get_identifier ("lang"), NULL_TREE, 0); - - this_choice - = build_binary_op - (TRUTH_ORIF_EXPR, integer_type_node, - build_binary_op - (EQ_EXPR, integer_type_node, gnu_comp, - convert (TREE_TYPE (gnu_comp), - build_int_2 ('V', 0))), - this_choice); - } - } - else - gigi_abort (318); - - gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, - gnu_choice, this_choice); - } - - gnu_result = build (COND_EXPR, void_type_node, gnu_choice, gnu_body, - NULL_TREE); - } - - /* Tell the back end that we start an exception handler if necessary. */ + gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node); else if (Exception_Mechanism == GCC_ZCX) - { - /* We build a TREE_LIST of nodes representing what exception - types this handler is able to catch, with special cases - for others and all others cases. - - Each exception type is actually identified by a pointer to the - exception id, with special value zero for "others" and one for - "all others". Beware that these special values are known and used - by the personality routine to identify the corresponding specific - kinds of handlers. - - ??? For initial time frame reasons, the others and all_others - cases have been handled using specific type trees, but this - somehow hides information to the back-end, which expects NULL to - be passed for catch all and end_cleanup to be used for cleanups. - - Care should be taken to ensure that the control flow impact of - such clauses is rendered in some way. lang_eh_type_covers is - doing the trick currently. */ - - tree gnu_etypes_list = NULL_TREE; - tree gnu_etype; - tree gnu_current_exc_ptr; - tree gnu_incoming_exc_ptr; - - for (gnat_temp = First (Exception_Choices (gnat_node)); - gnat_temp; gnat_temp = Next (gnat_temp)) - { - if (Nkind (gnat_temp) == N_Others_Choice) - gnu_etype - = All_Others (gnat_temp) ? integer_one_node - : integer_zero_node; - else if (Nkind (gnat_temp) == N_Identifier - || Nkind (gnat_temp) == N_Expanded_Name) - { - Entity_Id gnat_ex_id = Entity (gnat_temp); - - /* Exception may be a renaming. Recover original exception - which is the one elaborated and registered. */ - if (Present (Renamed_Object (gnat_ex_id))) - gnat_ex_id = Renamed_Object (gnat_ex_id); - - gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); - - gnu_etype - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); - - /* The Non_Ada_Error case for VMS exceptions is handled - by the personality routine. */ - } - else - gigi_abort (337); - - /* The GCC interface expects NULL to be passed for catch all - handlers, so it would be quite tempting to set gnu_etypes_list - to NULL if gnu_etype is integer_zero_node. It would not work, - however, because GCC's notion of "catch all" is stronger than - our notion of "others". Until we correctly use the cleanup - interface as well, the doing tht would prevent the "all - others" handlers from beeing seen, because nothing can be - caught beyond a catch all from GCC's point of view. */ - gnu_etypes_list - = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); - } - - start_stmt_group (); - gnat_pushlevel (); - - /* Expand a call to the begin_handler hook at the beginning of the - handler, and arrange for a call to the end_handler hook to occur - on every possible exit path. - - The hooks expect a pointer to the low level occurrence. This is - required for our stack management scheme because a raise inside - the handler pushes a new occurrence on top of the stack, which - means that this top does not necessarily match the occurrence - this handler was dealing with. - - The EXC_PTR_EXPR object references the exception occurrence - beeing propagated. Upon handler entry, this is the exception for - which the handler is triggered. This might not be the case upon - handler exit, however, as we might have a new occurrence - propagated by the handler's body, and the end_handler hook - called as a cleanup in this context. - - We use a local variable to retrieve the incoming value at - handler entry time, and reuse it to feed the end_handler hook's - argument at exit time. */ - gnu_current_exc_ptr = build (EXC_PTR_EXPR, ptr_type_node); - gnu_incoming_exc_ptr - = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, - ptr_type_node, gnu_current_exc_ptr, - 0, 0, 0, 0, 0, gnat_node); - - add_stmt_with_node (build_call_1_expr (begin_handler_decl, - gnu_incoming_exc_ptr), - gnat_node); - add_cleanup (build_call_1_expr (end_handler_decl, - gnu_incoming_exc_ptr)); - add_stmt_list (Statements (gnat_node)); - gnat_poplevel (); - gnu_result = build (CATCH_EXPR, void_type_node, - gnu_etypes_list, end_stmt_group ()); - } + gnu_result = Exception_Handler_to_gnu_zcx (gnat_node); else abort (); -- cgit v1.2.1