REAL_ARITHMETIC (dconstmp5, RDIV_EXPR, dconstm1, dconst2);
}
\f
+/* 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;
+}
+\f
+/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
+ to a GCC tree, which is returned. */
+
+static tree
+Case_Statement_to_gnu (Node_Id gnat_node)
+{
+ tree gnu_result;
+ tree gnu_expr;
+ Node_Id gnat_when;
+
+ gnu_expr = gnat_to_gnu (Expression (gnat_node));
+ gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
+
+ /* The range of values in a case statement is determined by the rules in
+ RM 5.4(7-9). In almost all cases, this range is represented by the Etype
+ of the expression. One exception arises in the case of a simple name that
+ is parenthesized. This still has the Etype of the name, but since it is
+ not a name, para 7 does not apply, and we need to go to the base type.
+ This is the only case where parenthesization affects the dynamic
+ semantics (i.e. the range of possible values at runtime that is covered
+ by the others alternative.
+
+ Another exception is if the subtype of the expression is non-static. In
+ that case, we also have to use the base type. */
+ if (Paren_Count (Expression (gnat_node)) != 0
+ || !Is_OK_Static_Subtype (Underlying_Type
+ (Etype (Expression (gnat_node)))))
+ gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
+
+ /* We build a SWITCH_EXPR that contains the code with interspersed
+ CASE_LABEL_EXPRs for each label. */
+
+ push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ());
+ start_stmt_group ();
+ for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
+ Present (gnat_when);
+ gnat_when = Next_Non_Pragma (gnat_when))
+ {
+ Node_Id gnat_choice;
+
+ /* 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;
+}
+\f
+/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
+ to a GCC tree, which is returned. */
+
+static tree
+Loop_Statement_to_gnu (Node_Id gnat_node)
+{
+ /* ??? It would be nice to use "build" here, but there's no build5. */
+ tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE);
+ tree gnu_loop_var = NULL_TREE;
+ Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
+ tree gnu_cond_expr = NULL_TREE;
+ tree gnu_result;
+
+ TREE_TYPE (gnu_loop_stmt) = void_type_node;
+ TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
+ LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
+ 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;
+}
+\f
+/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
+ don't return anything. */
+
+static void
+Subprogram_Body_to_gnu (Node_Id gnat_node)
+{
+ /* 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;
+}
+\f
+/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
+ or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
+ GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */
+
+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;
+}
+\f
+/* Subroutine of gnat_to_gnu to translate gnat_node, an
+ N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
+
+static tree
+Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
+{
+ tree gnu_jmpsave_decl = NULL_TREE;
+ tree gnu_jmpbuf_decl = NULL_TREE;
+ /* If just annotating, ignore all EH and cleanups. */
+ bool gcc_zcx = (!type_annotate_only
+ && Present (Exception_Handlers (gnat_node))
+ && Exception_Mechanism == 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) ... <handlers> else <block>". */
+ 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;
+}
+\f
+/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
+ to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
+ exception handling. */
+
+static tree
+Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
+{
+ /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
+ an "if" statement to select the proper exceptions. For "Others", exclude
+ exceptions where Handled_By_Others is nonzero unless the All_Others flag
+ is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
+ tree gnu_choice = integer_zero_node;
+ tree gnu_body = build_stmt_group (Statements (gnat_node), false);
+ Node_Id gnat_temp;
+
+ for (gnat_temp = First (Exception_Choices (gnat_node));
+ gnat_temp; gnat_temp = Next (gnat_temp))
+ {
+ tree this_choice;
+
+ if (Nkind (gnat_temp) == N_Others_Choice)
+ {
+ if (All_Others (gnat_temp))
+ this_choice = integer_one_node;
+ else
+ this_choice
+ = build_binary_op
+ (EQ_EXPR, integer_type_node,
+ convert
+ (integer_type_node,
+ build_component_ref
+ (build_unary_op
+ (INDIRECT_REF, NULL_TREE,
+ TREE_VALUE (gnu_except_ptr_stack)),
+ get_identifier ("not_handled_by_others"), NULL_TREE,
+ 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);
+}
+\f
+/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
+ to a GCC tree, which is returned. This is the variant for ZCX. */
+
+static tree
+Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
+{
+ tree gnu_etypes_list = NULL_TREE;
+ tree gnu_expr;
+ tree gnu_etype;
+ tree gnu_current_exc_ptr;
+ tree gnu_incoming_exc_ptr;
+ Node_Id gnat_temp;
+
+ /* We build a TREE_LIST of nodes representing what exception types this
+ handler can catch, with special cases for others and all others cases.
+
+ Each exception type is actually identified by a pointer to the exception
+ id, 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 ());
+}
+\f
/* This function is the driver of the GNAT to GCC tree transformation
process. It is the entry point of the tree transformer. GNAT_NODE is the
root of some GNAT tree. Return the root of the corresponding GCC tree.
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;
went_into_elab_proc = true;
}
-
switch (Nkind (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:
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);
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;
/**************************************/
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;
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:
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;
/*************************/
/***************************/
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
&& ! 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) ... <handlers> else <block>". */
- 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 ();
projects / platform / upstream / gcc.git / commitdiff