1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2004, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
25 ****************************************************************************/
29 #include "coretypes.h"
59 struct Node
*Nodes_Ptr
;
60 Node_Id
*Next_Node_Ptr
;
61 Node_Id
*Prev_Node_Ptr
;
62 struct Elist_Header
*Elists_Ptr
;
63 struct Elmt_Item
*Elmts_Ptr
;
64 struct String_Entry
*Strings_Ptr
;
65 Char_Code
*String_Chars_Ptr
;
66 struct List_Header
*List_Headers_Ptr
;
68 /* Current filename without path. */
69 const char *ref_filename
;
71 /* Flag indicating whether file names are discarded in exception messages */
72 int discard_file_names
;
74 /* If true, then gigi is being called on an analyzed but unexpanded
75 tree, and the only purpose of the call is to properly annotate
76 types with representation information. */
77 int type_annotate_only
;
79 /* List of TREE_LIST nodes representing a block stack. TREE_VALUE
80 of each gives the variable used for the setjmp buffer in the current
81 block, if any. TREE_PURPOSE gives the bottom condition for a loop,
82 if this block is for a loop. The latter is only used to save the tree
86 /* The current BLOCK_STMT node. TREE_CHAIN points to the previous
88 static GTY(()) tree gnu_block_stmt_node
;
90 /* List of unused BLOCK_STMT nodes. */
91 static GTY((deletable
)) tree gnu_block_stmt_free_list
;
93 /* List of TREE_LIST nodes representing a stack of exception pointer
94 variables. TREE_VALUE is the VAR_DECL that stores the address of
95 the raised exception. Nonzero means we are in an exception
96 handler. Not used in the zero-cost case. */
97 static GTY(()) tree gnu_except_ptr_stack
;
99 /* List of TREE_LIST nodes containing pending elaborations lists.
100 used to prevent the elaborations being reclaimed by GC. */
101 static GTY(()) tree gnu_pending_elaboration_lists
;
103 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
104 static enum tree_code gnu_codes
[Number_Node_Kinds
];
106 /* Current node being treated, in case gigi_abort called. */
107 Node_Id error_gnat_node
;
109 /* Variable that stores a list of labels to be used as a goto target instead of
110 a return in some functions. See processing for N_Subprogram_Body. */
111 static GTY(()) tree gnu_return_label_stack
;
113 static tree
tree_transform (Node_Id
);
114 static rtx
first_nondeleted_insn (rtx
);
115 static tree
start_block_stmt (void);
116 static tree
end_block_stmt (bool);
117 static tree
build_block_stmt (List_Id
);
118 static tree
make_expr_stmt_from_rtl (rtx
, Node_Id
);
119 static void elaborate_all_entities (Node_Id
);
120 static void process_freeze_entity (Node_Id
);
121 static void process_inlined_subprograms (Node_Id
);
122 static void process_decls (List_Id
, List_Id
, Node_Id
, int, int);
123 static tree
emit_range_check (tree
, Node_Id
);
124 static tree
emit_index_check (tree
, tree
, tree
, tree
);
125 static tree
emit_check (tree
, tree
, int);
126 static tree
convert_with_check (Entity_Id
, tree
, int, int, int);
127 static int addressable_p (tree
);
128 static tree
assoc_to_constructor (Node_Id
, tree
);
129 static tree
extract_values (tree
, tree
);
130 static tree
pos_to_constructor (Node_Id
, tree
, Entity_Id
);
131 static tree
maybe_implicit_deref (tree
);
132 static tree
gnat_stabilize_reference_1 (tree
, int);
133 static int build_unit_elab (Entity_Id
, int, tree
);
135 /* Constants for +0.5 and -0.5 for float-to-integer rounding. */
136 static REAL_VALUE_TYPE dconstp5
;
137 static REAL_VALUE_TYPE dconstmp5
;
139 /* This is the main program of the back-end. It sets up all the table
140 structures and then generates code. */
143 gigi (Node_Id gnat_root
,
146 struct Node
*nodes_ptr
,
147 Node_Id
*next_node_ptr
,
148 Node_Id
*prev_node_ptr
,
149 struct Elist_Header
*elists_ptr
,
150 struct Elmt_Item
*elmts_ptr
,
151 struct String_Entry
*strings_ptr
,
152 Char_Code
*string_chars_ptr
,
153 struct List_Header
*list_headers_ptr
,
154 Int number_units ATTRIBUTE_UNUSED
,
155 char *file_info_ptr ATTRIBUTE_UNUSED
,
156 Entity_Id standard_integer
,
157 Entity_Id standard_long_long_float
,
158 Entity_Id standard_exception_type
,
159 Int gigi_operating_mode
)
161 tree gnu_standard_long_long_float
;
162 tree gnu_standard_exception_type
;
164 max_gnat_nodes
= max_gnat_node
;
165 number_names
= number_name
;
166 Nodes_Ptr
= nodes_ptr
;
167 Next_Node_Ptr
= next_node_ptr
;
168 Prev_Node_Ptr
= prev_node_ptr
;
169 Elists_Ptr
= elists_ptr
;
170 Elmts_Ptr
= elmts_ptr
;
171 Strings_Ptr
= strings_ptr
;
172 String_Chars_Ptr
= string_chars_ptr
;
173 List_Headers_Ptr
= list_headers_ptr
;
175 type_annotate_only
= (gigi_operating_mode
== 1);
177 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
179 if (type_annotate_only
)
181 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
182 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
185 /* See if we should discard file names in exception messages. */
186 discard_file_names
= Debug_Flag_NN
;
188 if (Nkind (gnat_root
) != N_Compilation_Unit
)
191 set_lineno (gnat_root
, 0);
193 /* Initialize ourselves. */
197 gnat_compute_largest_alignment ();
200 /* Enable GNAT stack checking method if needed */
201 if (!Stack_Check_Probes_On_Target
)
202 set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode
, "_gnat_stack_check"));
204 /* Save the type we made for integer as the type for Standard.Integer.
205 Then make the rest of the standard types. Note that some of these
207 save_gnu_tree (Base_Type (standard_integer
),
208 TYPE_NAME (integer_type_node
), 0);
210 gnu_except_ptr_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
212 REAL_ARITHMETIC (dconstp5
, RDIV_EXPR
, dconst1
, dconst2
);
213 REAL_ARITHMETIC (dconstmp5
, RDIV_EXPR
, dconstm1
, dconst2
);
215 gnu_standard_long_long_float
216 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
217 gnu_standard_exception_type
218 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
220 init_gigi_decls (gnu_standard_long_long_float
, gnu_standard_exception_type
);
222 /* Process any Pragma Ident for the main unit. */
223 #ifdef ASM_OUTPUT_IDENT
224 if (Present (Ident_String (Main_Unit
)))
227 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
230 /* If we are using the GCC exception mechanism, let GCC know. */
231 if (Exception_Mechanism
== GCC_ZCX
)
234 gnat_to_code (gnat_root
);
238 /* This function is the driver of the GNAT to GCC tree transformation process.
239 GNAT_NODE is the root of some gnat tree. It generates code for that
243 gnat_to_code (Node_Id gnat_node
)
247 /* Save node number in case error */
248 error_gnat_node
= gnat_node
;
251 gnu_root
= tree_transform (gnat_node
);
252 gnat_expand_stmt (end_block_stmt (false));
254 /* If we return a statement, generate code for it. */
255 if (IS_STMT (gnu_root
))
257 if (TREE_CODE (gnu_root
) != NULL_STMT
)
258 gnat_expand_stmt (gnu_root
);
260 /* This should just generate code, not return a value. If it returns
261 a value, something is wrong. */
262 else if (gnu_root
!= error_mark_node
)
266 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
267 tree corresponding to that GNAT tree. Normally, no code is generated.
268 We just return an equivalent tree which is used elsewhere to generate
272 gnat_to_gnu (Node_Id gnat_node
)
275 bool made_sequence
= false;
277 /* We support the use of this on statements now as a transition
278 to full function-at-a-time processing. So we need to see if anything
279 we do generates RTL and returns error_mark_node. */
280 if (!global_bindings_p ())
282 do_pending_stack_adjust ();
285 emit_note (NOTE_INSN_DELETED
);
286 made_sequence
= true;
289 /* Save node number in case error */
290 error_gnat_node
= gnat_node
;
293 gnu_root
= tree_transform (gnat_node
);
294 gnat_expand_stmt (end_block_stmt (false));
296 if (gnu_root
== error_mark_node
)
300 if (type_annotate_only
)
306 do_pending_stack_adjust ();
308 gnu_root
= make_expr_stmt_from_rtl (first_nondeleted_insn (get_insns ()),
312 else if (made_sequence
)
316 do_pending_stack_adjust ();
318 insns
= first_nondeleted_insn (get_insns ());
323 /* If we have a statement, we need to first evaluate any RTL we
324 made in the process of building it and then the statement. */
325 if (IS_STMT (gnu_root
))
327 tree gnu_expr_stmt
= make_expr_stmt_from_rtl (insns
, gnat_node
);
329 TREE_CHAIN (gnu_expr_stmt
) = gnu_root
;
330 gnu_root
= build_nt (BLOCK_STMT
, gnu_expr_stmt
, NULL_TREE
);
331 TREE_SLOC (gnu_root
) = Sloc (gnat_node
);
341 /* This function is the driver of the GNAT to GCC tree transformation process.
342 It is the entry point of the tree transformer. GNAT_NODE is the root of
343 some GNAT tree. Return the root of the corresponding GCC tree or
344 error_mark_node to signal that there is no GCC tree to return.
346 The latter is the case if only code generation actions have to be performed
347 like in the case of if statements, loops, etc. This routine is wrapped
348 in the above two routines for most purposes. */
351 tree_transform (Node_Id gnat_node
)
353 tree gnu_result
= error_mark_node
; /* Default to no value. */
354 tree gnu_result_type
= void_type_node
;
356 tree gnu_lhs
, gnu_rhs
;
358 Entity_Id gnat_temp_type
;
360 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
361 set_lineno (gnat_node
, 0);
363 if (IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
364 && type_annotate_only
)
365 return error_mark_node
;
367 /* If this is a Statement and we are at top level, we add the statement
368 as an elaboration for a null tree. That will cause it to be placed
369 in the elaboration procedure. */
370 if (global_bindings_p ()
371 && ((IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
372 && Nkind (gnat_node
) != N_Null_Statement
)
373 || Nkind (gnat_node
) == N_Procedure_Call_Statement
374 || Nkind (gnat_node
) == N_Label
375 || (Nkind (gnat_node
) == N_Handled_Sequence_Of_Statements
376 && (Present (Exception_Handlers (gnat_node
))
377 || Present (At_End_Proc (gnat_node
))))
378 || ((Nkind (gnat_node
) == N_Raise_Constraint_Error
379 || Nkind (gnat_node
) == N_Raise_Storage_Error
380 || Nkind (gnat_node
) == N_Raise_Program_Error
)
381 && (Ekind (Etype (gnat_node
)) == E_Void
))))
383 add_pending_elaborations (NULL_TREE
, make_transform_expr (gnat_node
));
385 return error_mark_node
;
388 /* If this node is a non-static subexpression and we are only
389 annotating types, make this into a NULL_EXPR for non-VOID types
390 and error_mark_node for void return types. But allow
391 N_Identifier since we use it for lots of things, including
392 getting trees for discriminants. */
394 if (type_annotate_only
395 && IN (Nkind (gnat_node
), N_Subexpr
)
396 && Nkind (gnat_node
) != N_Identifier
397 && ! Compile_Time_Known_Value (gnat_node
))
399 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
401 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
402 return error_mark_node
;
404 return build1 (NULL_EXPR
, gnu_result_type
,
405 build_call_raise (CE_Range_Check_Failed
));
408 switch (Nkind (gnat_node
))
410 /********************************/
411 /* Chapter 2: Lexical Elements: */
412 /********************************/
415 case N_Expanded_Name
:
416 case N_Operator_Symbol
:
417 case N_Defining_Identifier
:
419 /* If the Etype of this node does not equal the Etype of the
420 Entity, something is wrong with the entity map, probably in
421 generic instantiation. However, this does not apply to
422 types. Since we sometime have strange Ekind's, just do
423 this test for objects. Also, if the Etype of the Entity is
424 private, the Etype of the N_Identifier is allowed to be the full
425 type and also we consider a packed array type to be the same as
426 the original type. Similarly, a class-wide type is equivalent
427 to a subtype of itself. Finally, if the types are Itypes,
428 one may be a copy of the other, which is also legal. */
430 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
431 ? gnat_node
: Entity (gnat_node
));
432 gnat_temp_type
= Etype (gnat_temp
);
434 if (Etype (gnat_node
) != gnat_temp_type
435 && ! (Is_Packed (gnat_temp_type
)
436 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
437 && ! (Is_Class_Wide_Type (Etype (gnat_node
)))
438 && ! (IN (Ekind (gnat_temp_type
), Private_Kind
)
439 && Present (Full_View (gnat_temp_type
))
440 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
441 || (Is_Packed (Full_View (gnat_temp_type
))
442 && Etype (gnat_node
) ==
443 Packed_Array_Type (Full_View (gnat_temp_type
)))))
444 && (!Is_Itype (Etype (gnat_node
)) || !Is_Itype (gnat_temp_type
))
445 && (Ekind (gnat_temp
) == E_Variable
446 || Ekind (gnat_temp
) == E_Component
447 || Ekind (gnat_temp
) == E_Constant
448 || Ekind (gnat_temp
) == E_Loop_Parameter
449 || IN (Ekind (gnat_temp
), Formal_Kind
)))
452 /* If this is a reference to a deferred constant whose partial view
453 is an unconstrained private type, the proper type is on the full
454 view of the constant, not on the full view of the type, which may
457 This may be a reference to a type, for example in the prefix of the
458 attribute Position, generated for dispatching code (see Make_DT in
459 exp_disp,adb). In that case we need the type itself, not is parent,
460 in particular if it is a derived type */
462 if (Is_Private_Type (gnat_temp_type
)
463 && Has_Unknown_Discriminants (gnat_temp_type
)
464 && Present (Full_View (gnat_temp
))
465 && ! Is_Type (gnat_temp
))
467 gnat_temp
= Full_View (gnat_temp
);
468 gnat_temp_type
= Etype (gnat_temp
);
469 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
473 /* Expand the type of this identitier first, in case it is
474 an enumeral literal, which only get made when the type
475 is expanded. There is no order-of-elaboration issue here.
476 We want to use the Actual_Subtype if it has already been
477 elaborated, otherwise the Etype. Avoid using Actual_Subtype
478 for packed arrays to simplify things. */
479 if ((Ekind (gnat_temp
) == E_Constant
480 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
481 && ! (Is_Array_Type (Etype (gnat_temp
))
482 && Present (Packed_Array_Type (Etype (gnat_temp
))))
483 && Present (Actual_Subtype (gnat_temp
))
484 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
485 gnat_temp_type
= Actual_Subtype (gnat_temp
);
487 gnat_temp_type
= Etype (gnat_node
);
489 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
492 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
494 /* If we are in an exception handler, force this variable into memory
495 to ensure optimization does not remove stores that appear
496 redundant but are actually needed in case an exception occurs.
498 ??? Note that we need not do this if the variable is declared within
499 the handler, only if it is referenced in the handler and declared
500 in an enclosing block, but we have no way of testing that
502 if (TREE_VALUE (gnu_except_ptr_stack
) != 0)
504 gnat_mark_addressable (gnu_result
);
505 flush_addressof (gnu_result
);
508 /* Some objects (such as parameters passed by reference, globals of
509 variable size, and renamed objects) actually represent the address
510 of the object. In that case, we must do the dereference. Likewise,
511 deal with parameters to foreign convention subprograms. Call fold
512 here since GNU_RESULT may be a CONST_DECL. */
513 if (DECL_P (gnu_result
)
514 && (DECL_BY_REF_P (gnu_result
)
515 || (TREE_CODE (gnu_result
) == PARM_DECL
516 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
518 int ro
= DECL_POINTS_TO_READONLY_P (gnu_result
);
521 if (TREE_CODE (gnu_result
) == PARM_DECL
522 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
523 gnu_result
= convert (build_pointer_type (gnu_result_type
),
526 /* If the object is constant, we try to do the dereference directly
527 through the DECL_INITIAL. This is actually required in order to
528 get correct aliasing information for renamed objects that are
529 components of non-aliased aggregates, because the type of
530 the renamed object and that of the aggregate don't alias. */
531 if (TREE_READONLY (gnu_result
)
532 && DECL_INITIAL (gnu_result
)
533 /* Strip possible conversion to reference type. */
534 && (initial
= TREE_CODE (DECL_INITIAL (gnu_result
)) == NOP_EXPR
535 ? TREE_OPERAND (DECL_INITIAL (gnu_result
), 0)
536 : DECL_INITIAL (gnu_result
), 1)
537 && TREE_CODE (initial
) == ADDR_EXPR
538 && (TREE_CODE (TREE_OPERAND (initial
, 0)) == ARRAY_REF
539 || TREE_CODE (TREE_OPERAND (initial
, 0)) == COMPONENT_REF
))
540 gnu_result
= TREE_OPERAND (initial
, 0);
542 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
545 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
) = ro
;
548 /* The GNAT tree has the type of a function as the type of its result.
549 Also use the type of the result if the Etype is a subtype which
550 is nominally unconstrained. But remove any padding from the
552 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
553 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
555 gnu_result_type
= TREE_TYPE (gnu_result
);
556 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
557 && TYPE_IS_PADDING_P (gnu_result_type
))
558 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
561 /* We always want to return the underlying INTEGER_CST for an
562 enumeration literal to avoid the need to call fold in lots
563 of places. But don't do this is the parent will be taking
564 the address of this object. */
565 if (TREE_CODE (gnu_result
) == CONST_DECL
)
567 gnat_temp
= Parent (gnat_node
);
568 if (DECL_CONST_CORRESPONDING_VAR (gnu_result
) == 0
569 || (Nkind (gnat_temp
) != N_Reference
570 && ! (Nkind (gnat_temp
) == N_Attribute_Reference
571 && ((Get_Attribute_Id (Attribute_Name (gnat_temp
))
573 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
575 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
576 == Attr_Unchecked_Access
)
577 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
578 == Attr_Unrestricted_Access
)))))
579 gnu_result
= DECL_INITIAL (gnu_result
);
583 case N_Integer_Literal
:
587 /* Get the type of the result, looking inside any padding and
588 left-justified modular types. Then get the value in that type. */
589 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
591 if (TREE_CODE (gnu_type
) == RECORD_TYPE
592 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
593 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
595 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
597 /* If the result overflows (meaning it doesn't fit in its base type),
598 abort. We would like to check that the value is within the range
599 of the subtype, but that causes problems with subtypes whose usage
600 will raise Constraint_Error and with biased representation, so
602 if (TREE_CONSTANT_OVERFLOW (gnu_result
))
607 case N_Character_Literal
:
608 /* If a Entity is present, it means that this was one of the
609 literals in a user-defined character type. In that case,
610 just return the value in the CONST_DECL. Otherwise, use the
611 character code. In that case, the base type should be an
612 INTEGER_TYPE, but we won't bother checking for that. */
613 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
614 if (Present (Entity (gnat_node
)))
615 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
617 gnu_result
= convert (gnu_result_type
,
618 build_int_2 (Char_Literal_Value (gnat_node
), 0));
622 /* If this is of a fixed-point type, the value we want is the
623 value of the corresponding integer. */
624 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
626 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
627 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
629 if (TREE_CONSTANT_OVERFLOW (gnu_result
))
633 /* We should never see a Vax_Float type literal, since the front end
634 is supposed to transform these using appropriate conversions */
635 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
640 Ureal ur_realval
= Realval (gnat_node
);
642 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
644 /* If the real value is zero, so is the result. Otherwise,
645 convert it to a machine number if it isn't already. That
646 forces BASE to 0 or 2 and simplifies the rest of our logic. */
647 if (UR_Is_Zero (ur_realval
))
648 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
651 if (! Is_Machine_Number (gnat_node
))
653 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
654 ur_realval
, Round_Even
, gnat_node
);
657 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
659 /* If we have a base of zero, divide by the denominator.
660 Otherwise, the base must be 2 and we scale the value, which
661 we know can fit in the mantissa of the type (hence the use
662 of that type above). */
663 if (Rbase (ur_realval
) == 0)
665 = build_binary_op (RDIV_EXPR
,
666 get_base_type (gnu_result_type
),
668 UI_To_gnu (Denominator (ur_realval
),
670 else if (Rbase (ur_realval
) != 2)
677 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
678 - UI_To_Int (Denominator (ur_realval
)));
679 gnu_result
= build_real (gnu_result_type
, tmp
);
683 /* Now see if we need to negate the result. Do it this way to
684 properly handle -0. */
685 if (UR_Is_Negative (Realval (gnat_node
)))
687 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
693 case N_String_Literal
:
694 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
695 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
697 /* We assume here that all strings are of type standard.string.
698 "Weird" types of string have been converted to an aggregate
700 String_Id gnat_string
= Strval (gnat_node
);
701 int length
= String_Length (gnat_string
);
702 char *string
= (char *) alloca (length
+ 1);
705 /* Build the string with the characters in the literal. Note
706 that Ada strings are 1-origin. */
707 for (i
= 0; i
< length
; i
++)
708 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
710 /* Put a null at the end of the string in case it's in a context
711 where GCC will want to treat it as a C string. */
714 gnu_result
= build_string (length
, string
);
716 /* Strings in GCC don't normally have types, but we want
717 this to not be converted to the array type. */
718 TREE_TYPE (gnu_result
) = gnu_result_type
;
722 /* Build a list consisting of each character, then make
724 String_Id gnat_string
= Strval (gnat_node
);
725 int length
= String_Length (gnat_string
);
727 tree gnu_list
= NULL_TREE
;
729 for (i
= 0; i
< length
; i
++)
731 = tree_cons (NULL_TREE
,
732 convert (TREE_TYPE (gnu_result_type
),
733 build_int_2 (Get_String_Char (gnat_string
,
739 = gnat_build_constructor (gnu_result_type
, nreverse (gnu_list
));
744 if (type_annotate_only
)
747 /* Check for (and ignore) unrecognized pragma */
748 if (! Is_Pragma_Name (Chars (gnat_node
)))
751 switch (Get_Pragma_Id (Chars (gnat_node
)))
753 case Pragma_Inspection_Point
:
754 /* Do nothing at top level: all such variables are already
756 if (global_bindings_p ())
759 set_lineno (gnat_node
, 1);
760 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
762 gnat_temp
= Next (gnat_temp
))
764 gnu_expr
= gnat_to_gnu (Expression (gnat_temp
));
765 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
766 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
768 gnu_expr
= build1 (USE_EXPR
, void_type_node
, gnu_expr
);
769 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
770 expand_expr_stmt (gnu_expr
);
774 case Pragma_Optimize
:
775 switch (Chars (Expression
776 (First (Pragma_Argument_Associations (gnat_node
)))))
778 case Name_Time
: case Name_Space
:
780 post_error ("insufficient -O value?", gnat_node
);
785 post_error ("must specify -O0?", gnat_node
);
794 case Pragma_Reviewable
:
795 if (write_symbols
== NO_DEBUG
)
796 post_error ("must specify -g?", gnat_node
);
801 /**************************************/
802 /* Chapter 3: Declarations and Types: */
803 /**************************************/
805 case N_Subtype_Declaration
:
806 case N_Full_Type_Declaration
:
807 case N_Incomplete_Type_Declaration
:
808 case N_Private_Type_Declaration
:
809 case N_Private_Extension_Declaration
:
810 case N_Task_Type_Declaration
:
811 process_type (Defining_Entity (gnat_node
));
814 case N_Object_Declaration
:
815 case N_Exception_Declaration
:
816 gnat_temp
= Defining_Entity (gnat_node
);
818 /* If we are just annotating types and this object has an unconstrained
819 or task type, don't elaborate it. */
820 if (type_annotate_only
821 && (((Is_Array_Type (Etype (gnat_temp
))
822 || Is_Record_Type (Etype (gnat_temp
)))
823 && ! Is_Constrained (Etype (gnat_temp
)))
824 || Is_Concurrent_Type (Etype (gnat_temp
))))
827 if (Present (Expression (gnat_node
))
828 && ! (Nkind (gnat_node
) == N_Object_Declaration
829 && No_Initialization (gnat_node
))
830 && (! type_annotate_only
831 || Compile_Time_Known_Value (Expression (gnat_node
))))
833 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
834 if (Do_Range_Check (Expression (gnat_node
)))
835 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_temp
));
837 /* If this object has its elaboration delayed, we must force
838 evaluation of GNU_EXPR right now and save it for when the object
840 if (Present (Freeze_Node (gnat_temp
)))
842 if ((Is_Public (gnat_temp
) || global_bindings_p ())
843 && ! TREE_CONSTANT (gnu_expr
))
846 = create_var_decl (create_concat_name (gnat_temp
, "init"),
847 NULL_TREE
, TREE_TYPE (gnu_expr
),
848 gnu_expr
, 0, Is_Public (gnat_temp
), 0,
850 add_decl_stmt (gnu_expr
, gnat_temp
);
853 gnu_expr
= maybe_variable (gnu_expr
, Expression (gnat_node
));
855 save_gnu_tree (gnat_node
, gnu_expr
, 1);
861 if (type_annotate_only
&& gnu_expr
!= 0
862 && TREE_CODE (gnu_expr
) == ERROR_MARK
)
865 if (No (Freeze_Node (gnat_temp
)))
866 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
869 case N_Object_Renaming_Declaration
:
871 gnat_temp
= Defining_Entity (gnat_node
);
873 /* Don't do anything if this renaming is handled by the front end.
874 or if we are just annotating types and this object has a
875 composite or task type, don't elaborate it. */
876 if (! Is_Renaming_Of_Object (gnat_temp
)
877 && ! (type_annotate_only
878 && (Is_Array_Type (Etype (gnat_temp
))
879 || Is_Record_Type (Etype (gnat_temp
))
880 || Is_Concurrent_Type (Etype (gnat_temp
)))))
881 gnat_to_gnu_entity (gnat_temp
,
882 gnat_to_gnu (Renamed_Object (gnat_temp
)), 1);
885 case N_Implicit_Label_Declaration
:
886 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
889 case N_Exception_Renaming_Declaration
:
890 case N_Number_Declaration
:
891 case N_Package_Renaming_Declaration
:
892 case N_Subprogram_Renaming_Declaration
:
893 /* These are fully handled in the front end. */
896 /*************************************/
897 /* Chapter 4: Names and Expressions: */
898 /*************************************/
900 case N_Explicit_Dereference
:
901 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
902 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
903 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
906 case N_Indexed_Component
:
908 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
912 Node_Id
*gnat_expr_array
;
914 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
915 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
917 /* If we got a padded type, remove it too. */
918 if (TREE_CODE (TREE_TYPE (gnu_array_object
)) == RECORD_TYPE
919 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
921 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
924 gnu_result
= gnu_array_object
;
926 /* First compute the number of dimensions of the array, then
927 fill the expression array, the order depending on whether
928 this is a Convention_Fortran array or not. */
929 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
930 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
931 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
932 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
935 gnat_expr_array
= (Node_Id
*) alloca (ndim
* sizeof (Node_Id
));
937 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
938 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
940 i
--, gnat_temp
= Next (gnat_temp
))
941 gnat_expr_array
[i
] = gnat_temp
;
943 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
945 i
++, gnat_temp
= Next (gnat_temp
))
946 gnat_expr_array
[i
] = gnat_temp
;
948 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
949 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
951 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
954 gnat_temp
= gnat_expr_array
[i
];
955 gnu_expr
= gnat_to_gnu (gnat_temp
);
957 if (Do_Range_Check (gnat_temp
))
960 (gnu_array_object
, gnu_expr
,
961 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
962 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
964 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
965 gnu_result
, gnu_expr
);
969 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
975 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
977 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
978 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
980 /* Do any implicit dereferences of the prefix and do any needed
982 gnu_result
= maybe_implicit_deref (gnu_result
);
983 gnu_result
= maybe_unconstrained_array (gnu_result
);
984 gnu_type
= TREE_TYPE (gnu_result
);
985 if (Do_Range_Check (gnat_range_node
))
987 /* Get the bounds of the slice. */
989 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
990 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
991 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
992 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
994 /* Check to see that the minimum slice value is in range */
997 (gnu_result
, gnu_min_expr
,
998 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
999 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
1001 /* Check to see that the maximum slice value is in range */
1004 (gnu_result
, gnu_max_expr
,
1005 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
1006 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
1008 /* Derive a good type to convert everything too */
1009 gnu_expr_type
= get_base_type (TREE_TYPE (gnu_expr_l
));
1011 /* Build a compound expression that does the range checks */
1013 = build_binary_op (COMPOUND_EXPR
, gnu_expr_type
,
1014 convert (gnu_expr_type
, gnu_expr_h
),
1015 convert (gnu_expr_type
, gnu_expr_l
));
1017 /* Build a conditional expression that returns the range checks
1018 expression if the slice range is not null (max >= min) or
1019 returns the min if the slice range is null */
1021 = fold (build (COND_EXPR
, gnu_expr_type
,
1022 build_binary_op (GE_EXPR
, gnu_expr_type
,
1023 convert (gnu_expr_type
,
1025 convert (gnu_expr_type
,
1027 gnu_expr
, gnu_min_expr
));
1030 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
1032 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
1033 gnu_result
, gnu_expr
);
1037 case N_Selected_Component
:
1039 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1040 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
1041 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
1044 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
1045 || IN (Ekind (gnat_pref_type
), Access_Kind
))
1047 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
1048 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
1049 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
1050 gnat_pref_type
= Designated_Type (gnat_pref_type
);
1053 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1055 /* For discriminant references in tagged types always substitute the
1056 corresponding discriminant as the actual selected component. */
1058 if (Is_Tagged_Type (gnat_pref_type
))
1059 while (Present (Corresponding_Discriminant (gnat_field
)))
1060 gnat_field
= Corresponding_Discriminant (gnat_field
);
1062 /* For discriminant references of untagged types always substitute the
1063 corresponding stored discriminant. */
1065 else if (Present (Corresponding_Discriminant (gnat_field
)))
1066 gnat_field
= Original_Record_Component (gnat_field
);
1068 /* Handle extracting the real or imaginary part of a complex.
1069 The real part is the first field and the imaginary the last. */
1071 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
1072 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
1073 ? REALPART_EXPR
: IMAGPART_EXPR
,
1074 NULL_TREE
, gnu_prefix
);
1077 gnu_field
= gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0);
1079 /* If there are discriminants, the prefix might be
1080 evaluated more than once, which is a problem if it has
1082 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
1083 ? Designated_Type (Etype
1084 (Prefix (gnat_node
)))
1085 : Etype (Prefix (gnat_node
))))
1086 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, 0);
1089 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
,
1090 (Nkind (Parent (gnat_node
))
1091 == N_Attribute_Reference
));
1094 if (gnu_result
== 0)
1097 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1101 case N_Attribute_Reference
:
1103 /* The attribute designator (like an enumeration value). */
1104 int attribute
= Get_Attribute_Id (Attribute_Name (gnat_node
));
1105 int prefix_unused
= 0;
1109 /* The Elab_Spec and Elab_Body attributes are special in that
1110 Prefix is a unit, not an object with a GCC equivalent. Similarly
1111 for Elaborated, since that variable isn't otherwise known. */
1112 if (attribute
== Attr_Elab_Body
|| attribute
== Attr_Elab_Spec
)
1115 = create_subprog_decl
1116 (create_concat_name (Entity (Prefix (gnat_node
)),
1117 attribute
== Attr_Elab_Body
1118 ? "elabb" : "elabs"),
1119 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 1, 0);
1123 gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1124 gnu_type
= TREE_TYPE (gnu_prefix
);
1126 /* If the input is a NULL_EXPR, make a new one. */
1127 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1129 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1130 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
,
1131 TREE_OPERAND (gnu_prefix
, 0));
1139 /* These are just conversions until since representation
1140 clauses for enumerations are handled in the front end. */
1142 int check_p
= Do_Range_Check (First (Expressions (gnat_node
)));
1144 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1145 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1146 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1147 check_p
, check_p
, 1);
1153 /* These just add or subject the constant 1. Representation
1154 clauses for enumerations are handled in the front-end. */
1155 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1156 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1158 if (Do_Range_Check (First (Expressions (gnat_node
))))
1160 gnu_expr
= protect_multiple_eval (gnu_expr
);
1163 (build_binary_op (EQ_EXPR
, integer_type_node
,
1165 attribute
== Attr_Pred
1166 ? TYPE_MIN_VALUE (gnu_result_type
)
1167 : TYPE_MAX_VALUE (gnu_result_type
)),
1168 gnu_expr
, CE_Range_Check_Failed
);
1172 = build_binary_op (attribute
== Attr_Pred
1173 ? MINUS_EXPR
: PLUS_EXPR
,
1174 gnu_result_type
, gnu_expr
,
1175 convert (gnu_result_type
, integer_one_node
));
1179 case Attr_Unrestricted_Access
:
1181 /* Conversions don't change something's address but can cause
1182 us to miss the COMPONENT_REF case below, so strip them off. */
1184 = remove_conversions (gnu_prefix
,
1185 ! Must_Be_Byte_Aligned (gnat_node
));
1187 /* If we are taking 'Address of an unconstrained object,
1188 this is the pointer to the underlying array. */
1189 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1191 /* ... fall through ... */
1194 case Attr_Unchecked_Access
:
1195 case Attr_Code_Address
:
1197 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1199 = build_unary_op (((attribute
== Attr_Address
1200 || attribute
== Attr_Unrestricted_Access
)
1201 && ! Must_Be_Byte_Aligned (gnat_node
))
1202 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1203 gnu_result_type
, gnu_prefix
);
1205 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1206 so that we don't try to build a trampoline. */
1207 if (attribute
== Attr_Code_Address
)
1209 for (gnu_expr
= gnu_result
;
1210 TREE_CODE (gnu_expr
) == NOP_EXPR
1211 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
1212 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
1213 TREE_CONSTANT (gnu_expr
) = 1;
1216 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1217 TREE_STATIC (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1222 case Attr_Pool_Address
:
1225 tree gnu_ptr
= gnu_prefix
;
1227 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1229 /* If this is an unconstrained array, we know the object must
1230 have been allocated with the template in front of the object.
1231 So compute the template address.*/
1233 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
1235 = convert (build_pointer_type
1236 (TYPE_OBJECT_RECORD_TYPE
1237 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
1240 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
1241 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
1242 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
1244 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
1245 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
1246 tree gnu_byte_offset
1247 = convert (gnu_char_ptr_type
,
1248 size_diffop (size_zero_node
, gnu_pos
));
1250 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
1251 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
1252 gnu_ptr
, gnu_byte_offset
);
1255 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
1260 case Attr_Object_Size
:
1261 case Attr_Value_Size
:
1262 case Attr_Max_Size_In_Storage_Elements
:
1264 gnu_expr
= gnu_prefix
;
1266 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1267 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1268 while (TREE_CODE (gnu_expr
) == NOP_EXPR
)
1269 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1271 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1273 gnu_type
= TREE_TYPE (gnu_prefix
);
1275 /* Replace an unconstrained array type with the type of the
1276 underlying array. We can't do this with a call to
1277 maybe_unconstrained_array since we may have a TYPE_DECL.
1278 For 'Max_Size_In_Storage_Elements, use the record type
1279 that will be used to allocate the object and its template. */
1281 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1283 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1284 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1285 gnu_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)));
1288 /* If we are looking for the size of a field, return the
1289 field size. Otherwise, if the prefix is an object,
1290 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1291 been specified, the result is the GCC size of the type.
1292 Otherwise, the result is the RM_Size of the type. */
1293 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1294 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1295 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1296 || attribute
== Attr_Object_Size
1297 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1299 /* If this is a padded type, the GCC size isn't relevant
1300 to the programmer. Normally, what we want is the RM_Size,
1301 which was set from the specified size, but if it was not
1302 set, we want the size of the relevant field. Using the MAX
1303 of those two produces the right result in all case. Don't
1304 use the size of the field if it's a self-referential type,
1305 since that's never what's wanted. */
1306 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1307 && TYPE_IS_PADDING_P (gnu_type
)
1308 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
1310 gnu_result
= rm_size (gnu_type
);
1311 if (! (CONTAINS_PLACEHOLDER_P
1312 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)))))
1314 = size_binop (MAX_EXPR
, gnu_result
,
1315 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
1318 gnu_result
= TYPE_SIZE (gnu_type
);
1321 gnu_result
= rm_size (gnu_type
);
1323 if (gnu_result
== 0)
1326 /* Deal with a self-referential size by returning the maximum
1327 size for a type and by qualifying the size with
1328 the object for 'Size of an object. */
1330 if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1332 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1333 gnu_result
= substitute_placeholder_in_expr (gnu_result
,
1336 gnu_result
= max_size (gnu_result
, 1);
1339 /* If the type contains a template, subtract the size of the
1341 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1342 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1343 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1344 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1346 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1348 /* Always perform division using unsigned arithmetic as the
1349 size cannot be negative, but may be an overflowed positive
1350 value. This provides correct results for sizes up to 512 MB.
1351 ??? Size should be calculated in storage elements directly. */
1353 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1354 gnu_result
= convert (sizetype
,
1355 fold (build (CEIL_DIV_EXPR
, bitsizetype
,
1357 bitsize_unit_node
)));
1360 case Attr_Alignment
:
1361 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1362 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1364 && (TYPE_IS_PADDING_P
1365 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1366 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1368 gnu_type
= TREE_TYPE (gnu_prefix
);
1369 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1372 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1374 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)));
1376 gnu_result
= size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
);
1381 case Attr_Range_Length
:
1384 if (INTEGRAL_TYPE_P (gnu_type
)
1385 || TREE_CODE (gnu_type
) == REAL_TYPE
)
1387 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1389 if (attribute
== Attr_First
)
1390 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1391 else if (attribute
== Attr_Last
)
1392 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1396 (MAX_EXPR
, get_base_type (gnu_result_type
),
1398 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1399 build_binary_op (MINUS_EXPR
,
1400 get_base_type (gnu_result_type
),
1401 convert (gnu_result_type
,
1402 TYPE_MAX_VALUE (gnu_type
)),
1403 convert (gnu_result_type
,
1404 TYPE_MIN_VALUE (gnu_type
))),
1405 convert (gnu_result_type
, integer_one_node
)),
1406 convert (gnu_result_type
, integer_zero_node
));
1410 /* ... fall through ... */
1414 = (Present (Expressions (gnat_node
))
1415 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1418 /* Make sure any implicit dereference gets done. */
1419 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1420 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1421 gnu_type
= TREE_TYPE (gnu_prefix
);
1423 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1425 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1430 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1431 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1432 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1433 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1436 Dimension
= ndim
+ 1 - Dimension
;
1439 for (; Dimension
> 1; Dimension
--)
1440 gnu_type
= TREE_TYPE (gnu_type
);
1442 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1445 if (attribute
== Attr_First
)
1447 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1448 else if (attribute
== Attr_Last
)
1450 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1452 /* 'Length or 'Range_Length. */
1454 tree gnu_compute_type
1455 = gnat_signed_or_unsigned_type
1456 (0, get_base_type (gnu_result_type
));
1460 (MAX_EXPR
, gnu_compute_type
,
1462 (PLUS_EXPR
, gnu_compute_type
,
1464 (MINUS_EXPR
, gnu_compute_type
,
1465 convert (gnu_compute_type
,
1467 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)))),
1468 convert (gnu_compute_type
,
1470 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))))),
1471 convert (gnu_compute_type
, integer_one_node
)),
1472 convert (gnu_compute_type
, integer_zero_node
));
1475 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1476 we are handling. Note that these attributes could not
1477 have been used on an unconstrained array type. */
1478 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
,
1484 case Attr_Bit_Position
:
1486 case Attr_First_Bit
:
1490 HOST_WIDE_INT bitsize
;
1491 HOST_WIDE_INT bitpos
;
1493 tree gnu_field_bitpos
;
1494 tree gnu_field_offset
;
1496 enum machine_mode mode
;
1497 int unsignedp
, volatilep
;
1499 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1500 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1503 /* We can have 'Bit on any object, but if it isn't a
1504 COMPONENT_REF, the result is zero. Do not allow
1505 'Bit on a bare component, though. */
1506 if (attribute
== Attr_Bit
1507 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1508 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1510 gnu_result
= integer_zero_node
;
1514 else if (TREE_CODE (gnu_prefix
) != COMPONENT_REF
1515 && ! (attribute
== Attr_Bit_Position
1516 && TREE_CODE (gnu_prefix
) == FIELD_DECL
))
1519 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1520 &mode
, &unsignedp
, &volatilep
);
1522 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1525 = bit_position (TREE_OPERAND (gnu_prefix
, 1));
1527 = byte_position (TREE_OPERAND (gnu_prefix
, 1));
1529 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1530 TREE_CODE (gnu_inner
) == COMPONENT_REF
1531 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1532 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1535 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1536 bit_position (TREE_OPERAND (gnu_inner
,
1539 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1540 byte_position (TREE_OPERAND (gnu_inner
,
1544 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1546 gnu_field_bitpos
= bit_position (gnu_prefix
);
1547 gnu_field_offset
= byte_position (gnu_prefix
);
1551 gnu_field_bitpos
= bitsize_zero_node
;
1552 gnu_field_offset
= size_zero_node
;
1558 gnu_result
= gnu_field_offset
;
1561 case Attr_First_Bit
:
1563 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1567 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1569 = size_binop (PLUS_EXPR
, gnu_result
,
1570 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1571 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1575 case Attr_Bit_Position
:
1576 gnu_result
= gnu_field_bitpos
;
1580 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1582 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
,
1590 gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1591 gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1593 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1594 gnu_result
= build_binary_op (attribute
== Attr_Min
1595 ? MIN_EXPR
: MAX_EXPR
,
1596 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1599 case Attr_Passed_By_Reference
:
1600 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1601 || must_pass_by_ref (gnu_type
));
1602 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1605 case Attr_Component_Size
:
1606 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1607 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1609 && (TYPE_IS_PADDING_P
1610 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1611 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1613 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1614 gnu_type
= TREE_TYPE (gnu_prefix
);
1616 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1618 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1620 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1621 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1622 gnu_type
= TREE_TYPE (gnu_type
);
1624 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1627 /* Note this size cannot be self-referential. */
1628 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1629 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1633 case Attr_Null_Parameter
:
1634 /* This is just a zero cast to the pointer type for
1635 our prefix and dereferenced. */
1636 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1638 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1639 convert (build_pointer_type (gnu_result_type
),
1640 integer_zero_node
));
1641 TREE_PRIVATE (gnu_result
) = 1;
1644 case Attr_Mechanism_Code
:
1647 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1650 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1651 if (Present (Expressions (gnat_node
)))
1653 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1655 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1656 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1660 code
= Mechanism (gnat_obj
);
1661 if (code
== Default
)
1662 code
= ((present_gnu_tree (gnat_obj
)
1663 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1664 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
1666 && (DECL_BY_COMPONENT_PTR_P
1667 (get_gnu_tree (gnat_obj
))))))
1668 ? By_Reference
: By_Copy
);
1669 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1674 /* Say we have an unimplemented attribute. Then set the
1675 value to be returned to be a zero and hope that's something
1676 we can convert to the type of this attribute. */
1678 post_error ("unimplemented attribute", gnat_node
);
1679 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1680 gnu_result
= integer_zero_node
;
1684 /* If this is an attribute where the prefix was unused,
1685 force a use of it if it has a side-effect. But don't do it if
1686 the prefix is just an entity name. However, if an access check
1687 is needed, we must do it. See second example in AARM 11.6(5.e). */
1688 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
)
1689 && ! Is_Entity_Name (Prefix (gnat_node
)))
1690 gnu_result
= fold (build (COMPOUND_EXPR
, TREE_TYPE (gnu_result
),
1691 gnu_prefix
, gnu_result
));
1696 /* Like 'Access as far as we are concerned. */
1697 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
1698 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
1699 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1703 case N_Extension_Aggregate
:
1707 /* ??? It is wrong to evaluate the type now, but there doesn't
1708 seem to be any other practical way of doing it. */
1710 gnu_aggr_type
= gnu_result_type
1711 = get_unpadded_type (Etype (gnat_node
));
1713 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
1714 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
1716 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type
)));
1718 if (Null_Record_Present (gnat_node
))
1719 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL_TREE
);
1721 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
)
1723 = assoc_to_constructor (First (Component_Associations (gnat_node
)),
1725 else if (TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
1727 /* The first element is the discrimant, which we ignore. The
1728 next is the field we're building. Convert the expression
1729 to the type of the field and then to the union type. */
1731 = Next (First (Component_Associations (gnat_node
)));
1732 Entity_Id gnat_field
= Entity (First (Choices (gnat_assoc
)));
1734 = TREE_TYPE (gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0));
1736 gnu_result
= convert (gnu_field_type
,
1737 gnat_to_gnu (Expression (gnat_assoc
)));
1739 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
1740 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
1742 Component_Type (Etype (gnat_node
)));
1743 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
1746 (COMPLEX_EXPR
, gnu_aggr_type
,
1747 gnat_to_gnu (Expression (First
1748 (Component_Associations (gnat_node
)))),
1749 gnat_to_gnu (Expression
1751 (First (Component_Associations (gnat_node
))))));
1755 gnu_result
= convert (gnu_result_type
, gnu_result
);
1760 gnu_result
= null_pointer_node
;
1761 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1764 case N_Type_Conversion
:
1765 case N_Qualified_Expression
:
1766 /* Get the operand expression. */
1767 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1768 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1771 = convert_with_check (Etype (gnat_node
), gnu_result
,
1772 Do_Overflow_Check (gnat_node
),
1773 Do_Range_Check (Expression (gnat_node
)),
1774 Nkind (gnat_node
) == N_Type_Conversion
1775 && Float_Truncate (gnat_node
));
1778 case N_Unchecked_Type_Conversion
:
1779 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1780 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1782 /* If the result is a pointer type, see if we are improperly
1783 converting to a stricter alignment. */
1785 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
1786 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
1788 unsigned int align
= known_alignment (gnu_result
);
1789 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
1790 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
1792 if (align
!= 0 && align
< oalign
&& ! TYPE_ALIGN_OK (gnu_obj_type
))
1793 post_error_ne_tree_2
1794 ("?source alignment (^) < alignment of & (^)",
1795 gnat_node
, Designated_Type (Etype (gnat_node
)),
1796 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
1799 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
,
1800 No_Truncation (gnat_node
));
1806 tree gnu_object
= gnat_to_gnu (Left_Opnd (gnat_node
));
1807 Node_Id gnat_range
= Right_Opnd (gnat_node
);
1811 /* GNAT_RANGE is either an N_Range node or an identifier
1812 denoting a subtype. */
1813 if (Nkind (gnat_range
) == N_Range
)
1815 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
1816 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
1818 else if (Nkind (gnat_range
) == N_Identifier
1819 || Nkind (gnat_range
) == N_Expanded_Name
)
1821 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
1823 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
1824 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
1829 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1831 /* If LOW and HIGH are identical, perform an equality test.
1832 Otherwise, ensure that GNU_OBJECT is only evaluated once
1833 and perform a full range test. */
1834 if (operand_equal_p (gnu_low
, gnu_high
, 0))
1835 gnu_result
= build_binary_op (EQ_EXPR
, gnu_result_type
,
1836 gnu_object
, gnu_low
);
1839 gnu_object
= protect_multiple_eval (gnu_object
);
1841 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
,
1842 build_binary_op (GE_EXPR
, gnu_result_type
,
1843 gnu_object
, gnu_low
),
1844 build_binary_op (LE_EXPR
, gnu_result_type
,
1845 gnu_object
, gnu_high
));
1848 if (Nkind (gnat_node
) == N_Not_In
)
1849 gnu_result
= invert_truthvalue (gnu_result
);
1854 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1855 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1856 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1857 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
1859 : (Rounded_Result (gnat_node
)
1860 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
1861 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1864 case N_And_Then
: case N_Or_Else
:
1866 /* Some processing below (e.g. clear_last_expr) requires access to
1867 status fields now maintained in the current function context, so
1868 we'll setup a dummy one if needed. We cannot use global_binding_p,
1869 since it might be true due to force_global and making a dummy
1870 context would kill the current function context. */
1871 bool make_dummy_context
= (cfun
== 0);
1872 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1875 if (make_dummy_context
)
1876 init_dummy_function_start ();
1878 /* The elaboration of the RHS may generate code. If so,
1879 we need to make sure it gets executed after the LHS. */
1880 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1883 gnu_rhs_side
= expand_start_stmt_expr (1 /*has_scope*/);
1884 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1885 expand_end_stmt_expr (gnu_rhs_side
);
1887 if (make_dummy_context
)
1888 expand_dummy_function_end ();
1890 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1892 if (first_nondeleted_insn (RTL_EXPR_SEQUENCE (gnu_rhs_side
)))
1893 gnu_rhs
= build (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs_side
,
1896 gnu_result
= build_binary_op (code
, gnu_result_type
, gnu_lhs
, gnu_rhs
);
1900 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
1901 /* These can either be operations on booleans or on modular types.
1902 Fall through for boolean types since that's the way GNU_CODES is
1904 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
1905 Modular_Integer_Kind
))
1908 = (Nkind (gnat_node
) == N_Op_Or
? BIT_IOR_EXPR
1909 : Nkind (gnat_node
) == N_Op_And
? BIT_AND_EXPR
1912 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1913 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1914 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1915 gnu_result
= build_binary_op (code
, gnu_result_type
,
1920 /* ... fall through ... */
1922 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
1923 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
1924 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
1925 case N_Op_Mod
: case N_Op_Rem
:
1926 case N_Op_Rotate_Left
:
1927 case N_Op_Rotate_Right
:
1928 case N_Op_Shift_Left
:
1929 case N_Op_Shift_Right
:
1930 case N_Op_Shift_Right_Arithmetic
:
1932 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1935 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1936 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1937 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1939 /* If this is a comparison operator, convert any references to
1940 an unconstrained array value into a reference to the
1942 if (TREE_CODE_CLASS (code
) == '<')
1944 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
1945 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
1948 /* If the result type is a private type, its full view may be a
1949 numeric subtype. The representation we need is that of its base
1950 type, given that it is the result of an arithmetic operation. */
1951 else if (Is_Private_Type (Etype (gnat_node
)))
1952 gnu_type
= gnu_result_type
1953 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
1955 /* If this is a shift whose count is not guaranteed to be correct,
1956 we need to adjust the shift count. */
1957 if (IN (Nkind (gnat_node
), N_Op_Shift
)
1958 && ! Shift_Count_OK (gnat_node
))
1960 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
1962 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
1964 if (Nkind (gnat_node
) == N_Op_Rotate_Left
1965 || Nkind (gnat_node
) == N_Op_Rotate_Right
)
1966 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
1967 gnu_rhs
, gnu_max_shift
);
1968 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
)
1971 (MIN_EXPR
, gnu_count_type
,
1972 build_binary_op (MINUS_EXPR
,
1975 convert (gnu_count_type
,
1980 /* For right shifts, the type says what kind of shift to do,
1981 so we may need to choose a different type. */
1982 if (Nkind (gnat_node
) == N_Op_Shift_Right
1983 && ! TYPE_UNSIGNED (gnu_type
))
1984 gnu_type
= gnat_unsigned_type (gnu_type
);
1985 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
1986 && TYPE_UNSIGNED (gnu_type
))
1987 gnu_type
= gnat_signed_type (gnu_type
);
1989 if (gnu_type
!= gnu_result_type
)
1991 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
1992 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
1995 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
1997 /* If this is a logical shift with the shift count not verified,
1998 we must return zero if it is too large. We cannot compensate
1999 above in this case. */
2000 if ((Nkind (gnat_node
) == N_Op_Shift_Left
2001 || Nkind (gnat_node
) == N_Op_Shift_Right
)
2002 && ! Shift_Count_OK (gnat_node
))
2006 build_binary_op (GE_EXPR
, integer_type_node
,
2008 convert (TREE_TYPE (gnu_rhs
),
2009 TYPE_SIZE (gnu_type
))),
2010 convert (gnu_type
, integer_zero_node
),
2015 case N_Conditional_Expression
:
2017 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
2018 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
2020 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
2022 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2023 gnu_result
= build_cond_expr (gnu_result_type
,
2024 gnat_truthvalue_conversion (gnu_cond
),
2025 gnu_true
, gnu_false
);
2030 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
2031 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2035 /* This case can apply to a boolean or a modular type.
2036 Fall through for a boolean operand since GNU_CODES is set
2037 up to handle this. */
2038 if (IN (Ekind (Etype (gnat_node
)), Modular_Integer_Kind
))
2040 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
2041 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2042 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
2047 /* ... fall through ... */
2049 case N_Op_Minus
: case N_Op_Abs
:
2050 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
2052 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
2053 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2055 gnu_result_type
= get_unpadded_type (Base_Type
2056 (Full_View (Etype (gnat_node
))));
2058 gnu_result
= build_unary_op (gnu_codes
[Nkind (gnat_node
)],
2059 gnu_result_type
, gnu_expr
);
2067 gnat_temp
= Expression (gnat_node
);
2069 /* The Expression operand can either be an N_Identifier or
2070 Expanded_Name, which must represent a type, or a
2071 N_Qualified_Expression, which contains both the object type and an
2072 initial value for the object. */
2073 if (Nkind (gnat_temp
) == N_Identifier
2074 || Nkind (gnat_temp
) == N_Expanded_Name
)
2075 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
2076 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
2078 Entity_Id gnat_desig_type
2079 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
2081 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
2083 gnu_init
= maybe_unconstrained_array (gnu_init
);
2084 if (Do_Range_Check (Expression (gnat_temp
)))
2085 gnu_init
= emit_range_check (gnu_init
, gnat_desig_type
);
2087 if (Is_Elementary_Type (gnat_desig_type
)
2088 || Is_Constrained (gnat_desig_type
))
2090 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
2091 gnu_init
= convert (gnu_type
, gnu_init
);
2095 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
2096 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2097 gnu_type
= TREE_TYPE (gnu_init
);
2099 gnu_init
= convert (gnu_type
, gnu_init
);
2105 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2106 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
2107 Procedure_To_Call (gnat_node
),
2108 Storage_Pool (gnat_node
), gnat_node
);
2112 /***************************/
2113 /* Chapter 5: Statements: */
2114 /***************************/
2117 gnu_result
= build_nt (LABEL_STMT
, gnat_to_gnu (Identifier (gnat_node
)));
2120 case N_Null_Statement
:
2121 gnu_result
= build_nt (NULL_STMT
);
2124 case N_Assignment_Statement
:
2125 /* Get the LHS and RHS of the statement and convert any reference to an
2126 unconstrained array into a reference to the underlying array. */
2127 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
2129 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
2131 /* If range check is needed, emit code to generate it */
2132 if (Do_Range_Check (Expression (gnat_node
)))
2133 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)));
2135 /* If either side's type has a size that overflows, convert this
2136 into raise of Storage_Error: execution shouldn't have gotten
2138 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
2139 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs
))))
2140 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs
))) == INTEGER_CST
2141 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs
)))))
2142 gnu_result
= build_call_raise (SE_Object_Too_Large
);
2145 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
2147 gnu_result
= build_nt (EXPR_STMT
, gnu_result
);
2150 case N_If_Statement
:
2151 gnu_result
= NULL_TREE
;
2153 /* Make an IF_STMT for each of the "else if" parts. Avoid
2155 if (Present (Elsif_Parts (gnat_node
)))
2156 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
2157 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
2159 gnu_expr
= make_node (IF_STMT
);
2161 IF_STMT_COND (gnu_expr
) = gnat_to_gnu (Condition (gnat_temp
));
2162 IF_STMT_TRUE (gnu_expr
)
2163 = build_block_stmt (Then_Statements (gnat_temp
));
2164 IF_STMT_ELSE (gnu_expr
) = IF_STMT_ELSEIF (gnu_expr
) = NULL_TREE
;
2165 TREE_SLOC (gnu_expr
) = Sloc (Condition (gnat_temp
));
2166 TREE_CHAIN (gnu_expr
) = gnu_result
;
2167 TREE_TYPE (gnu_expr
) = void_type_node
;
2168 gnu_result
= gnu_expr
;
2171 /* Now make the IF_STMT. Also avoid non-determinism. */
2172 gnu_expr
= make_node (IF_STMT
);
2173 IF_STMT_COND (gnu_expr
) = gnat_to_gnu (Condition (gnat_node
));
2174 IF_STMT_TRUE (gnu_expr
) = build_block_stmt (Then_Statements (gnat_node
));
2175 IF_STMT_ELSEIF (gnu_expr
) = nreverse (gnu_result
);
2176 IF_STMT_ELSE (gnu_expr
) = build_block_stmt (Else_Statements (gnat_node
));
2177 gnu_result
= gnu_expr
;
2180 case N_Case_Statement
:
2183 Node_Id gnat_choice
;
2185 Node_Id gnat_statement
;
2187 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2188 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2190 /* The range of values in a case statement is determined by the
2191 rules in RM 5.4(7-9). In almost all cases, this range is
2192 represented by the Etype of the expression. One exception arises
2193 in the case of a simple name that is parenthesized. This still
2194 has the Etype of the name, but since it is not a name, para 7
2195 does not apply, and we need to go to the base type. This is the
2196 only case where parenthesization affects the dynamic semantics
2197 (i.e. the range of possible values at runtime that is covered by
2198 the others alternative.
2200 Another exception is if the subtype of the expression is
2201 non-static. In that case, we also have to use the base type. */
2202 if (Paren_Count (Expression (gnat_node
)) != 0
2203 || !Is_OK_Static_Subtype (Underlying_Type
2204 (Etype (Expression (gnat_node
)))))
2205 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2207 set_lineno (gnat_node
, 1);
2208 expand_start_case (1, gnu_expr
, TREE_TYPE (gnu_expr
), "case");
2210 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2211 Present (gnat_when
);
2212 gnat_when
= Next_Non_Pragma (gnat_when
))
2214 tree gnu_temp_stmt
, gnu_block
;
2216 /* First compile all the different case choices for the current
2217 WHEN alternative. */
2219 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2220 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2224 gnu_label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2226 set_lineno (gnat_choice
, 1);
2227 switch (Nkind (gnat_choice
))
2230 /* Abort on all errors except range empty, which
2231 means we ignore this alternative. */
2233 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice
)),
2234 gnat_to_gnu (High_Bound (gnat_choice
)),
2235 convert
, gnu_label
, 0);
2237 if (error_code
!= 0 && error_code
!= 4)
2241 case N_Subtype_Indication
:
2244 (gnat_to_gnu (Low_Bound (Range_Expression
2245 (Constraint (gnat_choice
)))),
2246 gnat_to_gnu (High_Bound (Range_Expression
2247 (Constraint (gnat_choice
)))),
2248 convert
, gnu_label
, 0);
2250 if (error_code
!= 0 && error_code
!= 4)
2255 case N_Expanded_Name
:
2256 /* This represents either a subtype range or a static value
2257 of some kind; Ekind says which. If a static value,
2258 fall through to the next case. */
2259 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2261 tree type
= get_unpadded_type (Entity (gnat_choice
));
2264 = pushcase_range (fold (TYPE_MIN_VALUE (type
)),
2265 fold (TYPE_MAX_VALUE (type
)),
2266 convert
, gnu_label
, 0);
2268 if (error_code
!= 0 && error_code
!= 4)
2272 /* ... fall through ... */
2273 case N_Character_Literal
:
2274 case N_Integer_Literal
:
2275 if (pushcase (gnat_to_gnu (gnat_choice
), convert
,
2280 case N_Others_Choice
:
2281 if (pushcase (NULL_TREE
, convert
, gnu_label
, 0))
2290 /* After compiling the choices attached to the WHEN compile the
2291 body of statements that have to be executed, should the
2292 "WHEN ... =>" be taken. Push a binding level here in case
2293 variables are declared since we want them to be local to this
2294 set of statements instead of the block containing the Case
2297 start_block_stmt ();
2299 for (gnat_statement
= First (Statements (gnat_when
));
2300 Present (gnat_statement
);
2301 gnat_statement
= Next (gnat_statement
))
2302 add_stmt (gnat_to_gnu (gnat_statement
));
2304 /* Communicate to GCC that we are done with the current WHEN,
2305 i.e. insert a "break" statement. */
2306 gnu_temp_stmt
= build_nt (BREAK_STMT
);
2307 TREE_SLOC (gnu_temp_stmt
) = Sloc (gnat_when
);
2308 add_stmt (gnu_temp_stmt
);
2310 gnu_block
= gnat_poplevel ();
2311 gnu_temp_stmt
= end_block_stmt (gnu_block
!= 0);
2313 BLOCK_STMT_BLOCK (gnu_temp_stmt
) = gnu_block
;
2315 expand_expr_stmt (gnu_temp_stmt
);
2318 expand_end_case (gnu_expr
);
2322 case N_Loop_Statement
:
2324 /* The loop variable in GCC form, if any. */
2325 tree gnu_loop_var
= NULL_TREE
;
2326 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2327 enum tree_code gnu_update
= ERROR_MARK
;
2328 /* Used if this is a named loop for so EXIT can work. */
2329 struct nesting
*loop_id
;
2330 /* Condition to continue loop tested at top of loop. */
2331 tree gnu_top_condition
= integer_one_node
;
2332 /* Similar, but tested at bottom of loop. */
2333 tree gnu_bottom_condition
= integer_one_node
;
2334 Node_Id gnat_statement
;
2335 Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2336 Node_Id gnat_top_condition
= Empty
;
2337 int enclosing_if_p
= 0;
2339 /* Set the condition that under which the loop should continue.
2340 For "LOOP .... END LOOP;" the condition is always true. */
2341 if (No (gnat_iter_scheme
))
2343 /* The case "WHILE condition LOOP ..... END LOOP;" */
2344 else if (Present (Condition (gnat_iter_scheme
)))
2345 gnat_top_condition
= Condition (gnat_iter_scheme
);
2348 /* We have an iteration scheme. */
2349 Node_Id gnat_loop_spec
2350 = Loop_Parameter_Specification (gnat_iter_scheme
);
2351 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2352 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2353 tree gnu_type
= get_unpadded_type (gnat_type
);
2354 tree gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2355 tree gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2356 int reversep
= Reverse_Present (gnat_loop_spec
);
2357 tree gnu_first
= reversep
? gnu_high
: gnu_low
;
2358 tree gnu_last
= reversep
? gnu_low
: gnu_high
;
2359 enum tree_code end_code
= reversep
? GE_EXPR
: LE_EXPR
;
2360 tree gnu_base_type
= get_base_type (gnu_type
);
2362 = (reversep
? TYPE_MIN_VALUE (gnu_base_type
)
2363 : TYPE_MAX_VALUE (gnu_base_type
));
2365 /* We know the loop variable will not overflow if GNU_LAST is
2366 a constant and is not equal to GNU_LIMIT. If it might
2367 overflow, we have to move the limit test to the end of
2368 the loop. In that case, we have to test for an
2369 empty loop outside the loop. */
2370 if (TREE_CODE (gnu_last
) != INTEGER_CST
2371 || TREE_CODE (gnu_limit
) != INTEGER_CST
2372 || tree_int_cst_equal (gnu_last
, gnu_limit
))
2374 gnu_expr
= build_binary_op (LE_EXPR
, integer_type_node
,
2376 set_lineno (gnat_loop_spec
, 1);
2377 expand_start_cond (gnu_expr
, 0);
2381 /* Open a new nesting level that will surround the loop to declare
2382 the loop index variable. */
2384 expand_start_bindings (0);
2386 /* Declare the loop index and set it to its initial value. */
2387 start_block_stmt ();
2388 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2389 expand_expr_stmt (end_block_stmt (false));
2390 if (DECL_BY_REF_P (gnu_loop_var
))
2391 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2394 /* The loop variable might be a padded type, so use `convert' to
2395 get a reference to the inner variable if so. */
2396 gnu_loop_var
= convert (get_base_type (gnu_type
), gnu_loop_var
);
2398 /* Set either the top or bottom exit condition as
2399 appropriate depending on whether we know an overflow
2400 cannot occur or not. */
2402 gnu_bottom_condition
2403 = build_binary_op (NE_EXPR
, integer_type_node
,
2404 gnu_loop_var
, gnu_last
);
2407 = build_binary_op (end_code
, integer_type_node
,
2408 gnu_loop_var
, gnu_last
);
2410 gnu_update
= reversep
? PREDECREMENT_EXPR
: PREINCREMENT_EXPR
;
2413 set_lineno (gnat_node
, 1);
2415 loop_id
= expand_start_loop_continue_elsewhere (1);
2417 loop_id
= expand_start_loop (1);
2419 /* If the loop was named, have the name point to this loop. In this
2420 case, the association is not a ..._DECL node; in fact, it isn't
2421 a GCC tree node at all. Since this name is referenced inside
2422 the loop, do it before we process the statements of the loop. */
2423 if (Present (Identifier (gnat_node
)))
2425 tree gnu_loop_id
= make_node (GNAT_LOOP_ID
);
2427 TREE_LOOP_ID (gnu_loop_id
) = loop_id
;
2428 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_id
, 1);
2431 set_lineno (gnat_node
, 1);
2433 /* We must evaluate the condition after we've entered the
2434 loop so that any expression actions get done in the right
2436 if (Present (gnat_top_condition
))
2437 gnu_top_condition
= gnat_to_gnu (gnat_top_condition
);
2439 expand_exit_loop_top_cond (0, gnu_top_condition
);
2441 /* Make the loop body into its own block, so any allocated
2442 storage will be released every iteration. This is needed
2443 for stack allocation. */
2447 = tree_cons (gnu_bottom_condition
, NULL_TREE
, gnu_block_stack
);
2448 expand_start_bindings (0);
2450 for (gnat_statement
= First (Statements (gnat_node
));
2451 Present (gnat_statement
);
2452 gnat_statement
= Next (gnat_statement
))
2453 gnat_to_code (gnat_statement
);
2455 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
2457 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2459 set_lineno (gnat_node
, 1);
2460 expand_exit_loop_if_false (0, gnu_bottom_condition
);
2464 expand_loop_continue_here ();
2465 gnu_expr
= build_binary_op (gnu_update
, TREE_TYPE (gnu_loop_var
),
2467 convert (TREE_TYPE (gnu_loop_var
),
2469 set_lineno (gnat_iter_scheme
, 1);
2470 expand_expr_stmt (gnu_expr
);
2473 set_lineno (gnat_node
, 1);
2478 /* Close the nesting level that sourround the loop that was used to
2479 declare the loop index variable. */
2480 set_lineno (gnat_node
, 1);
2481 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
2487 set_lineno (gnat_node
, 1);
2493 case N_Block_Statement
:
2495 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2496 expand_start_bindings (0);
2497 start_block_stmt ();
2498 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2499 gnat_expand_stmt (end_block_stmt (false));
2500 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2501 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
2503 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2504 if (Present (Identifier (gnat_node
)))
2505 mark_out_of_scope (Entity (Identifier (gnat_node
)));
2508 case N_Exit_Statement
:
2510 /* Which loop to exit, NULL if the current loop. */
2511 struct nesting
*loop_id
= 0;
2512 /* The GCC version of the optional GNAT condition node attached to the
2513 exit statement. Exit the loop if this is false. */
2514 tree gnu_cond
= integer_zero_node
;
2516 if (Present (Name (gnat_node
)))
2518 = TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node
))));
2520 if (Present (Condition (gnat_node
)))
2521 gnu_cond
= invert_truthvalue (gnat_truthvalue_conversion
2522 (gnat_to_gnu (Condition (gnat_node
))));
2524 set_lineno (gnat_node
, 1);
2525 expand_exit_loop_if_false (loop_id
, gnu_cond
);
2529 case N_Return_Statement
:
2531 /* The gnu function type of the subprogram currently processed. */
2532 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
2533 /* The return value from the subprogram. */
2534 tree gnu_ret_val
= 0;
2536 /* If we are dealing with a "return;" from an Ada procedure with
2537 parameters passed by copy in copy out, we need to return a record
2538 containing the final values of these parameters. If the list
2539 contains only one entry, return just that entry.
2541 For a full description of the copy in copy out parameter mechanism,
2542 see the part of the gnat_to_gnu_entity routine dealing with the
2543 translation of subprograms.
2545 But if we have a return label defined, convert this into
2546 a branch to that label. */
2548 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2550 gnu_result
= build_nt (GOTO_STMT
,
2551 TREE_VALUE (gnu_return_label_stack
));
2555 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
2557 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type
)) == 1)
2558 gnu_ret_val
= TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type
));
2561 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
2562 TYPE_CI_CO_LIST (gnu_subprog_type
));
2565 /* If the Ada subprogram is a function, we just need to return the
2566 expression. If the subprogram returns an unconstrained
2567 array, we have to allocate a new version of the result and
2568 return it. If we return by reference, return a pointer. */
2570 else if (Present (Expression (gnat_node
)))
2572 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
2574 /* Do not remove the padding from GNU_RET_VAL if the inner
2575 type is self-referential since we want to allocate the fixed
2576 size in that case. */
2577 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
2578 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0)))
2580 && (TYPE_IS_PADDING_P
2581 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
2582 && (CONTAINS_PLACEHOLDER_P
2583 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
)))))
2584 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
2586 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type
)
2587 || By_Ref (gnat_node
))
2588 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
2590 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
))
2592 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
2594 /* We have two cases: either the function returns with
2595 depressed stack or not. If not, we allocate on the
2596 secondary stack. If so, we allocate in the stack frame.
2597 if no copy is needed, the front end will set By_Ref,
2598 which we handle in the case above. */
2599 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type
))
2601 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2602 TREE_TYPE (gnu_subprog_type
), 0, -1,
2606 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2607 TREE_TYPE (gnu_subprog_type
),
2608 Procedure_To_Call (gnat_node
),
2609 Storage_Pool (gnat_node
), gnat_node
);
2613 gnu_result
= build_nt (RETURN_STMT
, gnu_ret_val
);
2617 case N_Goto_Statement
:
2618 gnu_result
= build_nt (GOTO_STMT
, gnat_to_gnu (Name (gnat_node
)));
2621 /****************************/
2622 /* Chapter 6: Subprograms: */
2623 /****************************/
2625 case N_Subprogram_Declaration
:
2626 /* Unless there is a freeze node, declare the subprogram. We consider
2627 this a "definition" even though we're not generating code for
2628 the subprogram because we will be making the corresponding GCC
2631 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
2632 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
2637 case N_Abstract_Subprogram_Declaration
:
2638 /* This subprogram doesn't exist for code generation purposes, but we
2639 have to elaborate the types of any parameters, unless they are
2640 imported types (nothing to generate in this case). */
2642 = First_Formal (Defining_Entity (Specification (gnat_node
)));
2643 Present (gnat_temp
);
2644 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
2645 if (Is_Itype (Etype (gnat_temp
))
2646 && !From_With_Type (Etype (gnat_temp
)))
2647 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2651 case N_Defining_Program_Unit_Name
:
2652 /* For a child unit identifier go up a level to get the
2653 specificaton. We get this when we try to find the spec of
2654 a child unit package that is the compilation unit being compiled. */
2655 gnat_to_code (Parent (gnat_node
));
2658 case N_Subprogram_Body
:
2660 /* Save debug output mode in case it is reset. */
2661 enum debug_info_type save_write_symbols
= write_symbols
;
2662 const struct gcc_debug_hooks
*const save_debug_hooks
= debug_hooks
;
2663 /* Definining identifier of a parameter to the subprogram. */
2664 Entity_Id gnat_param
;
2665 /* The defining identifier for the subprogram body. Note that if a
2666 specification has appeared before for this body, then the identifier
2667 occurring in that specification will also be a defining identifier
2668 and all the calls to this subprogram will point to that
2670 Entity_Id gnat_subprog_id
2671 = (Present (Corresponding_Spec (gnat_node
))
2672 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
2674 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2675 tree gnu_subprog_decl
;
2676 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2677 tree gnu_subprog_type
;
2680 /* If this is a generic object or if it has been eliminated,
2683 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
2684 || Ekind (gnat_subprog_id
) == E_Generic_Function
2685 || Is_Eliminated (gnat_subprog_id
))
2688 /* If debug information is suppressed for the subprogram,
2689 turn debug mode off for the duration of processing. */
2690 if (!Needs_Debug_Info (gnat_subprog_id
))
2692 write_symbols
= NO_DEBUG
;
2693 debug_hooks
= &do_nothing_debug_hooks
;
2696 /* If this subprogram acts as its own spec, define it. Otherwise,
2697 just get the already-elaborated tree node. However, if this
2698 subprogram had its elaboration deferred, we will already have
2699 made a tree node for it. So treat it as not being defined in
2700 that case. Such a subprogram cannot have an address clause or
2701 a freeze node, so this test is safe, though it does disable
2702 some otherwise-useful error checking. */
2704 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
2705 Acts_As_Spec (gnat_node
)
2706 && ! present_gnu_tree (gnat_subprog_id
));
2708 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
2710 /* ??? Temporarily do this to avoid GC throwing away outer stuff. */
2711 ggc_push_context ();
2713 /* Set the line number in the decl to correspond to that of
2714 the body so that the line number notes are written
2716 set_lineno (gnat_node
, 0);
2717 DECL_SOURCE_LOCATION (gnu_subprog_decl
) = input_location
;
2719 begin_subprog_body (gnu_subprog_decl
);
2721 /* There used to be a second call to set_lineno here, with
2722 write_note_p set, but begin_subprog_body actually already emits the
2723 note we want (via init_function_start).
2725 Emitting a second note here was necessary for -ftest-coverage with
2726 GCC 2.8.1, as the first one was skipped by branch_prob. This is no
2727 longer the case with GCC 3.x, so emitting a second note here would
2728 result in having the first line of the subprogram counted twice by
2732 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2733 expand_start_bindings (0);
2734 start_block_stmt ();
2736 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2738 /* If there are OUT parameters, we need to ensure that the
2739 return statement properly copies them out. We do this by
2740 making a new block and converting any inner return into a goto
2741 to a label at the end of the block. */
2743 if (gnu_cico_list
!= 0)
2745 gnu_return_label_stack
2746 = tree_cons (NULL_TREE
,
2747 build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
),
2748 gnu_return_label_stack
);
2750 expand_start_bindings (0);
2753 gnu_return_label_stack
2754 = tree_cons (NULL_TREE
, NULL_TREE
, gnu_return_label_stack
);
2756 /* See if there are any parameters for which we don't yet have
2757 GCC entities. These must be for OUT parameters for which we
2758 will be making VAR_DECL nodes here. Fill them in to
2759 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2760 We can match up the entries because TYPE_CI_CO_LIST is in the
2761 order of the parameters. */
2763 for (gnat_param
= First_Formal (gnat_subprog_id
);
2764 Present (gnat_param
);
2765 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2766 if (!present_gnu_tree (gnat_param
))
2768 /* Skip any entries that have been already filled in; they
2769 must correspond to IN OUT parameters. */
2770 for (; gnu_cico_list
!= 0 && TREE_VALUE (gnu_cico_list
) != 0;
2771 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
))
2774 /* Do any needed references for padded types. */
2775 TREE_VALUE (gnu_cico_list
)
2776 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list
)),
2777 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
2780 gnat_expand_stmt (end_block_stmt (false));
2781 start_block_stmt ();
2782 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2783 gnat_expand_stmt (end_block_stmt (false));
2785 /* Generate the code of the subprogram itself. A return statement
2786 will be present and any OUT parameters will be handled there. */
2787 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2789 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
2791 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2793 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2797 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
2799 expand_label (TREE_VALUE (gnu_return_label_stack
));
2801 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2802 set_lineno (gnat_node
, 1);
2803 if (list_length (gnu_cico_list
) == 1)
2804 gnu_retval
= TREE_VALUE (gnu_cico_list
);
2806 gnu_retval
= gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
2809 if (DECL_P (gnu_retval
) && DECL_BY_REF_P (gnu_retval
))
2811 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_retval
);
2814 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2815 DECL_RESULT (current_function_decl
),
2820 gnu_return_label_stack
= TREE_CHAIN (gnu_return_label_stack
);
2822 /* Disconnect the trees for parameters that we made variables for
2823 from the GNAT entities since these will become unusable after
2824 we end the function. */
2825 for (gnat_param
= First_Formal (gnat_subprog_id
);
2826 Present (gnat_param
);
2827 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2828 if (TREE_CODE (get_gnu_tree (gnat_param
)) == VAR_DECL
)
2829 save_gnu_tree (gnat_param
, NULL_TREE
, 0);
2831 end_subprog_body ();
2832 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
2833 write_symbols
= save_write_symbols
;
2834 debug_hooks
= save_debug_hooks
;
2839 case N_Function_Call
:
2840 case N_Procedure_Call_Statement
:
2842 /* The GCC node corresponding to the GNAT subprogram name. This can
2843 either be a FUNCTION_DECL node if we are dealing with a standard
2844 subprogram call, or an indirect reference expression (an
2845 INDIRECT_REF node) pointing to a subprogram. */
2846 tree gnu_subprog_node
= gnat_to_gnu (Name (gnat_node
));
2847 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2848 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog_node
);
2849 tree gnu_subprog_addr
2850 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog_node
);
2851 Entity_Id gnat_formal
;
2852 Node_Id gnat_actual
;
2853 tree gnu_actual_list
= NULL_TREE
;
2854 tree gnu_name_list
= NULL_TREE
;
2855 tree gnu_before_list
= NULL_TREE
;
2856 tree gnu_after_list
= NULL_TREE
;
2857 tree gnu_subprog_call
;
2859 switch (Nkind (Name (gnat_node
)))
2862 case N_Operator_Symbol
:
2863 case N_Expanded_Name
:
2864 case N_Attribute_Reference
:
2865 if (Is_Eliminated (Entity (Name (gnat_node
))))
2866 Eliminate_Error_Msg (gnat_node
, Entity (Name (gnat_node
)));
2869 if (TREE_CODE (gnu_subprog_type
) != FUNCTION_TYPE
)
2872 /* If we are calling a stubbed function, make this into a
2873 raise of Program_Error. Elaborate all our args first. */
2875 if (TREE_CODE (gnu_subprog_node
) == FUNCTION_DECL
2876 && DECL_STUBBED_P (gnu_subprog_node
))
2878 for (gnat_actual
= First_Actual (gnat_node
);
2879 Present (gnat_actual
);
2880 gnat_actual
= Next_Actual (gnat_actual
))
2881 expand_expr_stmt (gnat_to_gnu (gnat_actual
));
2883 if (Nkind (gnat_node
) == N_Function_Call
)
2885 gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
2887 = build1 (NULL_EXPR
, gnu_result_type
,
2888 build_call_raise (PE_Stubbed_Subprogram_Called
));
2892 = build_nt (EXPR_STMT
,
2893 build_call_raise (PE_Stubbed_Subprogram_Called
));
2897 /* The only way we can be making a call via an access type is
2898 if Name is an explicit dereference. In that case, get the
2899 list of formal args from the type the access type is pointing
2900 to. Otherwise, get the formals from entity being called. */
2901 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2902 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
2903 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
2904 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2907 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
2909 /* Create the list of the actual parameters as GCC expects it, namely
2910 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2911 node is a parameter-expression and the TREE_PURPOSE field is
2912 null. Skip OUT parameters that are not passed by reference and
2913 don't need to be copied in. */
2915 for (gnat_actual
= First_Actual (gnat_node
);
2916 Present (gnat_actual
);
2917 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2918 gnat_actual
= Next_Actual (gnat_actual
))
2920 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
2921 /* We treat a conversion between aggregate types as if it
2922 is an unchecked conversion. */
2923 int unchecked_convert_p
2924 = (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
2925 || (Nkind (gnat_actual
) == N_Type_Conversion
2926 && Is_Composite_Type (Underlying_Type
2927 (Etype (gnat_formal
)))));
2929 = unchecked_convert_p
? Expression (gnat_actual
) : gnat_actual
;
2930 tree gnu_name
= gnat_to_gnu (gnat_name
);
2931 tree gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
));
2934 /* If it's possible we may need to use this expression twice,
2935 make sure than any side-effects are handled via SAVE_EXPRs.
2936 Likewise if we need to force side-effects before the call.
2937 ??? This is more conservative than we need since we don't
2938 need to do this for pass-by-ref with no conversion.
2939 If we are passing a non-addressable Out or In Out parameter by
2940 reference, pass the address of a copy and set up to copy back
2941 out after the call. */
2943 if (Ekind (gnat_formal
) != E_In_Parameter
)
2945 gnu_name
= gnat_stabilize_reference (gnu_name
, 1);
2946 if (! addressable_p (gnu_name
)
2947 && present_gnu_tree (gnat_formal
)
2948 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
2949 || (TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2950 && (DECL_BY_COMPONENT_PTR_P
2951 (get_gnu_tree (gnat_formal
))
2952 || DECL_BY_DESCRIPTOR_P
2953 (get_gnu_tree (gnat_formal
))))))
2955 tree gnu_copy
= gnu_name
;
2958 /* Remove any unpadding on the actual and make a copy.
2959 But if the actual is a left-justified modular type,
2960 first convert to it. */
2961 if (TREE_CODE (gnu_name
) == COMPONENT_REF
2962 && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name
, 0)))
2964 && (TYPE_IS_PADDING_P
2965 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))))
2966 gnu_name
= gnu_copy
= TREE_OPERAND (gnu_name
, 0);
2967 else if (TREE_CODE (gnu_name_type
) == RECORD_TYPE
2968 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2970 gnu_name
= convert (gnu_name_type
, gnu_name
);
2972 gnu_actual
= save_expr (gnu_name
);
2974 /* Since we're going to take the address of the SAVE_EXPR,
2975 we don't want it to be marked as unchanging.
2976 So set TREE_ADDRESSABLE. */
2977 gnu_temp
= skip_simple_arithmetic (gnu_actual
);
2978 if (TREE_CODE (gnu_temp
) == SAVE_EXPR
)
2980 TREE_ADDRESSABLE (gnu_temp
) = 1;
2981 TREE_READONLY (gnu_temp
) = 0;
2984 /* Set up to move the copy back to the original. */
2986 = build_nt (EXPR_STMT
,
2987 build (MODIFY_EXPR
, TREE_TYPE (gnu_copy
),
2988 gnu_copy
, gnu_actual
));
2990 TREE_TYPE (gnu_temp
) = void_type_node
;
2991 TREE_SLOC (gnu_temp
) = Sloc (gnat_actual
);
2992 TREE_CHAIN (gnu_temp
) = gnu_after_list
;
2993 gnu_after_list
= gnu_temp
;
2997 /* If this was a procedure call, we may not have removed any
2998 padding. So do it here for the part we will use as an
3000 gnu_actual
= gnu_name
;
3001 if (Ekind (gnat_formal
) != E_Out_Parameter
3002 && TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
3003 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
3004 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
3007 if (Ekind (gnat_formal
) != E_Out_Parameter
3008 && ! unchecked_convert_p
3009 && Do_Range_Check (gnat_actual
))
3010 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
3012 /* Do any needed conversions. We need only check for
3013 unchecked conversion since normal conversions will be handled
3014 by just converting to the formal type. */
3015 if (unchecked_convert_p
)
3018 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3020 (Nkind (gnat_actual
)
3021 == N_Unchecked_Type_Conversion
)
3022 && No_Truncation (gnat_actual
));
3024 /* One we've done the unchecked conversion, we still
3025 must ensure that the object is in range of the formal's
3027 if (Ekind (gnat_formal
) != E_Out_Parameter
3028 && Do_Range_Check (gnat_actual
))
3029 gnu_actual
= emit_range_check (gnu_actual
,
3030 Etype (gnat_formal
));
3032 else if (TREE_CODE (gnu_actual
) != SAVE_EXPR
)
3033 /* We may have suppressed a conversion to the Etype of the
3034 actual since the parent is a procedure call. So add the
3036 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
3039 if (TREE_CODE (gnu_actual
) != SAVE_EXPR
)
3040 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3042 /* If we have not saved a GCC object for the formal, it means it
3043 is an OUT parameter not passed by reference and that does not
3044 need to be copied in. Otherwise, look at the PARM_DECL to see
3045 if it is passed by reference. */
3046 if (present_gnu_tree (gnat_formal
)
3047 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3048 && DECL_BY_REF_P (get_gnu_tree (gnat_formal
)))
3050 if (Ekind (gnat_formal
) != E_In_Parameter
)
3052 gnu_actual
= gnu_name
;
3054 /* If we have a padded type, be sure we've removed the
3056 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
3057 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
))
3058 && TREE_CODE (gnu_actual
) != SAVE_EXPR
)
3060 = convert (get_unpadded_type (Etype (gnat_actual
)),
3064 /* Otherwise, if we have a non-addressable COMPONENT_REF of a
3065 variable-size type see if it's doing a unpadding operation.
3066 If so, remove that operation since we have no way of
3067 allocating the required temporary. */
3068 if (TREE_CODE (gnu_actual
) == COMPONENT_REF
3069 && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
3070 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual
, 0)))
3072 && TYPE_IS_PADDING_P (TREE_TYPE
3073 (TREE_OPERAND (gnu_actual
, 0)))
3074 && !addressable_p (gnu_actual
))
3075 gnu_actual
= TREE_OPERAND (gnu_actual
, 0);
3077 /* The symmetry of the paths to the type of an entity is
3078 broken here since arguments don't know that they will
3079 be passed by ref. */
3080 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
3081 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
,
3084 else if (present_gnu_tree (gnat_formal
)
3085 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3086 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
)))
3088 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
3089 gnu_actual
= maybe_implicit_deref (gnu_actual
);
3090 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
3092 if (TREE_CODE (gnu_formal_type
) == RECORD_TYPE
3093 && TYPE_IS_PADDING_P (gnu_formal_type
))
3096 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
3097 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3100 /* Take the address of the object and convert to the
3101 proper pointer type. We'd like to actually compute
3102 the address of the beginning of the array using
3103 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
3104 that the ARRAY_REF might return a constant and we'd
3105 be getting the wrong address. Neither approach is
3106 exactly correct, but this is the most likely to work
3108 gnu_actual
= convert (gnu_formal_type
,
3109 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3112 else if (present_gnu_tree (gnat_formal
)
3113 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3114 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
)))
3116 /* If arg is 'Null_Parameter, pass zero descriptor. */
3117 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
3118 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
3119 && TREE_PRIVATE (gnu_actual
))
3121 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
3125 = build_unary_op (ADDR_EXPR
, NULL_TREE
,
3126 fill_vms_descriptor (gnu_actual
,
3131 tree gnu_actual_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
));
3133 if (Ekind (gnat_formal
) != E_In_Parameter
)
3135 = chainon (gnu_name_list
,
3136 build_tree_list (NULL_TREE
, gnu_name
));
3138 if (! present_gnu_tree (gnat_formal
)
3139 || TREE_CODE (get_gnu_tree (gnat_formal
)) != PARM_DECL
)
3142 /* If this is 'Null_Parameter, pass a zero even though we are
3143 dereferencing it. */
3144 else if (TREE_CODE (gnu_actual
) == INDIRECT_REF
3145 && TREE_PRIVATE (gnu_actual
)
3146 && host_integerp (gnu_actual_size
, 1)
3147 && 0 >= compare_tree_int (gnu_actual_size
,
3151 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
3152 convert (gnat_type_for_size
3153 (tree_low_cst (gnu_actual_size
, 1), 1),
3154 integer_zero_node
), 0);
3157 = convert (TYPE_MAIN_VARIANT
3158 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
))),
3163 = chainon (gnu_actual_list
,
3164 build_tree_list (NULL_TREE
, gnu_actual
));
3167 gnu_subprog_call
= build (CALL_EXPR
, TREE_TYPE (gnu_subprog_type
),
3168 gnu_subprog_addr
, gnu_actual_list
,
3170 TREE_SIDE_EFFECTS (gnu_subprog_call
) = 1;
3172 /* If it is a function call, the result is the call expression. */
3173 if (Nkind (gnat_node
) == N_Function_Call
)
3175 gnu_result
= gnu_subprog_call
;
3177 /* If the function returns an unconstrained array or by reference,
3178 we have to de-dereference the pointer. */
3179 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
)
3180 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type
))
3181 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3184 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3188 /* If this is the case where the GNAT tree contains a procedure call
3189 but the Ada procedure has copy in copy out parameters, the special
3190 parameter passing mechanism must be used. */
3191 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
3193 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3194 in copy out parameters. */
3195 tree scalar_return_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3196 int length
= list_length (scalar_return_list
);
3202 gnu_subprog_call
= protect_multiple_eval (gnu_subprog_call
);
3204 /* If any of the names had side-effects, ensure they are
3205 all evaluated before the call. */
3206 for (gnu_name
= gnu_name_list
; gnu_name
;
3207 gnu_name
= TREE_CHAIN (gnu_name
))
3208 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name
)))
3210 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_subprog_call
),
3211 TREE_VALUE (gnu_name
), gnu_subprog_call
);
3214 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3215 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
3217 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
3219 for (gnat_actual
= First_Actual (gnat_node
);
3220 Present (gnat_actual
);
3221 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3222 gnat_actual
= Next_Actual (gnat_actual
))
3223 /* If we are dealing with a copy in copy out parameter, we must
3224 retrieve its value from the record returned in the function
3226 if (! (present_gnu_tree (gnat_formal
)
3227 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3228 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3229 || ((TREE_CODE (get_gnu_tree (gnat_formal
))
3231 && ((DECL_BY_COMPONENT_PTR_P
3232 (get_gnu_tree (gnat_formal
))
3233 || (DECL_BY_DESCRIPTOR_P
3234 (get_gnu_tree (gnat_formal
))))))))
3235 && Ekind (gnat_formal
) != E_In_Parameter
)
3237 /* Get the value to assign to this OUT or IN OUT
3238 parameter. It is either the result of the function if
3239 there is only a single such parameter or the appropriate
3240 field from the record returned. */
3242 = length
== 1 ? gnu_subprog_call
3243 : build_component_ref
3244 (gnu_subprog_call
, NULL_TREE
,
3245 TREE_PURPOSE (scalar_return_list
), 0);
3246 int unchecked_conversion
3247 = Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
;
3248 /* If the actual is a conversion, get the inner expression,
3249 which will be the real destination, and convert the
3250 result to the type of the actual parameter. */
3252 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3254 /* If the result is a padded type, remove the padding. */
3255 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3256 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3258 = convert (TREE_TYPE (TYPE_FIELDS
3259 (TREE_TYPE (gnu_result
))),
3262 /* If the result is a type conversion, do it. */
3263 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3265 = convert_with_check
3266 (Etype (Expression (gnat_actual
)), gnu_result
,
3267 Do_Overflow_Check (gnat_actual
),
3268 Do_Range_Check (Expression (gnat_actual
)),
3269 Float_Truncate (gnat_actual
));
3271 else if (unchecked_conversion
)
3273 = unchecked_convert (TREE_TYPE (gnu_actual
), gnu_result
,
3274 No_Truncation (gnat_actual
));
3277 if (Do_Range_Check (gnat_actual
))
3278 gnu_result
= emit_range_check (gnu_result
,
3279 Etype (gnat_actual
));
3281 if (! (! TREE_CONSTANT (TYPE_SIZE
3282 (TREE_TYPE (gnu_actual
)))
3283 && TREE_CONSTANT (TYPE_SIZE
3284 (TREE_TYPE (gnu_result
)))))
3285 gnu_result
= convert (TREE_TYPE (gnu_actual
),
3290 = build_nt (EXPR_STMT
,
3291 build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3292 gnu_actual
, gnu_result
));
3293 TREE_TYPE (gnu_result
) = void_type_node
;
3294 TREE_SLOC (gnu_result
) = Sloc (gnat_actual
);
3295 TREE_CHAIN (gnu_result
) = gnu_before_list
;
3296 gnu_before_list
= gnu_result
;
3297 scalar_return_list
= TREE_CHAIN (scalar_return_list
);
3298 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3303 gnu_before_list
= build_nt (EXPR_STMT
, gnu_subprog_call
);
3304 TREE_TYPE (gnu_before_list
) = void_type_node
;
3305 TREE_SLOC (gnu_before_list
) = Sloc (gnat_node
);
3308 gnu_result
= chainon (nreverse (gnu_before_list
),
3309 nreverse (gnu_after_list
));
3310 if (TREE_CHAIN (gnu_result
))
3311 gnu_result
= build_nt (BLOCK_STMT
, gnu_result
, NULL_TREE
);
3315 /*************************/
3316 /* Chapter 7: Packages: */
3317 /*************************/
3319 case N_Package_Declaration
:
3320 gnat_to_code (Specification (gnat_node
));
3323 case N_Package_Specification
:
3325 start_block_stmt ();
3326 process_decls (Visible_Declarations (gnat_node
),
3327 Private_Declarations (gnat_node
), Empty
, 1, 1);
3328 gnat_expand_stmt (end_block_stmt (false));
3331 case N_Package_Body
:
3333 /* If this is the body of a generic package - do nothing */
3334 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
3337 start_block_stmt ();
3338 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
3339 gnat_expand_stmt (end_block_stmt (false));
3341 if (Present (Handled_Statement_Sequence (gnat_node
)))
3343 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
3344 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
3345 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
3349 /*********************************/
3350 /* Chapter 8: Visibility Rules: */
3351 /*********************************/
3353 case N_Use_Package_Clause
:
3354 case N_Use_Type_Clause
:
3355 /* Nothing to do here - but these may appear in list of declarations */
3358 /***********************/
3359 /* Chapter 9: Tasks: */
3360 /***********************/
3362 case N_Protected_Type_Declaration
:
3365 case N_Single_Task_Declaration
:
3366 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
3369 /***********************************************************/
3370 /* Chapter 10: Program Structure and Compilation Issues: */
3371 /***********************************************************/
3373 case N_Compilation_Unit
:
3375 /* For a body, first process the spec if there is one. */
3376 if (Nkind (Unit (gnat_node
)) == N_Package_Body
3377 || (Nkind (Unit (gnat_node
)) == N_Subprogram_Body
3378 && ! Acts_As_Spec (gnat_node
)))
3379 gnat_to_code (Library_Unit (gnat_node
));
3381 process_inlined_subprograms (gnat_node
);
3383 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
3385 elaborate_all_entities (gnat_node
);
3387 if (Nkind (Unit (gnat_node
)) == N_Subprogram_Declaration
3388 || Nkind (Unit (gnat_node
)) == N_Generic_Package_Declaration
3389 || Nkind (Unit (gnat_node
)) == N_Generic_Subprogram_Declaration
)
3394 process_decls (Declarations (Aux_Decls_Node (gnat_node
)),
3395 Empty
, Empty
, 1, 1);
3396 gnat_expand_stmt (end_block_stmt (false));
3398 gnat_to_code (Unit (gnat_node
));
3400 /* Process any pragmas following the unit. */
3401 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node
))))
3402 for (gnat_temp
= First (Pragmas_After (Aux_Decls_Node (gnat_node
)));
3403 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3404 gnat_to_code (gnat_temp
);
3406 /* Put all the Actions into the elaboration routine if we already had
3407 elaborations. This will happen anyway if they are statements, but we
3408 want to force declarations there too due to order-of-elaboration
3409 issues. Most should have Is_Statically_Allocated set. If we
3410 have had no elaborations, we have no order-of-elaboration issue and
3411 don't want to create elaborations here. */
3412 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node
))))
3413 for (gnat_temp
= First (Actions (Aux_Decls_Node (gnat_node
)));
3414 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3416 if (pending_elaborations_p ())
3417 add_pending_elaborations (NULL_TREE
,
3418 make_transform_expr (gnat_temp
));
3420 gnat_to_code (gnat_temp
);
3423 /* Generate elaboration code for this unit, if necessary, and
3424 say whether we did or not. */
3425 Set_Has_No_Elaboration_Code
3428 (Defining_Entity (Unit (gnat_node
)),
3429 Nkind (Unit (gnat_node
)) == N_Package_Body
3430 || Nkind (Unit (gnat_node
)) == N_Subprogram_Body
,
3431 get_pending_elaborations ()));
3435 case N_Subprogram_Body_Stub
:
3436 case N_Package_Body_Stub
:
3437 case N_Protected_Body_Stub
:
3438 case N_Task_Body_Stub
:
3439 /* Simply process whatever unit is being inserted. */
3440 gnat_to_code (Unit (Library_Unit (gnat_node
)));
3444 gnat_to_code (Proper_Body (gnat_node
));
3447 /***************************/
3448 /* Chapter 11: Exceptions: */
3449 /***************************/
3451 case N_Handled_Sequence_Of_Statements
:
3453 /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3454 schemes and we have our own SJLJ mechanism. To call the GCC
3455 mechanism, we first call expand_eh_region_start if there is at least
3456 one handler associated with the region. We then generate code for
3457 the region and call expand_start_all_catch to announce that the
3458 associated handlers are going to be generated.
3460 For each handler we call expand_start_catch, generate code for the
3461 handler, and then call expand_end_catch.
3463 After all the handlers, we call expand_end_all_catch.
3465 Here we deal with the region level calls and the
3466 N_Exception_Handler branch deals with the handler level calls
3467 (start_catch/end_catch).
3469 ??? The region level calls down there have been specifically put in
3470 place for a ZCX context and currently the order in which things are
3471 emitted (region/handlers) is different from the SJLJ case. Instead of
3472 putting other calls with different conditions at other places for the
3473 SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3474 generalize the condition to make it not ZCX specific. */
3476 /* If there is an At_End procedure attached to this node, and the eh
3477 mechanism is GNAT oriented (SJLJ or ZCX with front end tables), we
3478 must have at least a corresponding At_End handler, unless the
3479 No_Exception_Handlers restriction is set. */
3480 if (! type_annotate_only
3481 && Exception_Mechanism
!= GCC_ZCX
3482 && Present (At_End_Proc (gnat_node
))
3483 && ! Present (Exception_Handlers (gnat_node
))
3484 && ! No_Exception_Handlers_Set())
3488 /* Need a binding level that we can exit for this sequence if there is
3489 at least one exception handler for this block (since each handler
3490 needs an identified exit point) or there is an At_End procedure
3491 attached to this node (in order to have an attachment point for a
3493 bool exitable_binding_for_block
3494 = (! type_annotate_only
3495 && (Present (Exception_Handlers (gnat_node
))
3496 || Present (At_End_Proc (gnat_node
))));
3498 /* Make a binding level that we can exit if we need one. */
3499 if (exitable_binding_for_block
)
3502 expand_start_bindings (1);
3505 /* If we are to call a function when exiting this block, expand a GCC
3506 cleanup to take care. We have made a binding level for this cleanup
3508 if (Present (At_End_Proc (gnat_node
)))
3510 tree gnu_cleanup_call
3511 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3513 tree gnu_cleanup_decl
3514 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3515 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3518 start_block_stmt ();
3519 add_decl_stmt (gnu_cleanup_decl
, gnat_node
);
3520 gnat_expand_stmt (end_block_stmt (false));
3521 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3524 /* Now we generate the code for this block, with a different layout
3525 for GNAT SJLJ and for GCC or front end ZCX. The handlers come first
3526 in the GNAT SJLJ case, while they come after the handled sequence
3527 in the other cases. */
3529 /* First deal with possible handlers for the GNAT SJLJ scheme. */
3530 if (! type_annotate_only
3531 && Exception_Mechanism
== Setjmp_Longjmp
3532 && Present (Exception_Handlers (gnat_node
)))
3534 /* We already have a fresh binding level at hand. Declare a
3535 variable to save the old __gnat_jmpbuf value and a variable for
3536 our jmpbuf. Call setjmp and handle each of the possible
3537 exceptions if it returns one. */
3539 tree gnu_jmpsave_decl
3540 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
3542 build_call_0_expr (get_jmpbuf_decl
),
3545 tree gnu_jmpbuf_decl
3546 = create_var_decl (get_identifier ("JMP_BUF"),
3547 NULL_TREE
, jmpbuf_type
,
3548 NULL_TREE
, 0, 0, 0, 0,
3551 start_block_stmt ();
3552 add_decl_stmt (gnu_jmpsave_decl
, gnat_node
);
3553 add_decl_stmt (gnu_jmpbuf_decl
, gnat_node
);
3554 gnat_expand_stmt (end_block_stmt (false));
3556 TREE_VALUE (gnu_block_stack
) = gnu_jmpbuf_decl
;
3558 /* When we exit this block, restore the saved value. */
3559 expand_decl_cleanup (gnu_jmpsave_decl
,
3560 build_call_1_expr (set_jmpbuf_decl
,
3563 /* Call setjmp and handle exceptions if it returns one. */
3564 set_lineno (gnat_node
, 1);
3566 (build_call_1_expr (setjmp_decl
,
3567 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3571 /* Restore our incoming longjmp value before we do anything. */
3573 (build_call_1_expr (set_jmpbuf_decl
, gnu_jmpsave_decl
));
3575 /* Make a binding level for the exception handling declarations
3576 and code. Don't assign it an exit label, since this is the
3577 outer block we want to exit at the end of each handler. */
3579 expand_start_bindings (0);
3581 gnu_except_ptr_stack
3582 = tree_cons (NULL_TREE
,
3584 (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
3585 build_pointer_type (except_type_node
),
3586 build_call_0_expr (get_excptr_decl
),
3588 gnu_except_ptr_stack
);
3589 start_block_stmt ();
3590 add_decl_stmt (TREE_VALUE (gnu_except_ptr_stack
), gnat_node
);
3591 gnat_expand_stmt (end_block_stmt (false));
3593 /* Generate code for each handler. The N_Exception_Handler case
3594 below does the real work. We ignore the dummy exception handler
3595 for the identifier case, as this is used only by the front
3597 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3598 Present (gnat_temp
);
3599 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3600 gnat_to_code (gnat_temp
);
3602 /* If none of the exception handlers did anything, re-raise
3603 but do not defer abortion. */
3604 set_lineno (gnat_node
, 1);
3606 (build_call_1_expr (raise_nodefer_decl
,
3607 TREE_VALUE (gnu_except_ptr_stack
)));
3609 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3611 /* End the binding level dedicated to the exception handlers. */
3612 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
3615 /* End the "if" on setjmp. Note that we have arranged things so
3616 control never returns here. */
3619 /* This is now immediately before the body proper. Set our jmp_buf
3620 as the current buffer. */
3622 (build_call_1_expr (set_jmpbuf_decl
,
3623 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3627 /* Now comes the processing for the sequence body. */
3629 /* If we use the back-end eh support, tell the back-end we are
3630 starting a new exception region. */
3631 if (! type_annotate_only
3632 && Exception_Mechanism
== GCC_ZCX
3633 && Present (Exception_Handlers (gnat_node
)))
3634 expand_eh_region_start ();
3636 /* Generate code and declarations for the prefix of this block,
3638 start_block_stmt ();
3639 if (Present (First_Real_Statement (gnat_node
)))
3640 process_decls (Statements (gnat_node
), Empty
,
3641 First_Real_Statement (gnat_node
), 1, 1);
3642 gnat_expand_stmt (end_block_stmt (false));
3644 /* Generate code for each statement in the block. */
3645 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
3646 ? First_Real_Statement (gnat_node
)
3647 : First (Statements (gnat_node
)));
3648 Present (gnat_temp
);
3649 gnat_temp
= Next (gnat_temp
))
3650 gnat_to_code (gnat_temp
);
3652 /* Exit the binding level we made, if any. */
3653 if (exitable_binding_for_block
)
3654 expand_exit_something ();
3656 /* Compile the handlers for front end ZCX or back-end supported
3658 if (! type_annotate_only
3659 && Exception_Mechanism
!= Setjmp_Longjmp
3660 && Present (Exception_Handlers (gnat_node
)))
3662 if (Exception_Mechanism
== GCC_ZCX
)
3663 expand_start_all_catch ();
3665 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3666 Present (gnat_temp
);
3667 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3668 gnat_to_code (gnat_temp
);
3670 if (Exception_Mechanism
== GCC_ZCX
)
3671 expand_end_all_catch ();
3674 /* Close the binding level we made, if any. */
3675 if (exitable_binding_for_block
)
3677 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
3684 case N_Exception_Handler
:
3685 if (Exception_Mechanism
== Setjmp_Longjmp
)
3687 /* Unless this is "Others" or the special "Non-Ada" exception
3688 for Ada, make an "if" statement to select the proper
3689 exceptions. For "Others", exclude exceptions where
3690 Handled_By_Others is nonzero unless the All_Others flag is set.
3691 For "Non-ada", accept an exception if "Lang" is 'V'. */
3692 tree gnu_choice
= integer_zero_node
;
3694 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3695 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3699 if (Nkind (gnat_temp
) == N_Others_Choice
)
3701 if (All_Others (gnat_temp
))
3702 this_choice
= integer_one_node
;
3706 (EQ_EXPR
, integer_type_node
,
3711 (INDIRECT_REF
, NULL_TREE
,
3712 TREE_VALUE (gnu_except_ptr_stack
)),
3713 get_identifier ("not_handled_by_others"), NULL_TREE
,
3718 else if (Nkind (gnat_temp
) == N_Identifier
3719 || Nkind (gnat_temp
) == N_Expanded_Name
)
3721 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
3723 /* Exception may be a renaming. Recover original exception
3724 which is the one elaborated and registered. */
3725 if (Present (Renamed_Object (gnat_ex_id
)))
3726 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
3728 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
3732 (EQ_EXPR
, integer_type_node
,
3733 TREE_VALUE (gnu_except_ptr_stack
),
3735 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack
)),
3736 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
3738 /* If this is the distinguished exception "Non_Ada_Error"
3739 (and we are in VMS mode), also allow a non-Ada
3740 exception (a VMS condition) to match. */
3741 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
3744 = build_component_ref
3746 (INDIRECT_REF
, NULL_TREE
,
3747 TREE_VALUE (gnu_except_ptr_stack
)),
3748 get_identifier ("lang"), NULL_TREE
, 0);
3752 (TRUTH_ORIF_EXPR
, integer_type_node
,
3754 (EQ_EXPR
, integer_type_node
, gnu_comp
,
3755 convert (TREE_TYPE (gnu_comp
),
3756 build_int_2 ('V', 0))),
3763 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
3764 gnu_choice
, this_choice
);
3767 set_lineno (gnat_node
, 1);
3769 expand_start_cond (gnu_choice
, 0);
3772 /* Tell the back end that we start an exception handler if necessary. */
3773 if (Exception_Mechanism
== GCC_ZCX
)
3775 /* We build a TREE_LIST of nodes representing what exception
3776 types this handler is able to catch, with special cases
3777 for others and all others cases.
3779 Each exception type is actually identified by a pointer to the
3780 exception id, with special value zero for "others" and one for
3781 "all others". Beware that these special values are known and used
3782 by the personality routine to identify the corresponding specific
3785 ??? For initial time frame reasons, the others and all_others
3786 cases have been handled using specific type trees, but this
3787 somehow hides information to the back-end, which expects NULL to
3788 be passed for catch all and end_cleanup to be used for cleanups.
3790 Care should be taken to ensure that the control flow impact of
3791 such clauses is rendered in some way. lang_eh_type_covers is
3792 doing the trick currently. */
3794 tree gnu_expr
, gnu_etype
;
3795 tree gnu_etypes_list
= NULL_TREE
;
3797 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3798 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3800 if (Nkind (gnat_temp
) == N_Others_Choice
)
3802 = All_Others (gnat_temp
) ? integer_one_node
3803 : integer_zero_node
;
3804 else if (Nkind (gnat_temp
) == N_Identifier
3805 || Nkind (gnat_temp
) == N_Expanded_Name
)
3807 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
3809 /* Exception may be a renaming. Recover original exception
3810 which is the one elaborated and registered. */
3811 if (Present (Renamed_Object (gnat_ex_id
)))
3812 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
3814 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
3817 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
3819 /* The Non_Ada_Error case for VMS exceptions is handled
3820 by the personality routine. */
3825 /* The GCC interface expects NULL to be passed for catch all
3826 handlers, so it would be quite tempting to set gnu_etypes_list
3827 to NULL if gnu_etype is integer_zero_node. It would not work,
3828 however, because GCC's notion of "catch all" is stronger than
3829 our notion of "others". Until we correctly use the cleanup
3830 interface as well, the doing tht would prevent the "all
3831 others" handlers from beeing seen, because nothing can be
3832 caught beyond a catch all from GCC's point of view. */
3834 = tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
3838 expand_start_catch (gnu_etypes_list
);
3841 expand_start_bindings (0);
3844 /* Expand a call to the begin_handler hook at the beginning of the
3845 handler, and arrange for a call to the end_handler hook to
3846 occur on every possible exit path.
3848 The hooks expect a pointer to the low level occurrence. This
3849 is required for our stack management scheme because a raise
3850 inside the handler pushes a new occurrence on top of the
3851 stack, which means that this top does not necessarily match
3852 the occurrence this handler was dealing with.
3854 The EXC_PTR_EXPR object references the exception occurrence
3855 beeing propagated. Upon handler entry, this is the exception
3856 for which the handler is triggered. This might not be the case
3857 upon handler exit, however, as we might have a new occurrence
3858 propagated by the handler's body, and the end_handler hook
3859 called as a cleanup in this context.
3861 We use a local variable to retrieve the incoming value at
3862 handler entry time, and reuse it to feed the end_handler
3863 hook's argument at exit time. */
3864 tree gnu_current_exc_ptr
3865 = build (EXC_PTR_EXPR
, ptr_type_node
);
3866 tree gnu_incoming_exc_ptr
3867 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
3868 ptr_type_node
, gnu_current_exc_ptr
,
3871 start_block_stmt ();
3872 add_decl_stmt (gnu_incoming_exc_ptr
, gnat_node
);
3873 gnat_expand_stmt (end_block_stmt (false));
3875 (build_call_1_expr (begin_handler_decl
, gnu_incoming_exc_ptr
));
3877 (0, build_call_1_expr (end_handler_decl
, gnu_incoming_exc_ptr
));
3881 for (gnat_temp
= First (Statements (gnat_node
));
3882 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3883 gnat_to_code (gnat_temp
);
3885 if (Exception_Mechanism
== GCC_ZCX
)
3887 /* Tell the back end that we're done with the current handler. */
3888 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
3890 expand_end_catch ();
3893 /* At the end of the handler, exit the block. We made this block in
3894 N_Handled_Sequence_Of_Statements. */
3895 expand_exit_something ();
3897 if (Exception_Mechanism
== Setjmp_Longjmp
)
3902 /*******************************/
3903 /* Chapter 12: Generic Units: */
3904 /*******************************/
3906 case N_Generic_Function_Renaming_Declaration
:
3907 case N_Generic_Package_Renaming_Declaration
:
3908 case N_Generic_Procedure_Renaming_Declaration
:
3909 case N_Generic_Package_Declaration
:
3910 case N_Generic_Subprogram_Declaration
:
3911 case N_Package_Instantiation
:
3912 case N_Procedure_Instantiation
:
3913 case N_Function_Instantiation
:
3914 /* These nodes can appear on a declaration list but there is nothing to
3915 to be done with them. */
3918 /***************************************************/
3919 /* Chapter 13: Representation Clauses and */
3920 /* Implementation-Dependent Features: */
3921 /***************************************************/
3923 case N_Attribute_Definition_Clause
:
3925 /* The only one we need deal with is for 'Address. For the others, SEM
3926 puts the information elsewhere. We need only deal with 'Address
3927 if the object has a Freeze_Node (which it never will currently). */
3928 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
3929 || No (Freeze_Node (Entity (Name (gnat_node
)))))
3932 /* Get the value to use as the address and save it as the
3933 equivalent for GNAT_TEMP. When the object is frozen,
3934 gnat_to_gnu_entity will do the right thing. */
3935 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3936 save_gnu_tree (Entity (Name (gnat_node
)), gnu_expr
, 1);
3939 case N_Enumeration_Representation_Clause
:
3940 case N_Record_Representation_Clause
:
3942 /* We do nothing with these. SEM puts the information elsewhere. */
3945 case N_Code_Statement
:
3946 if (! type_annotate_only
)
3948 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
3949 tree gnu_input_list
= 0, gnu_output_list
= 0, gnu_orig_out_list
= 0;
3950 tree gnu_clobber_list
= 0;
3953 /* First process inputs, then outputs, then clobbers. */
3954 Setup_Asm_Inputs (gnat_node
);
3955 while (Present (gnat_temp
= Asm_Input_Value ()))
3957 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3958 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3959 (Asm_Input_Constraint ()));
3962 = tree_cons (gnu_constr
, gnu_value
, gnu_input_list
);
3966 Setup_Asm_Outputs (gnat_node
);
3967 while (Present (gnat_temp
= Asm_Output_Variable ()))
3969 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3970 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3971 (Asm_Output_Constraint ()));
3974 = tree_cons (gnu_constr
, gnu_value
, gnu_orig_out_list
);
3976 = tree_cons (gnu_constr
, gnu_value
, gnu_output_list
);
3980 Clobber_Setup (gnat_node
);
3981 while ((clobber
= Clobber_Get_Next ()) != 0)
3983 = tree_cons (NULL_TREE
,
3984 build_string (strlen (clobber
) + 1, clobber
),
3987 gnu_input_list
= nreverse (gnu_input_list
);
3988 gnu_output_list
= nreverse (gnu_output_list
);
3989 gnu_orig_out_list
= nreverse (gnu_orig_out_list
);
3990 gnu_result
= build_nt (ASM_STMT
, gnu_template
, gnu_output_list
,
3991 gnu_orig_out_list
, gnu_input_list
,
3993 TREE_THIS_VOLATILE (gnu_result
) = Is_Asm_Volatile (gnat_node
);
3997 /***************************************************/
3999 /***************************************************/
4001 case N_Freeze_Entity
:
4002 process_freeze_entity (gnat_node
);
4003 start_block_stmt ();
4004 process_decls (Actions (gnat_node
), Empty
, Empty
, 1, 1);
4005 gnat_expand_stmt (end_block_stmt (false));
4008 case N_Itype_Reference
:
4009 if (! present_gnu_tree (Itype (gnat_node
)))
4010 process_type (Itype (gnat_node
));
4013 case N_Free_Statement
:
4014 if (! type_annotate_only
)
4016 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
4021 /* If this is a thin pointer, we must dereference it to create
4022 a fat pointer, then go back below to a thin pointer. The
4023 reason for this is that we need a fat pointer someplace in
4024 order to properly compute the size. */
4025 if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
4026 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
4027 build_unary_op (INDIRECT_REF
, NULL_TREE
,
4030 /* If this is an unconstrained array, we know the object must
4031 have been allocated with the template in front of the object.
4032 So pass the template address, but get the total size. Do this
4033 by converting to a thin pointer. */
4034 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
4036 = convert (build_pointer_type
4037 (TYPE_OBJECT_RECORD_TYPE
4038 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
4041 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
4042 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_obj_type
);
4043 align
= TYPE_ALIGN (gnu_obj_type
);
4045 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
4046 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
4048 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
4049 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
4050 tree gnu_byte_offset
4051 = convert (gnu_char_ptr_type
,
4052 size_diffop (size_zero_node
, gnu_pos
));
4054 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
4055 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
4056 gnu_ptr
, gnu_byte_offset
);
4060 = build_nt (EXPR_STMT
,
4061 build_call_alloc_dealloc
4062 (gnu_ptr
, gnu_obj_size
, align
,
4063 Procedure_To_Call (gnat_node
),
4064 Storage_Pool (gnat_node
), gnat_node
));
4068 case N_Raise_Constraint_Error
:
4069 case N_Raise_Program_Error
:
4070 case N_Raise_Storage_Error
:
4072 if (type_annotate_only
)
4075 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4076 gnu_result
= build_call_raise (UI_To_Int (Reason (gnat_node
)));
4078 /* If the type is VOID, this is a statement, so we need to
4079 generate the code for the call. Handle a Condition, if there
4081 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
4083 gnu_result
= build_nt (EXPR_STMT
, gnu_result
);
4084 TREE_TYPE (gnu_result
) = void_type_node
;
4085 TREE_SLOC (gnu_result
) = Sloc (gnat_node
);
4087 if (Present (Condition (gnat_node
)))
4088 gnu_result
= build_nt (IF_STMT
,
4089 gnat_to_gnu (Condition (gnat_node
)),
4090 gnu_result
, NULL_TREE
, NULL_TREE
);
4093 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
4096 case N_Validate_Unchecked_Conversion
:
4097 /* If the result is a pointer type, see if we are either converting
4098 from a non-pointer or from a pointer to a type with a different
4099 alias set and warn if so. If the result defined in the same unit as
4100 this unchecked convertion, we can allow this because we can know to
4101 make that type have alias set 0. */
4103 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
4104 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
4106 if (POINTER_TYPE_P (gnu_target_type
)
4107 && !In_Same_Source_Unit (Target_Type (gnat_node
), gnat_node
)
4108 && get_alias_set (TREE_TYPE (gnu_target_type
)) != 0
4109 && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node
)))
4110 && (!POINTER_TYPE_P (gnu_source_type
)
4111 || (get_alias_set (TREE_TYPE (gnu_source_type
))
4112 != get_alias_set (TREE_TYPE (gnu_target_type
)))))
4115 ("?possible aliasing problem for type&",
4116 gnat_node
, Target_Type (gnat_node
));
4118 ("\\?use -fno-strict-aliasing switch for references",
4121 ("\\?or use `pragma No_Strict_Aliasing (&);`",
4122 gnat_node
, Target_Type (gnat_node
));
4127 case N_Raise_Statement
:
4128 case N_Function_Specification
:
4129 case N_Procedure_Specification
:
4131 case N_Component_Association
:
4134 if (! type_annotate_only
)
4138 /* If the result is a statement, set needed flags and return it. */
4139 if (IS_STMT (gnu_result
))
4141 TREE_TYPE (gnu_result
) = void_type_node
;
4142 TREE_THIS_VOLATILE (gnu_result
) = TREE_SIDE_EFFECTS (gnu_result
) = 1;
4143 TREE_SLOC (gnu_result
) = Sloc (gnat_node
);
4147 /* If the result is a constant that overflows, raise constraint error. */
4148 else if (TREE_CODE (gnu_result
) == INTEGER_CST
4149 && TREE_CONSTANT_OVERFLOW (gnu_result
))
4151 post_error ("Constraint_Error will be raised at run-time?", gnat_node
);
4154 = build1 (NULL_EXPR
, gnu_result_type
,
4155 build_call_raise (CE_Overflow_Check_Failed
));
4158 /* If our result has side-effects and is of an unconstrained type,
4159 make a SAVE_EXPR so that we can be sure it will only be referenced
4160 once. Note we must do this before any conversions. */
4161 if (TREE_SIDE_EFFECTS (gnu_result
)
4162 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
4163 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))))
4164 gnu_result
= gnat_stabilize_reference (gnu_result
, 0);
4166 /* Now convert the result to the proper type. If the type is void or if
4167 we have no result, return error_mark_node to show we have no result.
4168 If the type of the result is correct or if we have a label (which doesn't
4169 have any well-defined type), return our result. Also don't do the
4170 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4171 since those are the cases where the front end may have the type wrong due
4172 to "instantiating" the unconstrained record with discriminant values
4173 or if this is a FIELD_DECL. If this is the Name of an assignment
4174 statement or a parameter of a procedure call, return what we have since
4175 the RHS has to be converted to our type there in that case, unless
4176 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
4177 record types with the same name, the expression type has integral mode,
4178 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
4179 we are converting from a packable type to its actual type and we need
4180 those conversions to be NOPs in order for assignments into these types to
4181 work properly if the inner object is a bitfield and hence can't have
4182 its address taken. Finally, don't convert integral types that are the
4183 operand of an unchecked conversion since we need to ignore those
4184 conversions (for 'Valid). Otherwise, convert the result to the proper
4187 if (Present (Parent (gnat_node
))
4188 && ((Nkind (Parent (gnat_node
)) == N_Assignment_Statement
4189 && Name (Parent (gnat_node
)) == gnat_node
)
4190 || (Nkind (Parent (gnat_node
)) == N_Procedure_Call_Statement
4191 && Name (Parent (gnat_node
)) != gnat_node
)
4192 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
4193 && ! AGGREGATE_TYPE_P (gnu_result_type
)
4194 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
4195 || Nkind (Parent (gnat_node
)) == N_Parameter_Association
)
4196 && ! (TYPE_SIZE (gnu_result_type
) != 0
4197 && TYPE_SIZE (TREE_TYPE (gnu_result
)) != 0
4198 && (AGGREGATE_TYPE_P (gnu_result_type
)
4199 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
4200 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
4201 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
4203 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
4204 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
4205 && (CONTAINS_PLACEHOLDER_P
4206 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
4207 && ! (TREE_CODE (gnu_result_type
) == RECORD_TYPE
4208 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type
))))
4210 /* In this case remove padding only if the inner object is of
4211 self-referential size: in that case it must be an object of
4212 unconstrained type with a default discriminant. In other cases,
4213 we want to avoid copying too much data. */
4214 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4215 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
4216 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4217 (TREE_TYPE (TYPE_FIELDS
4218 (TREE_TYPE (gnu_result
))))))
4219 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4223 else if (TREE_CODE (gnu_result
) == LABEL_DECL
4224 || TREE_CODE (gnu_result
) == FIELD_DECL
4225 || TREE_CODE (gnu_result
) == ERROR_MARK
4226 || (TYPE_SIZE (gnu_result_type
) != 0
4227 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
4228 && TREE_CODE (gnu_result
) != INDIRECT_REF
4229 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
4230 || ((TYPE_NAME (gnu_result_type
)
4231 == TYPE_NAME (TREE_TYPE (gnu_result
)))
4232 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
4233 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4234 && TYPE_MODE (gnu_result_type
) == BLKmode
4235 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result
)))
4238 /* Remove any padding record, but do nothing more in this case. */
4239 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4240 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
4241 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4245 else if (gnu_result
== error_mark_node
4246 || gnu_result_type
== void_type_node
)
4247 gnu_result
= error_mark_node
;
4248 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
4249 gnu_result
= convert (gnu_result_type
, gnu_result
);
4251 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4252 while ((TREE_CODE (gnu_result
) == NOP_EXPR
4253 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
4254 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
4255 gnu_result
= TREE_OPERAND (gnu_result
, 0);
4260 /* INSN is a list of insns. Return the first rtl in the list that isn't
4261 an INSN_NOTE_DELETED. */
4264 first_nondeleted_insn (rtx insns
)
4266 for (; insns
&& GET_CODE (insns
) == NOTE
4267 && NOTE_LINE_NUMBER (insns
) == NOTE_INSN_DELETED
;
4268 insns
= NEXT_INSN (insns
))
4274 /* Push the BLOCK_STMT stack and allocate a new BLOCK_STMT. */
4279 tree gnu_block_stmt
;
4281 /* First see if we can get one from the free list. */
4282 if (gnu_block_stmt_free_list
)
4284 gnu_block_stmt
= gnu_block_stmt_free_list
;
4285 gnu_block_stmt_free_list
= TREE_CHAIN (gnu_block_stmt_free_list
);
4289 gnu_block_stmt
= make_node (BLOCK_STMT
);
4290 TREE_TYPE (gnu_block_stmt
) = void_type_node
;
4293 BLOCK_STMT_LIST (gnu_block_stmt
) = NULL_TREE
;
4294 BLOCK_STMT_BLOCK (gnu_block_stmt
) = NULL_TREE
;
4295 TREE_CHAIN (gnu_block_stmt
) = gnu_block_stmt_node
;
4296 gnu_block_stmt_node
= gnu_block_stmt
;
4298 return gnu_block_stmt
;
4301 /* Add GNU_STMT to the current BLOCK_STMT node. We add them backwards
4302 order and the reverse in end_block_stmt. */
4305 add_stmt (tree gnu_stmt
)
4307 if (TREE_CODE_CLASS (TREE_CODE (gnu_stmt
)) != 's')
4310 if (TREE_CODE (gnu_stmt
) != NULL_STMT
)
4312 TREE_CHAIN (gnu_stmt
) = BLOCK_STMT_LIST (gnu_block_stmt_node
);
4313 BLOCK_STMT_LIST (gnu_block_stmt_node
) = gnu_stmt
;
4314 TREE_TYPE (gnu_stmt
) = void_type_node
;
4317 /* If this is a DECL_STMT for a variable with DECL_INIT_BY_ASSIGN_P set,
4318 generate the assignment statement too. */
4319 if (TREE_CODE (gnu_stmt
) == DECL_STMT
4320 && TREE_CODE (DECL_STMT_VAR (gnu_stmt
)) == VAR_DECL
4321 && DECL_INIT_BY_ASSIGN_P (DECL_STMT_VAR (gnu_stmt
)))
4323 tree gnu_decl
= DECL_STMT_VAR (gnu_stmt
);
4324 tree gnu_lhs
= gnu_decl
;
4325 tree gnu_assign_stmt
;
4327 /* If decl has a padded type, convert it to the unpadded type so the
4328 assignment is done properly. */
4329 if (TREE_CODE (TREE_TYPE (gnu_lhs
)) == RECORD_TYPE
4330 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_lhs
)))
4332 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_lhs
))), gnu_lhs
);
4335 = build_nt (EXPR_STMT
,
4336 build_binary_op (MODIFY_EXPR
, NULL_TREE
,
4337 gnu_lhs
, DECL_INITIAL (gnu_decl
)));
4338 DECL_INITIAL (gnu_decl
) = 0;
4339 DECL_INIT_BY_ASSIGN_P (gnu_decl
) = 0;
4341 TREE_SLOC (gnu_assign_stmt
) = TREE_SLOC (gnu_stmt
);
4342 TREE_TYPE (gnu_assign_stmt
) = void_type_node
;
4343 add_stmt (gnu_assign_stmt
);
4347 /* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node.
4348 Get SLOC from Entity_Id. */
4351 add_decl_stmt (tree gnu_decl
, Entity_Id gnat_entity
)
4355 /* If this is a variable that Gigi is to ignore, we may have been given
4356 an ERROR_MARK. So test for it. We also might have been given a
4357 reference for a renaming. So only do something for a decl. */
4358 if (!DECL_P (gnu_decl
))
4361 gnu_stmt
= build_nt (DECL_STMT
, gnu_decl
);
4362 TREE_TYPE (gnu_stmt
) = void_type_node
;
4363 TREE_SLOC (gnu_stmt
) = Sloc (gnat_entity
);
4364 add_stmt (gnu_stmt
);
4367 /* Return the BLOCK_STMT that corresponds to the statement that add_stmt
4368 has been emitting or just a single statement if only one. If FORCE
4369 is true, then always emit the BLOCK_STMT. */
4372 end_block_stmt (bool force
)
4374 tree gnu_block_stmt
= gnu_block_stmt_node
;
4375 tree gnu_retval
= gnu_block_stmt
;
4377 gnu_block_stmt_node
= TREE_CHAIN (gnu_block_stmt
);
4378 TREE_CHAIN (gnu_block_stmt
) = 0;
4380 /* If we have only one statement, return it and free this node. Otherwise,
4381 finish setting up this node and return it. If we have no statements,
4382 return a NULL_STMT. */
4383 if (!force
&& BLOCK_STMT_LIST (gnu_block_stmt
) == 0)
4385 gnu_retval
= build_nt (NULL_STMT
);
4386 TREE_TYPE (gnu_retval
) = void_type_node
;
4388 else if (!force
&& TREE_CHAIN (BLOCK_STMT_LIST (gnu_block_stmt
)) == 0)
4389 gnu_retval
= BLOCK_STMT_LIST (gnu_block_stmt
);
4392 BLOCK_STMT_LIST (gnu_block_stmt
)
4393 = nreverse (BLOCK_STMT_LIST (gnu_block_stmt
));
4394 TREE_SLOC (gnu_block_stmt
)
4395 = TREE_SLOC (BLOCK_STMT_LIST (gnu_block_stmt
));
4398 if (gnu_retval
!= gnu_block_stmt
)
4400 TREE_CHAIN (gnu_block_stmt
) = gnu_block_stmt_free_list
;
4401 gnu_block_stmt_free_list
= gnu_block_stmt
;
4407 /* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */
4410 build_block_stmt (List_Id gnat_list
)
4412 tree gnu_result
= NULL_TREE
;
4415 if (No (gnat_list
) || Is_Empty_List (gnat_list
))
4418 start_block_stmt ();
4420 for (gnat_node
= First (gnat_list
);
4421 Present (gnat_node
);
4422 gnat_node
= Next (gnat_node
))
4423 add_stmt (gnat_to_gnu (gnat_node
));
4425 gnu_result
= end_block_stmt (false);
4426 return TREE_CODE (gnu_result
) == NULL_STMT
? NULL_TREE
: gnu_result
;
4429 /* Build an EXPR_STMT to evaluate INSNS. Use Sloc from GNAT_NODE. */
4432 make_expr_stmt_from_rtl (rtx insns
, Node_Id gnat_node
)
4434 tree gnu_result
= make_node (RTL_EXPR
);
4436 TREE_TYPE (gnu_result
) = void_type_node
;
4437 RTL_EXPR_RTL (gnu_result
) = RTL_EXPR_ALT_RTL (gnu_result
) = const0_rtx
;
4438 RTL_EXPR_SEQUENCE (gnu_result
) = insns
;
4439 rtl_expr_chain
= tree_cons (NULL_TREE
, gnu_result
, rtl_expr_chain
);
4441 gnu_result
= build_nt (EXPR_STMT
, gnu_result
);
4442 TREE_SLOC (gnu_result
) = Sloc (gnat_node
);
4443 TREE_TYPE (gnu_result
) = void_type_node
;
4448 /* GNU_STMT is a statement. We generate code for that statement. */
4451 gnat_expand_stmt (tree gnu_stmt
)
4453 tree gnu_elmt
, gnu_elmt_2
;
4455 if (TREE_SLOC (gnu_stmt
))
4456 set_lineno_from_sloc (TREE_SLOC (gnu_stmt
), 1);
4458 switch (TREE_CODE (gnu_stmt
))
4461 expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt
));
4468 if (TREE_CODE (DECL_STMT_VAR (gnu_stmt
)) == TYPE_DECL
)
4469 force_type_save_exprs (TREE_TYPE (DECL_STMT_VAR (gnu_stmt
)));
4472 expand_decl (DECL_STMT_VAR (gnu_stmt
));
4473 if (DECL_CONTEXT (DECL_STMT_VAR (gnu_stmt
)))
4474 expand_decl_init (DECL_STMT_VAR (gnu_stmt
));
4476 if (TREE_ADDRESSABLE (DECL_STMT_VAR (gnu_stmt
)))
4478 put_var_into_stack (DECL_STMT_VAR (gnu_stmt
), true);
4479 flush_addressof (DECL_STMT_VAR (gnu_stmt
));
4485 if (BLOCK_STMT_BLOCK (gnu_stmt
))
4486 expand_start_bindings_and_block (0, BLOCK_STMT_BLOCK (gnu_stmt
));
4488 for (gnu_elmt
= BLOCK_STMT_LIST (gnu_stmt
); gnu_elmt
;
4489 gnu_elmt
= TREE_CHAIN (gnu_elmt
))
4490 gnat_expand_stmt (gnu_elmt
);
4492 if (BLOCK_STMT_BLOCK (gnu_stmt
))
4493 expand_end_bindings (NULL_TREE
, 1, -1);
4497 expand_start_cond (IF_STMT_COND (gnu_stmt
), 0);
4499 if (IF_STMT_TRUE (gnu_stmt
))
4500 gnat_expand_stmt (IF_STMT_TRUE (gnu_stmt
));
4502 for (gnu_elmt
= IF_STMT_ELSEIF (gnu_stmt
); gnu_elmt
;
4503 gnu_elmt
= TREE_CHAIN (gnu_elmt
))
4505 expand_start_else ();
4506 set_lineno_from_sloc (TREE_SLOC (gnu_elmt
), 1);
4507 expand_elseif (IF_STMT_COND (gnu_elmt
));
4508 if (IF_STMT_TRUE (gnu_elmt
))
4509 gnat_expand_stmt (IF_STMT_TRUE (gnu_elmt
));
4512 if (IF_STMT_ELSE (gnu_stmt
))
4514 expand_start_else ();
4515 gnat_expand_stmt (IF_STMT_ELSE (gnu_stmt
));
4522 TREE_USED (GOTO_STMT_LABEL (gnu_stmt
)) = 1;
4523 expand_goto (GOTO_STMT_LABEL (gnu_stmt
));
4527 expand_label (LABEL_STMT_LABEL (gnu_stmt
));
4531 if (RETURN_STMT_EXPR (gnu_stmt
))
4532 expand_return (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
4533 DECL_RESULT (current_function_decl
),
4534 RETURN_STMT_EXPR (gnu_stmt
)));
4536 expand_null_return ();
4540 expand_asm_operands (ASM_STMT_TEMPLATE (gnu_stmt
),
4541 ASM_STMT_OUTPUT (gnu_stmt
),
4542 ASM_STMT_INPUT (gnu_stmt
),
4543 ASM_STMT_CLOBBER (gnu_stmt
),
4544 TREE_THIS_VOLATILE (gnu_stmt
), input_location
);
4546 /* Copy all the intermediate outputs into the specified outputs. */
4547 for ((gnu_elmt
= ASM_STMT_OUTPUT (gnu_stmt
),
4548 gnu_elmt_2
= ASM_STMT_ORIG_OUT (gnu_stmt
));
4550 (gnu_elmt
= TREE_CHAIN (gnu_elmt
),
4551 gnu_elmt_2
= TREE_CHAIN (gnu_elmt_2
)))
4552 if (TREE_VALUE (gnu_elmt
) != TREE_VALUE (gnu_elmt_2
))
4555 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
4556 TREE_VALUE (gnu_elmt_2
),
4557 TREE_VALUE (gnu_elmt
)));
4563 expand_exit_something ();
4571 /* Force references to each of the entities in packages GNAT_NODE with's
4572 so that the debugging information for all of them are identical
4573 in all clients. Operate recursively on anything it with's, but check
4574 that we aren't elaborating something more than once. */
4576 /* The reason for this routine's existence is two-fold.
4577 First, with some debugging formats, notably MDEBUG on SGI
4578 IRIX, the linker will remove duplicate debugging information if two
4579 clients have identical debugguing information. With the normal scheme
4580 of elaboration, this does not usually occur, since entities in with'ed
4581 packages are elaborated on demand, and if clients have different usage
4582 patterns, the normal case, then the order and selection of entities
4583 will differ. In most cases however, it seems that linkers do not know
4584 how to eliminate duplicate debugging information, even if it is
4585 identical, so the use of this routine would increase the total amount
4586 of debugging information in the final executable.
4588 Second, this routine is called in type_annotate mode, to compute DDA
4589 information for types in withed units, for ASIS use */
4592 elaborate_all_entities (Node_Id gnat_node
)
4594 Entity_Id gnat_with_clause
, gnat_entity
;
4596 /* Process each unit only once. As we trace the context of all relevant
4597 units transitively, including generic bodies, we may encounter the
4598 same generic unit repeatedly */
4600 if (!present_gnu_tree (gnat_node
))
4601 save_gnu_tree (gnat_node
, integer_zero_node
, 1);
4603 /* Save entities in all context units. A body may have an implicit_with
4604 on its own spec, if the context includes a child unit, so don't save
4607 for (gnat_with_clause
= First (Context_Items (gnat_node
));
4608 Present (gnat_with_clause
);
4609 gnat_with_clause
= Next (gnat_with_clause
))
4610 if (Nkind (gnat_with_clause
) == N_With_Clause
4611 && ! present_gnu_tree (Library_Unit (gnat_with_clause
))
4612 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
4614 elaborate_all_entities (Library_Unit (gnat_with_clause
));
4616 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
4618 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
4619 Present (gnat_entity
);
4620 gnat_entity
= Next_Entity (gnat_entity
))
4621 if (Is_Public (gnat_entity
)
4622 && Convention (gnat_entity
) != Convention_Intrinsic
4623 && Ekind (gnat_entity
) != E_Package
4624 && Ekind (gnat_entity
) != E_Package_Body
4625 && Ekind (gnat_entity
) != E_Operator
4626 && ! (IN (Ekind (gnat_entity
), Type_Kind
)
4627 && ! Is_Frozen (gnat_entity
))
4628 && ! ((Ekind (gnat_entity
) == E_Procedure
4629 || Ekind (gnat_entity
) == E_Function
)
4630 && Is_Intrinsic_Subprogram (gnat_entity
))
4631 && ! IN (Ekind (gnat_entity
), Named_Kind
)
4632 && ! IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
4633 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4635 else if (Ekind (Entity (Name (gnat_with_clause
))) == E_Generic_Package
)
4638 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause
)));
4640 /* Retrieve compilation unit node of generic body. */
4641 while (Present (gnat_body
)
4642 && Nkind (gnat_body
) != N_Compilation_Unit
)
4643 gnat_body
= Parent (gnat_body
);
4645 /* If body is available, elaborate its context. */
4646 if (Present (gnat_body
))
4647 elaborate_all_entities (gnat_body
);
4651 if (Nkind (Unit (gnat_node
)) == N_Package_Body
&& type_annotate_only
)
4652 elaborate_all_entities (Library_Unit (gnat_node
));
4655 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
4658 process_freeze_entity (Node_Id gnat_node
)
4660 Entity_Id gnat_entity
= Entity (gnat_node
);
4664 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
4665 && present_gnu_tree (Declaration_Node (gnat_entity
)))
4666 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
4668 /* If this is a package, need to generate code for the package. */
4669 if (Ekind (gnat_entity
) == E_Package
)
4672 (Parent (Corresponding_Body
4673 (Parent (Declaration_Node (gnat_entity
)))));
4677 /* Check for old definition after the above call. This Freeze_Node
4678 might be for one its Itypes. */
4680 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4682 /* If this entity has an Address representation clause, GNU_OLD is the
4683 address, so discard it here. */
4684 if (Present (Address_Clause (gnat_entity
)))
4687 /* Don't do anything for class-wide types they are always
4688 transformed into their root type. */
4689 if (Ekind (gnat_entity
) == E_Class_Wide_Type
4690 || (Ekind (gnat_entity
) == E_Class_Wide_Subtype
4691 && Present (Equivalent_Type (gnat_entity
))))
4694 /* Don't do anything for subprograms that may have been elaborated before
4695 their freeze nodes. This can happen, for example because of an inner call
4696 in an instance body. */
4698 && TREE_CODE (gnu_old
) == FUNCTION_DECL
4699 && (Ekind (gnat_entity
) == E_Function
4700 || Ekind (gnat_entity
) == E_Procedure
))
4703 /* If we have a non-dummy type old tree, we have nothing to do. Unless
4704 this is the public view of a private type whose full view was not
4705 delayed, this node was never delayed as it should have been.
4706 Also allow this to happen for concurrent types since we may have
4707 frozen both the Corresponding_Record_Type and this type. */
4709 && ! (TREE_CODE (gnu_old
) == TYPE_DECL
4710 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
4712 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4713 && Present (Full_View (gnat_entity
))
4714 && No (Freeze_Node (Full_View (gnat_entity
))))
4716 else if (Is_Concurrent_Type (gnat_entity
))
4722 /* Reset the saved tree, if any, and elaborate the object or type for real.
4723 If there is a full declaration, elaborate it and copy the type to
4724 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4725 a class wide type or subtype. */
4728 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4729 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4730 && Present (Full_View (gnat_entity
))
4731 && present_gnu_tree (Full_View (gnat_entity
)))
4732 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, 0);
4733 if (Present (Class_Wide_Type (gnat_entity
))
4734 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4735 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, 0);
4738 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4739 && Present (Full_View (gnat_entity
)))
4741 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
4743 /* The above call may have defined this entity (the simplest example
4744 of this is when we have a private enumeral type since the bounds
4745 will have the public view. */
4746 if (! present_gnu_tree (gnat_entity
))
4747 save_gnu_tree (gnat_entity
, gnu_new
, 0);
4748 if (Present (Class_Wide_Type (gnat_entity
))
4749 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4750 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, 0);
4753 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
4755 /* If we've made any pointers to the old version of this type, we
4756 have to update them. */
4758 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4759 TREE_TYPE (gnu_new
));
4762 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4763 N_Compilation_Unit. */
4766 process_inlined_subprograms (Node_Id gnat_node
)
4768 Entity_Id gnat_entity
;
4771 /* If we can inline, generate RTL for all the inlined subprograms.
4772 Define the entity first so we set DECL_EXTERNAL. */
4773 if (optimize
> 0 && ! flag_no_inline
)
4774 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4775 Present (gnat_entity
);
4776 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4778 gnat_body
= Parent (Declaration_Node (gnat_entity
));
4780 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4782 /* ??? This really should always be Present. */
4783 if (No (Corresponding_Body (gnat_body
)))
4787 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4790 if (Present (gnat_body
))
4792 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4793 gnat_to_code (gnat_body
);
4798 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4799 We make two passes, one to elaborate anything other than bodies (but
4800 we declare a function if there was no spec). The second pass
4801 elaborates the bodies.
4803 GNAT_END_LIST gives the element in the list past the end. Normally,
4804 this is Empty, but can be First_Real_Statement for a
4805 Handled_Sequence_Of_Statements.
4807 We make a complete pass through both lists if PASS1P is true, then make
4808 the second pass over both lists if PASS2P is true. The lists usually
4809 correspond to the public and private parts of a package. */
4812 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
4813 Node_Id gnat_end_list
, int pass1p
, int pass2p
)
4815 List_Id gnat_decl_array
[2];
4819 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
4822 for (i
= 0; i
<= 1; i
++)
4823 if (Present (gnat_decl_array
[i
]))
4824 for (gnat_decl
= First (gnat_decl_array
[i
]);
4825 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4827 set_lineno (gnat_decl
, 0);
4829 /* For package specs, we recurse inside the declarations,
4830 thus taking the two pass approach inside the boundary. */
4831 if (Nkind (gnat_decl
) == N_Package_Declaration
4832 && (Nkind (Specification (gnat_decl
)
4833 == N_Package_Specification
)))
4834 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4835 Private_Declarations (Specification (gnat_decl
)),
4838 /* Similarly for any declarations in the actions of a
4840 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4842 start_block_stmt ();
4843 process_freeze_entity (gnat_decl
);
4844 gnat_expand_stmt (end_block_stmt (false));
4845 process_decls (Actions (gnat_decl
), Empty
, Empty
, 1, 0);
4848 /* Package bodies with freeze nodes get their elaboration deferred
4849 until the freeze node, but the code must be placed in the right
4850 place, so record the code position now. */
4851 else if (Nkind (gnat_decl
) == N_Package_Body
4852 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
4853 record_code_position (gnat_decl
);
4855 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
4856 && Present (Library_Unit (gnat_decl
))
4857 && Present (Freeze_Node
4860 (Library_Unit (gnat_decl
)))))))
4861 record_code_position
4862 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
4864 /* We defer most subprogram bodies to the second pass. */
4865 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
4867 if (Acts_As_Spec (gnat_decl
))
4869 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
4871 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
4872 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4873 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4876 /* For bodies and stubs that act as their own specs, the entity
4877 itself must be elaborated in the first pass, because it may
4878 be used in other declarations. */
4879 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
4881 Node_Id gnat_subprog_id
=
4882 Defining_Entity (Specification (gnat_decl
));
4884 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
4885 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
4886 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4887 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4890 /* Concurrent stubs stand for the corresponding subprogram bodies,
4891 which are deferred like other bodies. */
4892 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
4893 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4897 start_block_stmt ();
4898 gnat_to_code (gnat_decl
);
4899 gnat_expand_stmt (end_block_stmt (false));
4903 /* Here we elaborate everything we deferred above except for package bodies,
4904 which are elaborated at their freeze nodes. Note that we must also
4905 go inside things (package specs and freeze nodes) the first pass did. */
4907 for (i
= 0; i
<= 1; i
++)
4908 if (Present (gnat_decl_array
[i
]))
4909 for (gnat_decl
= First (gnat_decl_array
[i
]);
4910 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4912 if (Nkind (gnat_decl
) == N_Subprogram_Body
4913 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
4914 || Nkind (gnat_decl
) == N_Task_Body_Stub
4915 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4916 gnat_to_code (gnat_decl
);
4918 else if (Nkind (gnat_decl
) == N_Package_Declaration
4919 && (Nkind (Specification (gnat_decl
)
4920 == N_Package_Specification
)))
4921 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4922 Private_Declarations (Specification (gnat_decl
)),
4925 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4926 process_decls (Actions (gnat_decl
), Empty
, Empty
, 0, 1);
4930 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4931 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4932 which we have to check. */
4935 emit_range_check (tree gnu_expr
, Entity_Id gnat_range_type
)
4937 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
4938 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
4939 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
4940 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
4942 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4943 we can't do anything since we might be truncating the bounds. No
4944 check is needed in this case. */
4945 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
4946 && (TYPE_PRECISION (gnu_compare_type
)
4947 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
4950 /* Checked expressions must be evaluated only once. */
4951 gnu_expr
= protect_multiple_eval (gnu_expr
);
4953 /* There's no good type to use here, so we might as well use
4954 integer_type_node. Note that the form of the check is
4955 (not (expr >= lo)) or (not (expr >= hi))
4956 the reason for this slightly convoluted form is that NaN's
4957 are not considered to be in range in the float case. */
4959 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4961 (build_binary_op (GE_EXPR
, integer_type_node
,
4962 convert (gnu_compare_type
, gnu_expr
),
4963 convert (gnu_compare_type
, gnu_low
))),
4965 (build_binary_op (LE_EXPR
, integer_type_node
,
4966 convert (gnu_compare_type
, gnu_expr
),
4967 convert (gnu_compare_type
,
4969 gnu_expr
, CE_Range_Check_Failed
);
4972 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4973 which we are about to index, GNU_EXPR is the index expression to be
4974 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4975 against which GNU_EXPR has to be checked. Note that for index
4976 checking we cannot use the emit_range_check function (although very
4977 similar code needs to be generated in both cases) since for index
4978 checking the array type against which we are checking the indeces
4979 may be unconstrained and consequently we need to retrieve the
4980 actual index bounds from the array object itself
4981 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4982 subprograms having unconstrained array formal parameters */
4985 emit_index_check (tree gnu_array_object
,
4990 tree gnu_expr_check
;
4992 /* Checked expressions must be evaluated only once. */
4993 gnu_expr
= protect_multiple_eval (gnu_expr
);
4995 /* Must do this computation in the base type in case the expression's
4996 type is an unsigned subtypes. */
4997 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
4999 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
5000 the object we are handling. */
5001 gnu_low
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low
, gnu_array_object
);
5002 gnu_high
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high
, gnu_array_object
);
5004 /* There's no good type to use here, so we might as well use
5005 integer_type_node. */
5007 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
5008 build_binary_op (LT_EXPR
, integer_type_node
,
5010 convert (TREE_TYPE (gnu_expr_check
),
5012 build_binary_op (GT_EXPR
, integer_type_node
,
5014 convert (TREE_TYPE (gnu_expr_check
),
5016 gnu_expr
, CE_Index_Check_Failed
);
5019 /* Given GNU_COND which contains the condition corresponding to an access,
5020 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
5021 that returns GNU_EXPR if GNU_COND is false and raises a
5022 CONSTRAINT_ERROR if GNU_COND is true. REASON is the code that says
5023 why the exception was raised. */
5026 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
)
5031 gnu_call
= build_call_raise (reason
);
5033 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
5034 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
5035 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
5037 gnu_result
= fold (build (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
5038 build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
),
5039 gnu_call
, gnu_expr
),
5042 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
5043 protect it. Otherwise, show GNU_RESULT has no side effects: we
5044 don't need to evaluate it just for the check. */
5045 if (TREE_SIDE_EFFECTS (gnu_expr
))
5047 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
, gnu_result
);
5049 TREE_SIDE_EFFECTS (gnu_result
) = 0;
5051 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
5052 we will repeatedly do the test. It would be nice if GCC was able
5053 to optimize this and only do it once. */
5054 return save_expr (gnu_result
);
5057 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
5058 overflow checks if OVERFLOW_P is nonzero and range checks if
5059 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
5060 If TRUNCATE_P is nonzero, do a float to integer conversion with
5061 truncation; otherwise round. */
5064 convert_with_check (Entity_Id gnat_type
,
5070 tree gnu_type
= get_unpadded_type (gnat_type
);
5071 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
5072 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
5073 tree gnu_base_type
= get_base_type (gnu_type
);
5074 tree gnu_ada_base_type
= get_ada_base_type (gnu_type
);
5075 tree gnu_result
= gnu_expr
;
5077 /* If we are not doing any checks, the output is an integral type, and
5078 the input is not a floating type, just do the conversion. This
5079 shortcut is required to avoid problems with packed array types
5080 and simplifies code in all cases anyway. */
5081 if (! range_p
&& ! overflow_p
&& INTEGRAL_TYPE_P (gnu_base_type
)
5082 && ! FLOAT_TYPE_P (gnu_in_type
))
5083 return convert (gnu_type
, gnu_expr
);
5085 /* First convert the expression to its base type. This
5086 will never generate code, but makes the tests below much simpler.
5087 But don't do this if converting from an integer type to an unconstrained
5088 array type since then we need to get the bounds from the original
5090 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
5091 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
5093 /* If overflow checks are requested, we need to be sure the result will
5094 fit in the output base type. But don't do this if the input
5095 is integer and the output floating-point. */
5097 && ! (FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
5099 /* Ensure GNU_EXPR only gets evaluated once. */
5100 tree gnu_input
= protect_multiple_eval (gnu_result
);
5101 tree gnu_cond
= integer_zero_node
;
5102 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
5103 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
5104 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
5105 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
5107 /* Convert the lower bounds to signed types, so we're sure we're
5108 comparing them properly. Likewise, convert the upper bounds
5109 to unsigned types. */
5110 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TYPE_UNSIGNED (gnu_in_basetype
))
5111 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
5113 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
5114 && !TYPE_UNSIGNED (gnu_in_basetype
))
5115 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
5117 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
5118 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
5120 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
5121 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
5123 /* Check each bound separately and only if the result bound
5124 is tighter than the bound on the input type. Note that all the
5125 types are base types, so the bounds must be constant. Also,
5126 the comparison is done in the base type of the input, which
5127 always has the proper signedness. First check for input
5128 integer (which means output integer), output float (which means
5129 both float), or mixed, in which case we always compare.
5130 Note that we have to do the comparison which would *fail* in the
5131 case of an error since if it's an FP comparison and one of the
5132 values is a NaN or Inf, the comparison will fail. */
5133 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
5134 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
5135 : (FLOAT_TYPE_P (gnu_base_type
)
5136 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
5137 TREE_REAL_CST (gnu_out_lb
))
5141 (build_binary_op (GE_EXPR
, integer_type_node
,
5142 gnu_input
, convert (gnu_in_basetype
,
5145 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
5146 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
5147 : (FLOAT_TYPE_P (gnu_base_type
)
5148 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
5149 TREE_REAL_CST (gnu_in_lb
))
5152 = build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
, gnu_cond
,
5154 (build_binary_op (LE_EXPR
, integer_type_node
,
5156 convert (gnu_in_basetype
,
5159 if (! integer_zerop (gnu_cond
))
5160 gnu_result
= emit_check (gnu_cond
, gnu_input
,
5161 CE_Overflow_Check_Failed
);
5164 /* Now convert to the result base type. If this is a non-truncating
5165 float-to-integer conversion, round. */
5166 if (INTEGRAL_TYPE_P (gnu_ada_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
5169 tree gnu_point_5
= build_real (gnu_in_basetype
, dconstp5
);
5170 tree gnu_minus_point_5
= build_real (gnu_in_basetype
, dconstmp5
);
5171 tree gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
5172 tree gnu_saved_result
= save_expr (gnu_result
);
5173 tree gnu_comp
= build (GE_EXPR
, integer_type_node
,
5174 gnu_saved_result
, gnu_zero
);
5175 tree gnu_adjust
= build (COND_EXPR
, gnu_in_basetype
, gnu_comp
,
5176 gnu_point_5
, gnu_minus_point_5
);
5179 = build (PLUS_EXPR
, gnu_in_basetype
, gnu_saved_result
, gnu_adjust
);
5182 if (TREE_CODE (gnu_ada_base_type
) == INTEGER_TYPE
5183 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type
)
5184 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
5185 gnu_result
= unchecked_convert (gnu_ada_base_type
, gnu_result
, 0);
5187 gnu_result
= convert (gnu_ada_base_type
, gnu_result
);
5189 /* Finally, do the range check if requested. Note that if the
5190 result type is a modular type, the range check is actually
5191 an overflow check. */
5194 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
5195 && TYPE_MODULAR_P (gnu_base_type
) && overflow_p
))
5196 gnu_result
= emit_range_check (gnu_result
, gnat_type
);
5198 return convert (gnu_type
, gnu_result
);
5201 /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
5202 it is an expression involving computation or if it involves a bitfield
5203 reference. This returns the same as gnat_mark_addressable in most
5207 addressable_p (tree gnu_expr
)
5209 switch (TREE_CODE (gnu_expr
))
5215 /* All DECLs are addressable: if they are in a register, we can force
5219 case UNCONSTRAINED_ARRAY_REF
:
5227 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
5228 && (! DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr
, 1))
5229 || ! flag_strict_aliasing
)
5230 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
5232 case ARRAY_REF
: case ARRAY_RANGE_REF
:
5233 case REALPART_EXPR
: case IMAGPART_EXPR
:
5235 return addressable_p (TREE_OPERAND (gnu_expr
, 0));
5238 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
5239 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
5241 case VIEW_CONVERT_EXPR
:
5243 /* This is addressable if we can avoid a copy. */
5244 tree type
= TREE_TYPE (gnu_expr
);
5245 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
5247 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
5248 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
5249 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
5250 || ((TYPE_MODE (type
) == BLKmode
5251 || TYPE_MODE (inner_type
) == BLKmode
)
5252 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
5253 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
5254 || TYPE_ALIGN_OK (type
)
5255 || TYPE_ALIGN_OK (inner_type
))))
5256 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
5264 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
5265 a separate Freeze node exists, delay the bulk of the processing. Otherwise
5266 make a GCC type for GNAT_ENTITY and set up the correspondance. */
5269 process_type (Entity_Id gnat_entity
)
5272 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
5275 /* If we are to delay elaboration of this type, just do any
5276 elaborations needed for expressions within the declaration and
5277 make a dummy type entry for this node and its Full_View (if
5278 any) in case something points to it. Don't do this if it
5279 has already been done (the only way that can happen is if
5280 the private completion is also delayed). */
5281 if (Present (Freeze_Node (gnat_entity
))
5282 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
5283 && Present (Full_View (gnat_entity
))
5284 && Freeze_Node (Full_View (gnat_entity
))
5285 && ! present_gnu_tree (Full_View (gnat_entity
))))
5287 elaborate_entity (gnat_entity
);
5291 tree gnu_decl
= create_type_decl (get_entity_name (gnat_entity
),
5292 make_dummy_type (gnat_entity
),
5295 save_gnu_tree (gnat_entity
, gnu_decl
, 0);
5296 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
5297 && Present (Full_View (gnat_entity
)))
5298 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, 0);
5304 /* If we saved away a dummy type for this node it means that this
5305 made the type that corresponds to the full type of an incomplete
5306 type. Clear that type for now and then update the type in the
5310 if (TREE_CODE (gnu_old
) != TYPE_DECL
5311 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)))
5313 /* If this was a withed access type, this is not an error
5314 and merely indicates we've already elaborated the type
5316 if (Is_Type (gnat_entity
) && From_With_Type (gnat_entity
))
5322 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
5325 /* Now fully elaborate the type. */
5326 start_block_stmt ();
5327 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
5328 if (TREE_CODE (gnu_new
) != TYPE_DECL
)
5331 /* If we have an old type and we've made pointers to this type,
5332 update those pointers. */
5334 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
5335 TREE_TYPE (gnu_new
));
5337 /* If this is a record type corresponding to a task or protected type
5338 that is a completion of an incomplete type, perform a similar update
5340 /* ??? Including protected types here is a guess. */
5342 if (IN (Ekind (gnat_entity
), Record_Kind
)
5343 && Is_Concurrent_Record_Type (gnat_entity
)
5344 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
5347 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
5349 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
5351 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
5354 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
5355 TREE_TYPE (gnu_new
));
5358 gnat_expand_stmt (end_block_stmt (false));
5361 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
5362 GNU_TYPE is the GCC type of the corresponding record.
5364 Return a CONSTRUCTOR to build the record. */
5367 assoc_to_constructor (Node_Id gnat_assoc
, tree gnu_type
)
5369 tree gnu_field
, gnu_list
, gnu_result
;
5371 /* We test for GNU_FIELD being empty in the case where a variant
5372 was the last thing since we don't take things off GNAT_ASSOC in
5373 that case. We check GNAT_ASSOC in case we have a variant, but it
5376 for (gnu_list
= NULL_TREE
; Present (gnat_assoc
);
5377 gnat_assoc
= Next (gnat_assoc
))
5379 Node_Id gnat_field
= First (Choices (gnat_assoc
));
5380 tree gnu_field
= gnat_to_gnu_entity (Entity (gnat_field
), NULL_TREE
, 0);
5381 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
5383 /* The expander is supposed to put a single component selector name
5384 in every record component association */
5385 if (Next (gnat_field
))
5388 /* Before assigning a value in an aggregate make sure range checks
5389 are done if required. Then convert to the type of the field. */
5390 if (Do_Range_Check (Expression (gnat_assoc
)))
5391 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
));
5393 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
5395 /* Add the field and expression to the list. */
5396 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
5399 gnu_result
= extract_values (gnu_list
, gnu_type
);
5401 /* Verify every enty in GNU_LIST was used. */
5402 for (gnu_field
= gnu_list
; gnu_field
; gnu_field
= TREE_CHAIN (gnu_field
))
5403 if (! TREE_ADDRESSABLE (gnu_field
))
5409 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5410 is the first element of an array aggregate. It may itself be an
5411 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5412 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5413 of the array component. It is needed for range checking. */
5416 pos_to_constructor (Node_Id gnat_expr
,
5417 tree gnu_array_type
,
5418 Entity_Id gnat_component_type
)
5421 tree gnu_expr_list
= NULL_TREE
;
5423 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
5425 /* If the expression is itself an array aggregate then first build the
5426 innermost constructor if it is part of our array (multi-dimensional
5429 if (Nkind (gnat_expr
) == N_Aggregate
5430 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
5431 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
5432 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
5433 TREE_TYPE (gnu_array_type
),
5434 gnat_component_type
);
5437 gnu_expr
= gnat_to_gnu (gnat_expr
);
5439 /* before assigning the element to the array make sure it is
5441 if (Do_Range_Check (gnat_expr
))
5442 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
);
5446 = tree_cons (NULL_TREE
, convert (TREE_TYPE (gnu_array_type
), gnu_expr
),
5450 return gnat_build_constructor (gnu_array_type
, nreverse (gnu_expr_list
));
5453 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5454 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
5455 of the associations that are from RECORD_TYPE. If we see an internal
5456 record, make a recursive call to fill it in as well. */
5459 extract_values (tree values
, tree record_type
)
5461 tree result
= NULL_TREE
;
5464 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
5468 /* _Parent is an internal field, but may have values in the aggregate,
5469 so check for values first. */
5470 if ((tem
= purpose_member (field
, values
)) != 0)
5472 value
= TREE_VALUE (tem
);
5473 TREE_ADDRESSABLE (tem
) = 1;
5476 else if (DECL_INTERNAL_P (field
))
5478 value
= extract_values (values
, TREE_TYPE (field
));
5479 if (TREE_CODE (value
) == CONSTRUCTOR
5480 && CONSTRUCTOR_ELTS (value
) == 0)
5484 /* If we have a record subtype, the names will match, but not the
5485 actual FIELD_DECLs. */
5486 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
5487 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
5489 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
5490 TREE_ADDRESSABLE (tem
) = 1;
5496 result
= tree_cons (field
, value
, result
);
5499 return gnat_build_constructor (record_type
, nreverse (result
));
5502 /* EXP is to be treated as an array or record. Handle the cases when it is
5503 an access object and perform the required dereferences. */
5506 maybe_implicit_deref (tree exp
)
5508 /* If the type is a pointer, dereference it. */
5510 if (POINTER_TYPE_P (TREE_TYPE (exp
)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp
)))
5511 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
5513 /* If we got a padded type, remove it too. */
5514 if (TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
5515 && TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
5516 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
5521 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
5524 protect_multiple_eval (tree exp
)
5526 tree type
= TREE_TYPE (exp
);
5528 /* If this has no side effects, we don't need to do anything. */
5529 if (! TREE_SIDE_EFFECTS (exp
))
5532 /* If it is a conversion, protect what's inside the conversion.
5533 Similarly, if we're indirectly referencing something, we only
5534 actually need to protect the address since the data itself can't
5535 change in these situations. */
5536 else if (TREE_CODE (exp
) == NON_LVALUE_EXPR
5537 || TREE_CODE (exp
) == NOP_EXPR
|| TREE_CODE (exp
) == CONVERT_EXPR
5538 || TREE_CODE (exp
) == VIEW_CONVERT_EXPR
5539 || TREE_CODE (exp
) == INDIRECT_REF
5540 || TREE_CODE (exp
) == UNCONSTRAINED_ARRAY_REF
)
5541 return build1 (TREE_CODE (exp
), type
,
5542 protect_multiple_eval (TREE_OPERAND (exp
, 0)));
5544 /* If EXP is a fat pointer or something that can be placed into a register,
5545 just make a SAVE_EXPR. */
5546 if (TYPE_FAT_POINTER_P (type
) || TYPE_MODE (type
) != BLKmode
)
5547 return save_expr (exp
);
5549 /* Otherwise, dereference, protect the address, and re-reference. */
5552 build_unary_op (INDIRECT_REF
, type
,
5553 save_expr (build_unary_op (ADDR_EXPR
,
5554 build_reference_type (type
),
5558 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5559 how to handle our new nodes and we take an extra argument that says
5560 whether to force evaluation of everything. */
5563 gnat_stabilize_reference (tree ref
, int force
)
5565 tree type
= TREE_TYPE (ref
);
5566 enum tree_code code
= TREE_CODE (ref
);
5574 /* No action is needed in this case. */
5580 case FIX_TRUNC_EXPR
:
5581 case FIX_FLOOR_EXPR
:
5582 case FIX_ROUND_EXPR
:
5584 case VIEW_CONVERT_EXPR
:
5587 = build1 (code
, type
,
5588 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
));
5592 case UNCONSTRAINED_ARRAY_REF
:
5593 result
= build1 (code
, type
,
5594 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5599 result
= build (COMPONENT_REF
, type
,
5600 gnat_stabilize_reference (TREE_OPERAND (ref
, 0),
5602 TREE_OPERAND (ref
, 1));
5606 result
= build (BIT_FIELD_REF
, type
,
5607 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5608 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5610 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 2),
5615 result
= build (ARRAY_REF
, type
,
5616 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5617 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5621 case ARRAY_RANGE_REF
:
5622 result
= build (ARRAY_RANGE_REF
, type
,
5623 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5624 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5629 result
= build (COMPOUND_EXPR
, type
,
5630 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5632 gnat_stabilize_reference (TREE_OPERAND (ref
, 1),
5637 result
= build1 (INDIRECT_REF
, type
,
5638 save_expr (build1 (ADDR_EXPR
,
5639 build_reference_type (type
), ref
)));
5642 /* If arg isn't a kind of lvalue we recognize, make no change.
5643 Caller should recognize the error for an invalid lvalue. */
5648 return error_mark_node
;
5651 TREE_READONLY (result
) = TREE_READONLY (ref
);
5655 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5656 arg to force a SAVE_EXPR for everything. */
5659 gnat_stabilize_reference_1 (tree e
, int force
)
5661 enum tree_code code
= TREE_CODE (e
);
5662 tree type
= TREE_TYPE (e
);
5665 /* We cannot ignore const expressions because it might be a reference
5666 to a const array but whose index contains side-effects. But we can
5667 ignore things that are actual constant or that already have been
5668 handled by this function. */
5670 if (TREE_CONSTANT (e
) || code
== SAVE_EXPR
)
5673 switch (TREE_CODE_CLASS (code
))
5682 if (TREE_SIDE_EFFECTS (e
) || force
)
5683 return save_expr (e
);
5687 /* Constants need no processing. In fact, we should never reach
5692 /* Recursively stabilize each operand. */
5693 result
= build (code
, type
,
5694 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0), force
),
5695 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 1), force
));
5699 /* Recursively stabilize each operand. */
5700 result
= build1 (code
, type
,
5701 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
5709 TREE_READONLY (result
) = TREE_READONLY (e
);
5713 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5714 either a spec or a body, BODY_P says which. If needed, make a function
5715 to be the elaboration routine for that object and perform the elaborations
5718 Return 1 if we didn't need an elaboration function, zero otherwise. */
5721 build_unit_elab (Entity_Id gnat_unit
, int body_p
, tree gnu_elab_list
)
5727 /* If we have nothing to do, return. */
5728 if (gnu_elab_list
== 0)
5731 /* Prevent the elaboration list from being reclaimed by the GC. */
5732 gnu_pending_elaboration_lists
= chainon (gnu_pending_elaboration_lists
,
5735 /* Set our file and line number to that of the object and set up the
5736 elaboration routine. */
5737 gnu_decl
= create_subprog_decl (create_concat_name (gnat_unit
,
5740 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 0,
5742 DECL_ELABORATION_PROC_P (gnu_decl
) = 1;
5744 begin_subprog_body (gnu_decl
);
5745 set_lineno (gnat_unit
, 1);
5747 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
5748 expand_start_bindings (0);
5750 /* Emit the assignments for the elaborations we have to do. If there
5751 is no destination, this is just a call to execute some statement
5752 that was placed within the declarative region. But first save a
5753 pointer so we can see if any insns were generated. */
5755 insn
= get_last_insn ();
5757 for (; gnu_elab_list
; gnu_elab_list
= TREE_CHAIN (gnu_elab_list
))
5758 if (TREE_PURPOSE (gnu_elab_list
) == NULL_TREE
)
5760 if (TREE_VALUE (gnu_elab_list
) != 0)
5761 expand_expr_stmt (TREE_VALUE (gnu_elab_list
));
5765 tree lhs
= TREE_PURPOSE (gnu_elab_list
);
5767 input_location
= DECL_SOURCE_LOCATION (lhs
);
5769 /* If LHS has a padded type, convert it to the unpadded type
5770 so the assignment is done properly. */
5771 if (TREE_CODE (TREE_TYPE (lhs
)) == RECORD_TYPE
5772 && TYPE_IS_PADDING_P (TREE_TYPE (lhs
)))
5773 lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs
))), lhs
);
5775 emit_line_note (input_location
);
5776 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5777 TREE_PURPOSE (gnu_elab_list
),
5778 TREE_VALUE (gnu_elab_list
)));
5781 /* See if any non-NOTE insns were generated. */
5782 for (insn
= NEXT_INSN (insn
); insn
; insn
= NEXT_INSN (insn
))
5783 if (GET_RTX_CLASS (GET_CODE (insn
)) == RTX_INSN
)
5789 expand_end_bindings (NULL_TREE
, block_has_vars (), -1);
5791 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
5792 end_subprog_body ();
5794 /* We are finished with the elaboration list it can now be discarded. */
5795 gnu_pending_elaboration_lists
= TREE_CHAIN (gnu_pending_elaboration_lists
);
5797 /* If there were no insns, we don't need an elab routine. It would
5798 be nice to not output this one, but there's no good way to do that. */
5802 extern char *__gnat_to_canonical_file_spec (char *);
5804 /* Determine the input_filename and the input_line from the source location
5805 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5806 input_line. If WRITE_NOTE_P is true, emit a line number note. */
5809 set_lineno (Node_Id gnat_node
, int write_note_p
)
5811 Source_Ptr source_location
= Sloc (gnat_node
);
5813 set_lineno_from_sloc (source_location
, write_note_p
);
5816 /* Likewise, but passed a Sloc. */
5819 set_lineno_from_sloc (Source_Ptr source_location
, int write_note_p
)
5821 /* If node not from source code, ignore. */
5822 if (source_location
< 0)
5825 /* Use the identifier table to make a hashed, permanent copy of the filename,
5826 since the name table gets reallocated after Gigi returns but before all
5827 the debugging information is output. The __gnat_to_canonical_file_spec
5828 call translates filenames from pragmas Source_Reference that contain host
5829 style syntax not understood by gdb. */
5831 = IDENTIFIER_POINTER
5833 (__gnat_to_canonical_file_spec
5835 (Full_Debug_Name (Get_Source_File_Index (source_location
))))));
5837 /* ref_filename is the reference file name as given by sinput (i.e no
5840 = IDENTIFIER_POINTER
5843 (Debug_Source_Name (Get_Source_File_Index (source_location
)))));;
5844 input_line
= Get_Logical_Line_Number (source_location
);
5846 if (! global_bindings_p () && write_note_p
)
5847 emit_line_note (input_location
);
5850 /* Post an error message. MSG is the error message, properly annotated.
5851 NODE is the node at which to post the error and the node to use for the
5852 "&" substitution. */
5855 post_error (const char *msg
, Node_Id node
)
5857 String_Template temp
;
5860 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5861 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5863 Error_Msg_N (fp
, node
);
5866 /* Similar, but NODE is the node at which to post the error and ENT
5867 is the node to use for the "&" substitution. */
5870 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
5872 String_Template temp
;
5875 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5876 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5878 Error_Msg_NE (fp
, node
, ent
);
5881 /* Similar, but NODE is the node at which to post the error, ENT is the node
5882 to use for the "&" substitution, and N is the number to use for the ^. */
5885 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int n
)
5887 String_Template temp
;
5890 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5891 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5892 Error_Msg_Uint_1
= UI_From_Int (n
);
5895 Error_Msg_NE (fp
, node
, ent
);
5898 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5899 number to write. If the tree represents a constant that fits within
5900 a host integer, the text inside curly brackets in MSG will be output
5901 (presumably including a '^'). Otherwise that text will not be output
5902 and the text inside square brackets will be output instead. */
5905 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
5907 char *newmsg
= alloca (strlen (msg
) + 1);
5908 String_Template temp
= {1, 0};
5910 char start_yes
, end_yes
, start_no
, end_no
;
5914 fp
.Array
= newmsg
, fp
.Bounds
= &temp
;
5916 if (host_integerp (t
, 1)
5917 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5920 (t
, (((unsigned HOST_WIDE_INT
) 1 << (HOST_BITS_PER_INT
- 1)) - 1)) < 0
5924 Error_Msg_Uint_1
= UI_From_Int (tree_low_cst (t
, 1));
5925 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
5928 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
5930 for (p
= msg
, q
= newmsg
; *p
!= 0; p
++)
5932 if (*p
== start_yes
)
5933 for (p
++; *p
!= end_yes
; p
++)
5935 else if (*p
== start_no
)
5936 for (p
++; *p
!= end_no
; p
++)
5944 temp
.High_Bound
= strlen (newmsg
);
5946 Error_Msg_NE (fp
, node
, ent
);
5949 /* Similar to post_error_ne_tree, except that NUM is a second
5950 integer to write in the message. */
5953 post_error_ne_tree_2 (const char *msg
,
5959 Error_Msg_Uint_2
= UI_From_Int (num
);
5960 post_error_ne_tree (msg
, node
, ent
, t
);
5963 /* Set the node for a second '&' in the error message. */
5966 set_second_error_entity (Entity_Id e
)
5968 Error_Msg_Node_2
= e
;
5971 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5972 as the relevant node that provides the location info for the error */
5975 gigi_abort (int code
)
5977 String_Template temp
= {1, 10};
5980 fp
.Array
= "Gigi abort", fp
.Bounds
= &temp
;
5982 Current_Error_Node
= error_gnat_node
;
5983 Compiler_Abort (fp
, code
);
5986 /* Initialize the table that maps GNAT codes to GCC codes for simple
5987 binary and unary operations. */
5990 init_code_table (void)
5992 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
5993 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
5995 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
5996 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
5997 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
5998 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
5999 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
6000 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
6001 gnu_codes
[N_Op_Le
] = LE_EXPR
;
6002 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
6003 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
6004 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
6005 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
6006 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
6007 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
6008 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
6009 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
6010 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
6011 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
6012 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
6013 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
6014 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
6015 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
6016 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
6019 #include "gt-ada-trans.h"