1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2007, 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, 51 Franklin Street, Fifth Floor, *
20 * Boston, MA 02110-1301, 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"
43 #include "tree-gimple.h"
60 /* Let code below know whether we are targetting VMS without need of
61 intrusive preprocessor directives. */
62 #ifndef TARGET_ABI_OPEN_VMS
63 #define TARGET_ABI_OPEN_VMS 0
68 struct Node *Nodes_Ptr;
69 Node_Id *Next_Node_Ptr;
70 Node_Id *Prev_Node_Ptr;
71 struct Elist_Header *Elists_Ptr;
72 struct Elmt_Item *Elmts_Ptr;
73 struct String_Entry *Strings_Ptr;
74 Char_Code *String_Chars_Ptr;
75 struct List_Header *List_Headers_Ptr;
77 /* Current filename without path. */
78 const char *ref_filename;
80 /* If true, then gigi is being called on an analyzed but unexpanded
81 tree, and the only purpose of the call is to properly annotate
82 types with representation information. */
83 bool type_annotate_only;
85 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
86 of unconstrained array IN parameters to avoid emitting a great deal of
87 redundant instructions to recompute them each time. */
88 struct parm_attr GTY (())
90 int id; /* GTY doesn't like Entity_Id. */
97 typedef struct parm_attr *parm_attr;
100 DEF_VEC_ALLOC_P(parm_attr,gc);
102 struct language_function GTY(())
104 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca, for
105 fear of running out of stack space. If we need more, we use xmalloc/free
107 #define ALLOCA_THRESHOLD 1000
109 VEC(parm_attr,gc) *parm_attr_cache;
112 #define f_parm_attr_cache \
113 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
115 /* A structure used to gather together information about a statement group.
116 We use this to gather related statements, for example the "then" part
117 of a IF. In the case where it represents a lexical scope, we may also
118 have a BLOCK node corresponding to it and/or cleanups. */
120 struct stmt_group GTY((chain_next ("%h.previous"))) {
121 struct stmt_group *previous; /* Previous code group. */
122 tree stmt_list; /* List of statements for this code group. */
123 tree block; /* BLOCK for this code group, if any. */
124 tree cleanups; /* Cleanups for this code group, if any. */
127 static GTY(()) struct stmt_group *current_stmt_group;
129 /* List of unused struct stmt_group nodes. */
130 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
132 /* A structure used to record information on elaboration procedures
133 we've made and need to process.
135 ??? gnat_node should be Node_Id, but gengtype gets confused. */
137 struct elab_info GTY((chain_next ("%h.next"))) {
138 struct elab_info *next; /* Pointer to next in chain. */
139 tree elab_proc; /* Elaboration procedure. */
140 int gnat_node; /* The N_Compilation_Unit. */
143 static GTY(()) struct elab_info *elab_info_list;
145 /* Free list of TREE_LIST nodes used for stacks. */
146 static GTY((deletable)) tree gnu_stack_free_list;
148 /* List of TREE_LIST nodes representing a stack of exception pointer
149 variables. TREE_VALUE is the VAR_DECL that stores the address of
150 the raised exception. Nonzero means we are in an exception
151 handler. Not used in the zero-cost case. */
152 static GTY(()) tree gnu_except_ptr_stack;
154 /* List of TREE_LIST nodes used to store the current elaboration procedure
155 decl. TREE_VALUE is the decl. */
156 static GTY(()) tree gnu_elab_proc_stack;
158 /* Variable that stores a list of labels to be used as a goto target instead of
159 a return in some functions. See processing for N_Subprogram_Body. */
160 static GTY(()) tree gnu_return_label_stack;
162 /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
163 TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */
164 static GTY(()) tree gnu_loop_label_stack;
166 /* List of TREE_LIST nodes representing labels for switch statements.
167 TREE_VALUE of each entry is the label at the end of the switch. */
168 static GTY(()) tree gnu_switch_label_stack;
170 /* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */
171 static GTY(()) tree gnu_constraint_error_label_stack;
172 static GTY(()) tree gnu_storage_error_label_stack;
173 static GTY(()) tree gnu_program_error_label_stack;
175 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
176 static enum tree_code gnu_codes[Number_Node_Kinds];
178 /* Current node being treated, in case abort called. */
179 Node_Id error_gnat_node;
181 static void Compilation_Unit_to_gnu (Node_Id);
182 static void record_code_position (Node_Id);
183 static void insert_code_for (Node_Id);
184 static void add_cleanup (tree, Node_Id);
185 static tree mark_visited (tree *, int *, void *);
186 static tree unshare_save_expr (tree *, int *, void *);
187 static void add_stmt_list (List_Id);
188 static void push_exception_label_stack (tree *, Entity_Id);
189 static tree build_stmt_group (List_Id, bool);
190 static void push_stack (tree *, tree, tree);
191 static void pop_stack (tree *);
192 static enum gimplify_status gnat_gimplify_stmt (tree *);
193 static void elaborate_all_entities (Node_Id);
194 static void process_freeze_entity (Node_Id);
195 static void process_inlined_subprograms (Node_Id);
196 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
197 static tree emit_range_check (tree, Node_Id);
198 static tree emit_index_check (tree, tree, tree, tree);
199 static tree emit_check (tree, tree, int);
200 static tree convert_with_check (Entity_Id, tree, bool, bool, bool);
201 static bool addressable_p (tree);
202 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
203 static tree extract_values (tree, tree);
204 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
205 static tree maybe_implicit_deref (tree);
206 static tree gnat_stabilize_reference (tree, bool);
207 static tree gnat_stabilize_reference_1 (tree, bool);
208 static void annotate_with_node (tree, Node_Id);
209 static int lvalue_required_p (Node_Id, tree, int);
211 /* This is the main program of the back-end. It sets up all the table
212 structures and then generates code. */
215 gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
216 struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
217 struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
218 struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
219 struct List_Header *list_headers_ptr, Int number_units ATTRIBUTE_UNUSED,
220 char *file_info_ptr ATTRIBUTE_UNUSED, Entity_Id standard_integer,
221 Entity_Id standard_long_long_float, Entity_Id standard_exception_type,
222 Int gigi_operating_mode)
224 tree gnu_standard_long_long_float;
225 tree gnu_standard_exception_type;
226 struct elab_info *info;
228 max_gnat_nodes = max_gnat_node;
229 number_names = number_name;
230 Nodes_Ptr = nodes_ptr;
231 Next_Node_Ptr = next_node_ptr;
232 Prev_Node_Ptr = prev_node_ptr;
233 Elists_Ptr = elists_ptr;
234 Elmts_Ptr = elmts_ptr;
235 Strings_Ptr = strings_ptr;
236 String_Chars_Ptr = string_chars_ptr;
237 List_Headers_Ptr = list_headers_ptr;
239 type_annotate_only = (gigi_operating_mode == 1);
242 gnat_compute_largest_alignment ();
245 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
247 if (type_annotate_only)
249 TYPE_SIZE (void_type_node) = bitsize_zero_node;
250 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
253 /* Save the type we made for integer as the type for Standard.Integer.
254 Then make the rest of the standard types. Note that some of these
256 save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
259 gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
260 gnu_constraint_error_label_stack
261 = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
262 gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
263 gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
265 gnu_standard_long_long_float
266 = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
267 gnu_standard_exception_type
268 = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
270 init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type);
272 /* Process any Pragma Ident for the main unit. */
273 #ifdef ASM_OUTPUT_IDENT
274 if (Present (Ident_String (Main_Unit)))
277 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
280 /* If we are using the GCC exception mechanism, let GCC know. */
281 if (Exception_Mechanism == Back_End_Exceptions)
284 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
285 Compilation_Unit_to_gnu (gnat_root);
287 /* Now see if we have any elaboration procedures to deal with. */
288 for (info = elab_info_list; info; info = info->next)
290 tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
293 /* Unshare SAVE_EXPRs between subprograms. These are not unshared by
294 the gimplifier for obvious reasons, but it turns out that we need to
295 unshare them for the global level because of SAVE_EXPRs made around
296 checks for global objects and around allocators for global objects
297 of variable size, in order to prevent node sharing in the underlying
298 expression. Note that this implicitly assumes that the SAVE_EXPR
299 nodes themselves are not shared between subprograms, which would be
300 an upstream bug for which we would not change the outcome. */
301 walk_tree_without_duplicates (&gnu_body, unshare_save_expr, NULL);
303 /* Set the current function to be the elaboration procedure and gimplify
305 current_function_decl = info->elab_proc;
306 gimplify_body (&gnu_body, info->elab_proc, true);
308 /* We should have a BIND_EXPR, but it may or may not have any statements
309 in it. If it doesn't have any, we have nothing to do. */
310 gnu_stmts = gnu_body;
311 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
312 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
314 /* If there are no statements, there is no elaboration code. */
315 if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
317 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
318 cgraph_remove_node (cgraph_node (info->elab_proc));
322 /* Otherwise, compile the function. Note that we'll be gimplifying
323 it twice, but that's fine for the nodes we use. */
324 begin_subprog_body (info->elab_proc);
325 end_subprog_body (gnu_body);
329 /* We cannot track the location of errors past this point. */
330 error_gnat_node = Empty;
333 /* Perform initializations for this module. */
336 gnat_init_stmt_group (void)
338 /* Initialize ourselves. */
342 /* Enable GNAT stack checking method if needed */
343 if (!Stack_Check_Probes_On_Target)
344 set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
347 /* Returns a positive value if GNAT_NODE requires an lvalue for an
348 operand of OPERAND_TYPE, whose aliasing is specified by ALIASED,
349 zero otherwise. This is int instead of bool to facilitate usage
350 in non purely binary logic contexts. */
353 lvalue_required_p (Node_Id gnat_node, tree operand_type, int aliased)
355 switch (Nkind (gnat_node))
360 case N_Attribute_Reference:
362 unsigned char id = Get_Attribute_Id (Attribute_Name (gnat_node));
363 return id == Attr_Address
365 || id == Attr_Unchecked_Access
366 || id == Attr_Unrestricted_Access;
369 case N_Parameter_Association:
370 case N_Function_Call:
371 case N_Procedure_Call_Statement:
372 return must_pass_by_ref (operand_type)
373 || default_pass_by_ref (operand_type);
375 case N_Indexed_Component:
378 /* ??? Consider that referencing an indexed component with a
379 non-constant index forces the whole aggregate to memory.
380 Note that N_Integer_Literal is conservative, any static
381 expression in the RM sense could probably be accepted. */
382 for (gnat_temp = First (Expressions (gnat_node));
384 gnat_temp = Next (gnat_temp))
385 if (Nkind (gnat_temp) != N_Integer_Literal)
389 /* ... fall through ... */
392 aliased |= Has_Aliased_Components (Etype (Prefix (gnat_node)));
393 return lvalue_required_p (Parent (gnat_node), operand_type, aliased);
395 case N_Selected_Component:
396 aliased |= Is_Aliased (Entity (Selector_Name (gnat_node)));
397 return lvalue_required_p (Parent (gnat_node), operand_type, aliased);
399 case N_Object_Renaming_Declaration:
400 /* We need to make a real renaming only if the constant object is
401 aliased or if we may use a renaming pointer; otherwise we can
402 optimize and return the rvalue. We make an exception if the object
403 is an identifier since in this case the rvalue can be propagated
404 attached to the CONST_DECL. */
406 /* This should match the constant case of the renaming code. */
407 || Is_Composite_Type (Etype (Name (gnat_node)))
408 || Nkind (Name (gnat_node)) == N_Identifier);
417 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
418 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
419 where we should place the result type. */
422 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
424 tree gnu_result_type;
426 Node_Id gnat_temp, gnat_temp_type;
428 /* Whether the parent of gnat_node requires an lvalue. Needed in
429 specific circumstances only, so evaluated lazily. < 0 means unknown,
430 > 0 means known true, 0 means known false. */
431 int parent_requires_lvalue = -1;
433 /* If GNAT_NODE is a constant, whether we should use the initialization
434 value instead of the constant entity, typically for scalars with an
435 address clause when the parent doesn't require an lvalue. */
436 bool use_constant_initializer = false;
438 /* If the Etype of this node does not equal the Etype of the Entity,
439 something is wrong with the entity map, probably in generic
440 instantiation. However, this does not apply to types. Since we sometime
441 have strange Ekind's, just do this test for objects. Also, if the Etype of
442 the Entity is private, the Etype of the N_Identifier is allowed to be the
443 full type and also we consider a packed array type to be the same as the
444 original type. Similarly, a class-wide type is equivalent to a subtype of
445 itself. Finally, if the types are Itypes, one may be a copy of the other,
446 which is also legal. */
447 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
448 ? gnat_node : Entity (gnat_node));
449 gnat_temp_type = Etype (gnat_temp);
451 gcc_assert (Etype (gnat_node) == gnat_temp_type
452 || (Is_Packed (gnat_temp_type)
453 && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
454 || (Is_Class_Wide_Type (Etype (gnat_node)))
455 || (IN (Ekind (gnat_temp_type), Private_Kind)
456 && Present (Full_View (gnat_temp_type))
457 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
458 || (Is_Packed (Full_View (gnat_temp_type))
459 && (Etype (gnat_node)
460 == Packed_Array_Type (Full_View
461 (gnat_temp_type))))))
462 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
463 || !(Ekind (gnat_temp) == E_Variable
464 || Ekind (gnat_temp) == E_Component
465 || Ekind (gnat_temp) == E_Constant
466 || Ekind (gnat_temp) == E_Loop_Parameter
467 || IN (Ekind (gnat_temp), Formal_Kind)));
469 /* If this is a reference to a deferred constant whose partial view is an
470 unconstrained private type, the proper type is on the full view of the
471 constant, not on the full view of the type, which may be unconstrained.
473 This may be a reference to a type, for example in the prefix of the
474 attribute Position, generated for dispatching code (see Make_DT in
475 exp_disp,adb). In that case we need the type itself, not is parent,
476 in particular if it is a derived type */
477 if (Is_Private_Type (gnat_temp_type)
478 && Has_Unknown_Discriminants (gnat_temp_type)
479 && Ekind (gnat_temp) == E_Constant
480 && Present (Full_View (gnat_temp)))
482 gnat_temp = Full_View (gnat_temp);
483 gnat_temp_type = Etype (gnat_temp);
487 /* We want to use the Actual_Subtype if it has already been elaborated,
488 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
490 if ((Ekind (gnat_temp) == E_Constant
491 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
492 && !(Is_Array_Type (Etype (gnat_temp))
493 && Present (Packed_Array_Type (Etype (gnat_temp))))
494 && Present (Actual_Subtype (gnat_temp))
495 && present_gnu_tree (Actual_Subtype (gnat_temp)))
496 gnat_temp_type = Actual_Subtype (gnat_temp);
498 gnat_temp_type = Etype (gnat_node);
501 /* Expand the type of this identifier first, in case it is an enumeral
502 literal, which only get made when the type is expanded. There is no
503 order-of-elaboration issue here. */
504 gnu_result_type = get_unpadded_type (gnat_temp_type);
506 /* If this is a non-imported scalar constant with an address clause,
507 retrieve the value instead of a pointer to be dereferenced unless the
508 parent requires an lvalue. This is generally more efficient and
509 actually required if this is a static expression because it might be used
510 in a context where a dereference is inappropriate, such as a case
511 statement alternative or a record discriminant. There is no possible
512 volatile-ness shortciruit here since Volatile constants must be imported
514 if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type)
515 && !Is_Imported (gnat_temp)
516 && Present (Address_Clause (gnat_temp)))
518 parent_requires_lvalue
519 = lvalue_required_p (Parent (gnat_node), gnu_result_type,
520 Is_Aliased (gnat_temp));
521 use_constant_initializer = !parent_requires_lvalue;
524 if (use_constant_initializer)
526 /* If this is a deferred constant, the initializer is attached to the
528 if (Present (Full_View (gnat_temp)))
529 gnat_temp = Full_View (gnat_temp);
531 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
534 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
536 /* If we are in an exception handler, force this variable into memory to
537 ensure optimization does not remove stores that appear redundant but are
538 actually needed in case an exception occurs.
540 ??? Note that we need not do this if the variable is declared within the
541 handler, only if it is referenced in the handler and declared in an
542 enclosing block, but we have no way of testing that right now.
544 ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
545 here, but it can now be removed by the Tree aliasing machinery if the
546 address of the variable is never taken. All we can do is to make the
547 variable volatile, which might incur the generation of temporaries just
548 to access the memory in some circumstances. This can be avoided for
549 variables of non-constant size because they are automatically allocated
550 to memory. There might be no way of allocating a proper temporary for
551 them in any case. We only do this for SJLJ though. */
552 if (TREE_VALUE (gnu_except_ptr_stack)
553 && TREE_CODE (gnu_result) == VAR_DECL
554 && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
555 TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
557 /* Some objects (such as parameters passed by reference, globals of
558 variable size, and renamed objects) actually represent the address
559 of the object. In that case, we must do the dereference. Likewise,
560 deal with parameters to foreign convention subprograms. */
561 if (DECL_P (gnu_result)
562 && (DECL_BY_REF_P (gnu_result)
563 || (TREE_CODE (gnu_result) == PARM_DECL
564 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
566 bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
569 if (TREE_CODE (gnu_result) == PARM_DECL
570 && DECL_BY_COMPONENT_PTR_P (gnu_result))
572 = build_unary_op (INDIRECT_REF, NULL_TREE,
573 convert (build_pointer_type (gnu_result_type),
576 /* If it's a renaming pointer and we are at the right binding level,
577 we can reference the renamed object directly, since the renamed
578 expression has been protected against multiple evaluations. */
579 else if (TREE_CODE (gnu_result) == VAR_DECL
580 && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
581 && (! DECL_RENAMING_GLOBAL_P (gnu_result)
582 || global_bindings_p ()))
583 gnu_result = renamed_obj;
585 /* Return the underlying CST for a CONST_DECL like a few lines below,
586 after dereferencing in this case. */
587 else if (TREE_CODE (gnu_result) == CONST_DECL)
588 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
589 DECL_INITIAL (gnu_result));
592 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
594 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
597 /* The GNAT tree has the type of a function as the type of its result. Also
598 use the type of the result if the Etype is a subtype which is nominally
599 unconstrained. But remove any padding from the resulting type. */
600 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
601 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
603 gnu_result_type = TREE_TYPE (gnu_result);
604 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
605 && TYPE_IS_PADDING_P (gnu_result_type))
606 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
609 /* If we have a constant declaration and its initializer at hand,
610 try to return the latter to avoid the need to call fold in lots
611 of places and the need of elaboration code if this Id is used as
612 an initializer itself. */
613 if (TREE_CONSTANT (gnu_result)
614 && DECL_P (gnu_result) && DECL_INITIAL (gnu_result))
617 = (TREE_CODE (gnu_result) == CONST_DECL
618 ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result);
620 /* If there is a corresponding variable, we only want to return the CST
621 value if the parent doesn't require an lvalue. Evaluate this now if
622 we have not already done so. */
623 if (object && parent_requires_lvalue < 0)
624 parent_requires_lvalue
625 = lvalue_required_p (Parent (gnat_node), gnu_result_type,
626 Is_Aliased (gnat_temp));
628 if (!object || !parent_requires_lvalue)
629 gnu_result = DECL_INITIAL (gnu_result);
632 *gnu_result_type_p = gnu_result_type;
636 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
637 any statements we generate. */
640 Pragma_to_gnu (Node_Id gnat_node)
643 tree gnu_result = alloc_stmt_list ();
645 /* Check for (and ignore) unrecognized pragma and do nothing if we are just
647 if (type_annotate_only || !Is_Pragma_Name (Chars (gnat_node)))
650 switch (Get_Pragma_Id (Chars (gnat_node)))
652 case Pragma_Inspection_Point:
653 /* Do nothing at top level: all such variables are already viewable. */
654 if (global_bindings_p ())
657 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
659 gnat_temp = Next (gnat_temp))
661 Node_Id gnat_expr = Expression (gnat_temp);
662 tree gnu_expr = gnat_to_gnu (gnat_expr);
664 enum machine_mode mode;
665 tree asm_constraint = NULL_TREE;
666 #ifdef ASM_COMMENT_START
670 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
671 gnu_expr = TREE_OPERAND (gnu_expr, 0);
673 /* Use the value only if it fits into a normal register,
674 otherwise use the address. */
675 mode = TYPE_MODE (TREE_TYPE (gnu_expr));
676 use_address = ((GET_MODE_CLASS (mode) != MODE_INT
677 && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
678 || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
681 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
683 #ifdef ASM_COMMENT_START
684 comment = concat (ASM_COMMENT_START,
685 " inspection point: ",
686 Get_Name_String (Chars (gnat_expr)),
687 use_address ? " address" : "",
690 asm_constraint = build_string (strlen (comment), comment);
693 gnu_expr = build4 (ASM_EXPR, void_type_node,
697 (build_tree_list (NULL_TREE,
698 build_string (1, "g")),
699 gnu_expr, NULL_TREE),
701 ASM_VOLATILE_P (gnu_expr) = 1;
702 annotate_with_node (gnu_expr, gnat_node);
703 append_to_statement_list (gnu_expr, &gnu_result);
707 case Pragma_Optimize:
708 switch (Chars (Expression
709 (First (Pragma_Argument_Associations (gnat_node)))))
711 case Name_Time: case Name_Space:
713 post_error ("insufficient -O value?", gnat_node);
718 post_error ("must specify -O0?", gnat_node);
726 case Pragma_Reviewable:
727 if (write_symbols == NO_DEBUG)
728 post_error ("must specify -g?", gnat_node);
734 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
735 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
736 where we should place the result type. ATTRIBUTE is the attribute ID. */
739 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
741 tree gnu_result = error_mark_node;
742 tree gnu_result_type;
744 bool prefix_unused = false;
745 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
746 tree gnu_type = TREE_TYPE (gnu_prefix);
748 /* If the input is a NULL_EXPR, make a new one. */
749 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
751 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
752 return build1 (NULL_EXPR, *gnu_result_type_p,
753 TREE_OPERAND (gnu_prefix, 0));
760 /* These are just conversions until since representation clauses for
761 enumerations are handled in the front end. */
763 bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
765 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
766 gnu_result_type = get_unpadded_type (Etype (gnat_node));
767 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
768 checkp, checkp, true);
774 /* These just add or subject the constant 1. Representation clauses for
775 enumerations are handled in the front-end. */
776 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
777 gnu_result_type = get_unpadded_type (Etype (gnat_node));
779 if (Do_Range_Check (First (Expressions (gnat_node))))
781 gnu_expr = protect_multiple_eval (gnu_expr);
784 (build_binary_op (EQ_EXPR, integer_type_node,
786 attribute == Attr_Pred
787 ? TYPE_MIN_VALUE (gnu_result_type)
788 : TYPE_MAX_VALUE (gnu_result_type)),
789 gnu_expr, CE_Range_Check_Failed);
793 = build_binary_op (attribute == Attr_Pred
794 ? MINUS_EXPR : PLUS_EXPR,
795 gnu_result_type, gnu_expr,
796 convert (gnu_result_type, integer_one_node));
800 case Attr_Unrestricted_Access:
801 /* Conversions don't change something's address but can cause us to miss
802 the COMPONENT_REF case below, so strip them off. */
803 gnu_prefix = remove_conversions (gnu_prefix,
804 !Must_Be_Byte_Aligned (gnat_node));
806 /* If we are taking 'Address of an unconstrained object, this is the
807 pointer to the underlying array. */
808 if (attribute == Attr_Address)
809 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
811 /* ... fall through ... */
814 case Attr_Unchecked_Access:
815 case Attr_Code_Address:
816 gnu_result_type = get_unpadded_type (Etype (gnat_node));
818 = build_unary_op (((attribute == Attr_Address
819 || attribute == Attr_Unrestricted_Access)
820 && !Must_Be_Byte_Aligned (gnat_node))
821 ? ATTR_ADDR_EXPR : ADDR_EXPR,
822 gnu_result_type, gnu_prefix);
824 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
825 don't try to build a trampoline. */
826 if (attribute == Attr_Code_Address)
828 for (gnu_expr = gnu_result;
829 TREE_CODE (gnu_expr) == NOP_EXPR
830 || TREE_CODE (gnu_expr) == CONVERT_EXPR;
831 gnu_expr = TREE_OPERAND (gnu_expr, 0))
832 TREE_CONSTANT (gnu_expr) = 1;
834 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
835 TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
839 case Attr_Pool_Address:
842 tree gnu_ptr = gnu_prefix;
844 gnu_result_type = get_unpadded_type (Etype (gnat_node));
846 /* If this is an unconstrained array, we know the object must have been
847 allocated with the template in front of the object. So compute the
849 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
851 = convert (build_pointer_type
852 (TYPE_OBJECT_RECORD_TYPE
853 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
856 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
857 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
858 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
860 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
861 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
864 size_diffop (size_zero_node, gnu_pos));
865 gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
867 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
868 gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
869 gnu_ptr, gnu_byte_offset);
872 gnu_result = convert (gnu_result_type, gnu_ptr);
877 case Attr_Object_Size:
878 case Attr_Value_Size:
879 case Attr_Max_Size_In_Storage_Elements:
880 gnu_expr = gnu_prefix;
882 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
883 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
884 while (TREE_CODE (gnu_expr) == NOP_EXPR)
885 gnu_expr = TREE_OPERAND (gnu_expr, 0)
888 gnu_prefix = remove_conversions (gnu_prefix, true);
889 prefix_unused = true;
890 gnu_type = TREE_TYPE (gnu_prefix);
892 /* Replace an unconstrained array type with the type of the underlying
893 array. We can't do this with a call to maybe_unconstrained_array
894 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
895 use the record type that will be used to allocate the object and its
897 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
899 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
900 if (attribute != Attr_Max_Size_In_Storage_Elements)
901 gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
904 /* If we're looking for the size of a field, return the field size.
905 Otherwise, if the prefix is an object, or if 'Object_Size or
906 'Max_Size_In_Storage_Elements has been specified, the result is the
907 GCC size of the type. Otherwise, the result is the RM_Size of the
909 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
910 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
911 else if (TREE_CODE (gnu_prefix) != TYPE_DECL
912 || attribute == Attr_Object_Size
913 || attribute == Attr_Max_Size_In_Storage_Elements)
915 /* If this is a padded type, the GCC size isn't relevant to the
916 programmer. Normally, what we want is the RM_Size, which was set
917 from the specified size, but if it was not set, we want the size
918 of the relevant field. Using the MAX of those two produces the
919 right result in all case. Don't use the size of the field if it's
920 a self-referential type, since that's never what's wanted. */
921 if (TREE_CODE (gnu_type) == RECORD_TYPE
922 && TYPE_IS_PADDING_P (gnu_type)
923 && TREE_CODE (gnu_expr) == COMPONENT_REF)
925 gnu_result = rm_size (gnu_type);
926 if (!(CONTAINS_PLACEHOLDER_P
927 (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
929 = size_binop (MAX_EXPR, gnu_result,
930 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
932 else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
934 Node_Id gnat_deref = Prefix (gnat_node);
935 Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
936 tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
937 if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
938 && Present (gnat_actual_subtype))
940 tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
941 gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
942 gnu_actual_obj_type, get_identifier ("SIZE"));
945 gnu_result = TYPE_SIZE (gnu_type);
948 gnu_result = TYPE_SIZE (gnu_type);
951 gnu_result = rm_size (gnu_type);
953 gcc_assert (gnu_result);
955 /* Deal with a self-referential size by returning the maximum size for a
956 type and by qualifying the size with the object for 'Size of an
958 if (CONTAINS_PLACEHOLDER_P (gnu_result))
960 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
961 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
963 gnu_result = max_size (gnu_result, true);
966 /* If the type contains a template, subtract its size. */
967 if (TREE_CODE (gnu_type) == RECORD_TYPE
968 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
969 gnu_result = size_binop (MINUS_EXPR, gnu_result,
970 DECL_SIZE (TYPE_FIELDS (gnu_type)));
972 gnu_result_type = get_unpadded_type (Etype (gnat_node));
974 /* Always perform division using unsigned arithmetic as the size cannot
975 be negative, but may be an overflowed positive value. This provides
976 correct results for sizes up to 512 MB.
978 ??? Size should be calculated in storage elements directly. */
980 if (attribute == Attr_Max_Size_In_Storage_Elements)
981 gnu_result = convert (sizetype,
982 fold_build2 (CEIL_DIV_EXPR, bitsizetype,
983 gnu_result, bitsize_unit_node));
987 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
988 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
990 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
991 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
993 gnu_type = TREE_TYPE (gnu_prefix);
994 gnu_result_type = get_unpadded_type (Etype (gnat_node));
995 prefix_unused = true;
997 gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF
998 ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))
999 : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT);
1004 case Attr_Range_Length:
1005 prefix_unused = true;
1007 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1009 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1011 if (attribute == Attr_First)
1012 gnu_result = TYPE_MIN_VALUE (gnu_type);
1013 else if (attribute == Attr_Last)
1014 gnu_result = TYPE_MAX_VALUE (gnu_type);
1018 (MAX_EXPR, get_base_type (gnu_result_type),
1020 (PLUS_EXPR, get_base_type (gnu_result_type),
1021 build_binary_op (MINUS_EXPR,
1022 get_base_type (gnu_result_type),
1023 convert (gnu_result_type,
1024 TYPE_MAX_VALUE (gnu_type)),
1025 convert (gnu_result_type,
1026 TYPE_MIN_VALUE (gnu_type))),
1027 convert (gnu_result_type, integer_one_node)),
1028 convert (gnu_result_type, integer_zero_node));
1033 /* ... fall through ... */
1037 int Dimension = (Present (Expressions (gnat_node))
1038 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1040 struct parm_attr *pa = NULL;
1041 Entity_Id gnat_param = Empty;
1043 /* Make sure any implicit dereference gets done. */
1044 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1045 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1046 /* We treat unconstrained array IN parameters specially. */
1047 if (Nkind (Prefix (gnat_node)) == N_Identifier
1048 && !Is_Constrained (Etype (Prefix (gnat_node)))
1049 && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1050 gnat_param = Entity (Prefix (gnat_node));
1051 gnu_type = TREE_TYPE (gnu_prefix);
1052 prefix_unused = true;
1053 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1055 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1060 for (ndim = 1, gnu_type_temp = gnu_type;
1061 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1062 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1063 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1066 Dimension = ndim + 1 - Dimension;
1069 for (i = 1; i < Dimension; i++)
1070 gnu_type = TREE_TYPE (gnu_type);
1072 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1074 /* When not optimizing, look up the slot associated with the parameter
1075 and the dimension in the cache and create a new one on failure. */
1076 if (!optimize && Present (gnat_param))
1078 for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1079 if (pa->id == gnat_param && pa->dim == Dimension)
1084 pa = GGC_CNEW (struct parm_attr);
1085 pa->id = gnat_param;
1086 pa->dim = Dimension;
1087 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1091 /* Return the cached expression or build a new one. */
1092 if (attribute == Attr_First)
1094 if (pa && pa->first)
1096 gnu_result = pa->first;
1101 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1104 else if (attribute == Attr_Last)
1108 gnu_result = pa->last;
1113 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1116 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
1118 tree gnu_compute_type;
1120 if (pa && pa->length)
1122 gnu_result = pa->length;
1127 = signed_or_unsigned_type_for (0,
1128 get_base_type (gnu_result_type));
1132 (MAX_EXPR, gnu_compute_type,
1134 (PLUS_EXPR, gnu_compute_type,
1136 (MINUS_EXPR, gnu_compute_type,
1137 convert (gnu_compute_type,
1139 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
1140 convert (gnu_compute_type,
1142 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
1143 convert (gnu_compute_type, integer_one_node)),
1144 convert (gnu_compute_type, integer_zero_node));
1147 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1148 handling. Note that these attributes could not have been used on
1149 an unconstrained array type. */
1150 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
1153 /* Cache the expression we have just computed. Since we want to do it
1154 at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1155 create the temporary. */
1159 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1160 TREE_SIDE_EFFECTS (gnu_result) = 1;
1161 TREE_INVARIANT (gnu_result) = 1;
1162 if (attribute == Attr_First)
1163 pa->first = gnu_result;
1164 else if (attribute == Attr_Last)
1165 pa->last = gnu_result;
1167 pa->length = gnu_result;
1172 case Attr_Bit_Position:
1174 case Attr_First_Bit:
1178 HOST_WIDE_INT bitsize;
1179 HOST_WIDE_INT bitpos;
1181 tree gnu_field_bitpos;
1182 tree gnu_field_offset;
1184 enum machine_mode mode;
1185 int unsignedp, volatilep;
1187 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1188 gnu_prefix = remove_conversions (gnu_prefix, true);
1189 prefix_unused = true;
1191 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1192 the result is 0. Don't allow 'Bit on a bare component, though. */
1193 if (attribute == Attr_Bit
1194 && TREE_CODE (gnu_prefix) != COMPONENT_REF
1195 && TREE_CODE (gnu_prefix) != FIELD_DECL)
1197 gnu_result = integer_zero_node;
1202 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1203 || (attribute == Attr_Bit_Position
1204 && TREE_CODE (gnu_prefix) == FIELD_DECL));
1206 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1207 &mode, &unsignedp, &volatilep, false);
1209 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1211 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1212 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1214 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1215 TREE_CODE (gnu_inner) == COMPONENT_REF
1216 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1217 gnu_inner = TREE_OPERAND (gnu_inner, 0))
1220 = size_binop (PLUS_EXPR, gnu_field_bitpos,
1221 bit_position (TREE_OPERAND (gnu_inner, 1)));
1223 = size_binop (PLUS_EXPR, gnu_field_offset,
1224 byte_position (TREE_OPERAND (gnu_inner, 1)));
1227 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1229 gnu_field_bitpos = bit_position (gnu_prefix);
1230 gnu_field_offset = byte_position (gnu_prefix);
1234 gnu_field_bitpos = bitsize_zero_node;
1235 gnu_field_offset = size_zero_node;
1241 gnu_result = gnu_field_offset;
1244 case Attr_First_Bit:
1246 gnu_result = size_int (bitpos % BITS_PER_UNIT);
1250 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1251 gnu_result = size_binop (PLUS_EXPR, gnu_result,
1252 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1253 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1257 case Attr_Bit_Position:
1258 gnu_result = gnu_field_bitpos;
1262 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1264 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1271 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1272 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1274 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1275 gnu_result = build_binary_op (attribute == Attr_Min
1276 ? MIN_EXPR : MAX_EXPR,
1277 gnu_result_type, gnu_lhs, gnu_rhs);
1281 case Attr_Passed_By_Reference:
1282 gnu_result = size_int (default_pass_by_ref (gnu_type)
1283 || must_pass_by_ref (gnu_type));
1284 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1287 case Attr_Component_Size:
1288 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1289 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1291 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1292 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1294 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1295 gnu_type = TREE_TYPE (gnu_prefix);
1297 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1298 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1300 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1301 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1302 gnu_type = TREE_TYPE (gnu_type);
1304 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1306 /* Note this size cannot be self-referential. */
1307 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1308 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1309 prefix_unused = true;
1312 case Attr_Null_Parameter:
1313 /* This is just a zero cast to the pointer type for
1314 our prefix and dereferenced. */
1315 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1317 = build_unary_op (INDIRECT_REF, NULL_TREE,
1318 convert (build_pointer_type (gnu_result_type),
1319 integer_zero_node));
1320 TREE_PRIVATE (gnu_result) = 1;
1323 case Attr_Mechanism_Code:
1326 Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1328 prefix_unused = true;
1329 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1330 if (Present (Expressions (gnat_node)))
1332 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1334 for (gnat_obj = First_Formal (gnat_obj); i > 1;
1335 i--, gnat_obj = Next_Formal (gnat_obj))
1339 code = Mechanism (gnat_obj);
1340 if (code == Default)
1341 code = ((present_gnu_tree (gnat_obj)
1342 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1343 || ((TREE_CODE (get_gnu_tree (gnat_obj))
1345 && (DECL_BY_COMPONENT_PTR_P
1346 (get_gnu_tree (gnat_obj))))))
1347 ? By_Reference : By_Copy);
1348 gnu_result = convert (gnu_result_type, size_int (- code));
1353 /* Say we have an unimplemented attribute. Then set the value to be
1354 returned to be a zero and hope that's something we can convert to the
1355 type of this attribute. */
1356 post_error ("unimplemented attribute", gnat_node);
1357 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1358 gnu_result = integer_zero_node;
1362 /* If this is an attribute where the prefix was unused, force a use of it if
1363 it has a side-effect. But don't do it if the prefix is just an entity
1364 name. However, if an access check is needed, we must do it. See second
1365 example in AARM 11.6(5.e). */
1366 if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1367 && !Is_Entity_Name (Prefix (gnat_node)))
1368 gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1369 gnu_prefix, gnu_result);
1371 *gnu_result_type_p = gnu_result_type;
1375 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1376 to a GCC tree, which is returned. */
1379 Case_Statement_to_gnu (Node_Id gnat_node)
1385 gnu_expr = gnat_to_gnu (Expression (gnat_node));
1386 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1388 /* The range of values in a case statement is determined by the rules in
1389 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1390 of the expression. One exception arises in the case of a simple name that
1391 is parenthesized. This still has the Etype of the name, but since it is
1392 not a name, para 7 does not apply, and we need to go to the base type.
1393 This is the only case where parenthesization affects the dynamic
1394 semantics (i.e. the range of possible values at runtime that is covered
1395 by the others alternative.
1397 Another exception is if the subtype of the expression is non-static. In
1398 that case, we also have to use the base type. */
1399 if (Paren_Count (Expression (gnat_node)) != 0
1400 || !Is_OK_Static_Subtype (Underlying_Type
1401 (Etype (Expression (gnat_node)))))
1402 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1404 /* We build a SWITCH_EXPR that contains the code with interspersed
1405 CASE_LABEL_EXPRs for each label. */
1407 push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ());
1408 start_stmt_group ();
1409 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1410 Present (gnat_when);
1411 gnat_when = Next_Non_Pragma (gnat_when))
1413 Node_Id gnat_choice;
1414 int choices_added = 0;
1416 /* First compile all the different case choices for the current WHEN
1418 for (gnat_choice = First (Discrete_Choices (gnat_when));
1419 Present (gnat_choice); gnat_choice = Next (gnat_choice))
1421 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1423 switch (Nkind (gnat_choice))
1426 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1427 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1430 case N_Subtype_Indication:
1431 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1432 (Constraint (gnat_choice))));
1433 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1434 (Constraint (gnat_choice))));
1438 case N_Expanded_Name:
1439 /* This represents either a subtype range or a static value of
1440 some kind; Ekind says which. */
1441 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1443 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1445 gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1446 gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1450 /* ... fall through ... */
1452 case N_Character_Literal:
1453 case N_Integer_Literal:
1454 gnu_low = gnat_to_gnu (gnat_choice);
1457 case N_Others_Choice:
1464 /* If the case value is a subtype that raises Constraint_Error at
1465 run-time because of a wrong bound, then gnu_low or gnu_high
1466 is not translated into an INTEGER_CST. In such a case, we need
1467 to ensure that the when statement is not added in the tree,
1468 otherwise it will crash the gimplifier. */
1469 if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
1470 && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
1473 add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
1475 create_artificial_label ()),
1481 /* Push a binding level here in case variables are declared since we want
1482 them to be local to this set of statements instead of the block
1483 containing the Case statement. */
1485 if (choices_added > 0)
1487 add_stmt (build_stmt_group (Statements (gnat_when), true));
1488 add_stmt (build1 (GOTO_EXPR, void_type_node,
1489 TREE_VALUE (gnu_switch_label_stack)));
1493 /* Now emit a definition of the label all the cases branched to. */
1494 add_stmt (build1 (LABEL_EXPR, void_type_node,
1495 TREE_VALUE (gnu_switch_label_stack)));
1496 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
1497 end_stmt_group (), NULL_TREE);
1498 pop_stack (&gnu_switch_label_stack);
1503 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
1504 to a GCC tree, which is returned. */
1507 Loop_Statement_to_gnu (Node_Id gnat_node)
1509 /* ??? It would be nice to use "build" here, but there's no build5. */
1510 tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
1511 NULL_TREE, NULL_TREE, NULL_TREE);
1512 tree gnu_loop_var = NULL_TREE;
1513 Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
1514 tree gnu_cond_expr = NULL_TREE;
1517 TREE_TYPE (gnu_loop_stmt) = void_type_node;
1518 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
1519 LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
1520 annotate_with_node (gnu_loop_stmt, gnat_node);
1522 /* Save the end label of this LOOP_STMT in a stack so that the corresponding
1523 N_Exit_Statement can find it. */
1524 push_stack (&gnu_loop_label_stack, NULL_TREE,
1525 LOOP_STMT_LABEL (gnu_loop_stmt));
1527 /* Set the condition that under which the loop should continue.
1528 For "LOOP .... END LOOP;" the condition is always true. */
1529 if (No (gnat_iter_scheme))
1531 /* The case "WHILE condition LOOP ..... END LOOP;" */
1532 else if (Present (Condition (gnat_iter_scheme)))
1533 LOOP_STMT_TOP_COND (gnu_loop_stmt)
1534 = gnat_to_gnu (Condition (gnat_iter_scheme));
1537 /* We have an iteration scheme. */
1538 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
1539 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
1540 Entity_Id gnat_type = Etype (gnat_loop_var);
1541 tree gnu_type = get_unpadded_type (gnat_type);
1542 tree gnu_low = TYPE_MIN_VALUE (gnu_type);
1543 tree gnu_high = TYPE_MAX_VALUE (gnu_type);
1544 bool reversep = Reverse_Present (gnat_loop_spec);
1545 tree gnu_first = reversep ? gnu_high : gnu_low;
1546 tree gnu_last = reversep ? gnu_low : gnu_high;
1547 enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
1548 tree gnu_base_type = get_base_type (gnu_type);
1549 tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
1550 : TYPE_MAX_VALUE (gnu_base_type));
1552 /* We know the loop variable will not overflow if GNU_LAST is a constant
1553 and is not equal to GNU_LIMIT. If it might overflow, we have to move
1554 the limit test to the end of the loop. In that case, we have to test
1555 for an empty loop outside the loop. */
1556 if (TREE_CODE (gnu_last) != INTEGER_CST
1557 || TREE_CODE (gnu_limit) != INTEGER_CST
1558 || tree_int_cst_equal (gnu_last, gnu_limit))
1561 = build3 (COND_EXPR, void_type_node,
1562 build_binary_op (LE_EXPR, integer_type_node,
1564 NULL_TREE, alloc_stmt_list ());
1565 annotate_with_node (gnu_cond_expr, gnat_loop_spec);
1568 /* Open a new nesting level that will surround the loop to declare the
1569 loop index variable. */
1570 start_stmt_group ();
1573 /* Declare the loop index and set it to its initial value. */
1574 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
1575 if (DECL_BY_REF_P (gnu_loop_var))
1576 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
1578 /* The loop variable might be a padded type, so use `convert' to get a
1579 reference to the inner variable if so. */
1580 gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
1582 /* Set either the top or bottom exit condition as appropriate depending
1583 on whether or not we know an overflow cannot occur. */
1585 LOOP_STMT_BOT_COND (gnu_loop_stmt)
1586 = build_binary_op (NE_EXPR, integer_type_node,
1587 gnu_loop_var, gnu_last);
1589 LOOP_STMT_TOP_COND (gnu_loop_stmt)
1590 = build_binary_op (end_code, integer_type_node,
1591 gnu_loop_var, gnu_last);
1593 LOOP_STMT_UPDATE (gnu_loop_stmt)
1594 = build_binary_op (reversep ? PREDECREMENT_EXPR
1595 : PREINCREMENT_EXPR,
1596 TREE_TYPE (gnu_loop_var),
1598 convert (TREE_TYPE (gnu_loop_var),
1600 annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
1604 /* If the loop was named, have the name point to this loop. In this case,
1605 the association is not a ..._DECL node, but the end label from this
1607 if (Present (Identifier (gnat_node)))
1608 save_gnu_tree (Entity (Identifier (gnat_node)),
1609 LOOP_STMT_LABEL (gnu_loop_stmt), true);
1611 /* Make the loop body into its own block, so any allocated storage will be
1612 released every iteration. This is needed for stack allocation. */
1613 LOOP_STMT_BODY (gnu_loop_stmt)
1614 = build_stmt_group (Statements (gnat_node), true);
1616 /* If we declared a variable, then we are in a statement group for that
1617 declaration. Add the LOOP_STMT to it and make that the "loop". */
1620 add_stmt (gnu_loop_stmt);
1622 gnu_loop_stmt = end_stmt_group ();
1625 /* If we have an outer COND_EXPR, that's our result and this loop is its
1626 "true" statement. Otherwise, the result is the LOOP_STMT. */
1629 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
1630 gnu_result = gnu_cond_expr;
1631 recalculate_side_effects (gnu_cond_expr);
1634 gnu_result = gnu_loop_stmt;
1636 pop_stack (&gnu_loop_label_stack);
1641 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
1642 handler for the current function. */
1644 /* This is implemented by issuing a call to the appropriate VMS specific
1645 builtin. To avoid having VMS specific sections in the global gigi decls
1646 array, we maintain the decls of interest here. We can't declare them
1647 inside the function because we must mark them never to be GC'd, which we
1648 can only do at the global level. */
1650 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
1651 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
1654 establish_gnat_vms_condition_handler (void)
1656 tree establish_stmt;
1658 /* Elaborate the required decls on the first call. Check on the decl for
1659 the gnat condition handler to decide, as this is one we create so we are
1660 sure that it will be non null on subsequent calls. The builtin decl is
1661 looked up so remains null on targets where it is not implemented yet. */
1662 if (gnat_vms_condition_handler_decl == NULL_TREE)
1664 vms_builtin_establish_handler_decl
1666 (get_identifier ("__builtin_establish_vms_condition_handler"));
1668 gnat_vms_condition_handler_decl
1669 = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
1671 build_function_type_list (integer_type_node,
1675 NULL_TREE, 0, 1, 1, 0, Empty);
1678 /* Do nothing if the establish builtin is not available, which might happen
1679 on targets where the facility is not implemented. */
1680 if (vms_builtin_establish_handler_decl == NULL_TREE)
1684 = build_call_1_expr (vms_builtin_establish_handler_decl,
1686 (ADDR_EXPR, NULL_TREE,
1687 gnat_vms_condition_handler_decl));
1689 add_stmt (establish_stmt);
1692 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
1693 don't return anything. */
1696 Subprogram_Body_to_gnu (Node_Id gnat_node)
1698 /* Defining identifier of a parameter to the subprogram. */
1699 Entity_Id gnat_param;
1700 /* The defining identifier for the subprogram body. Note that if a
1701 specification has appeared before for this body, then the identifier
1702 occurring in that specification will also be a defining identifier and all
1703 the calls to this subprogram will point to that specification. */
1704 Entity_Id gnat_subprog_id
1705 = (Present (Corresponding_Spec (gnat_node))
1706 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
1707 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
1708 tree gnu_subprog_decl;
1709 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
1710 tree gnu_subprog_type;
1713 VEC(parm_attr,gc) *cache;
1715 /* If this is a generic object or if it has been eliminated,
1717 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
1718 || Ekind (gnat_subprog_id) == E_Generic_Function
1719 || Is_Eliminated (gnat_subprog_id))
1722 /* If this subprogram acts as its own spec, define it. Otherwise, just get
1723 the already-elaborated tree node. However, if this subprogram had its
1724 elaboration deferred, we will already have made a tree node for it. So
1725 treat it as not being defined in that case. Such a subprogram cannot
1726 have an address clause or a freeze node, so this test is safe, though it
1727 does disable some otherwise-useful error checking. */
1729 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
1730 Acts_As_Spec (gnat_node)
1731 && !present_gnu_tree (gnat_subprog_id));
1733 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
1735 /* Propagate the debug mode. */
1736 if (!Needs_Debug_Info (gnat_subprog_id))
1737 DECL_IGNORED_P (gnu_subprog_decl) = 1;
1739 /* Set the line number in the decl to correspond to that of the body so that
1740 the line number notes are written correctly. */
1741 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
1743 /* Initialize the information structure for the function. */
1744 allocate_struct_function (gnu_subprog_decl);
1745 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
1746 = GGC_CNEW (struct language_function);
1748 begin_subprog_body (gnu_subprog_decl);
1749 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1751 /* If there are OUT parameters, we need to ensure that the return statement
1752 properly copies them out. We do this by making a new block and converting
1753 any inner return into a goto to a label at the end of the block. */
1754 push_stack (&gnu_return_label_stack, NULL_TREE,
1755 gnu_cico_list ? create_artificial_label () : NULL_TREE);
1757 /* Get a tree corresponding to the code for the subprogram. */
1758 start_stmt_group ();
1761 /* See if there are any parameters for which we don't yet have GCC entities.
1762 These must be for OUT parameters for which we will be making VAR_DECL
1763 nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
1764 entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
1765 the order of the parameters. */
1766 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
1767 Present (gnat_param);
1768 gnat_param = Next_Formal_With_Extras (gnat_param))
1769 if (!present_gnu_tree (gnat_param))
1771 /* Skip any entries that have been already filled in; they must
1772 correspond to IN OUT parameters. */
1773 for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
1774 gnu_cico_list = TREE_CHAIN (gnu_cico_list))
1777 /* Do any needed references for padded types. */
1778 TREE_VALUE (gnu_cico_list)
1779 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
1780 gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
1783 /* On VMS, establish our condition handler to possibly turn a condition into
1784 the corresponding exception if the subprogram has a foreign convention or
1787 To ensure proper execution of local finalizations on condition instances,
1788 we must turn a condition into the corresponding exception even if there
1789 is no applicable Ada handler, and need at least one condition handler per
1790 possible call chain involving GNAT code. OTOH, establishing the handler
1791 has a cost so we want to minimize the number of subprograms into which
1792 this happens. The foreign or exported condition is expected to satisfy
1793 all the constraints. */
1794 if (TARGET_ABI_OPEN_VMS
1795 && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
1796 establish_gnat_vms_condition_handler ();
1798 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
1800 /* Generate the code of the subprogram itself. A return statement will be
1801 present and any OUT parameters will be handled there. */
1802 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
1804 gnu_result = end_stmt_group ();
1806 /* If we populated the parameter attributes cache, we need to make sure
1807 that the cached expressions are evaluated on all possible paths. */
1808 cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
1811 struct parm_attr *pa;
1814 start_stmt_group ();
1816 for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
1819 add_stmt (pa->first);
1821 add_stmt (pa->last);
1823 add_stmt (pa->length);
1826 add_stmt (gnu_result);
1827 gnu_result = end_stmt_group ();
1830 /* If we made a special return label, we need to make a block that contains
1831 the definition of that label and the copying to the return value. That
1832 block first contains the function, then the label and copy statement. */
1833 if (TREE_VALUE (gnu_return_label_stack))
1837 start_stmt_group ();
1839 add_stmt (gnu_result);
1840 add_stmt (build1 (LABEL_EXPR, void_type_node,
1841 TREE_VALUE (gnu_return_label_stack)));
1843 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1844 if (list_length (gnu_cico_list) == 1)
1845 gnu_retval = TREE_VALUE (gnu_cico_list);
1847 gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
1850 if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
1851 gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
1854 (build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval),
1857 gnu_result = end_stmt_group ();
1860 pop_stack (&gnu_return_label_stack);
1862 /* Set the end location. */
1864 ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
1865 ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
1866 : Sloc (gnat_node)),
1867 &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
1869 end_subprog_body (gnu_result);
1871 /* Disconnect the trees for parameters that we made variables for from the
1872 GNAT entities since these are unusable after we end the function. */
1873 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
1874 Present (gnat_param);
1875 gnat_param = Next_Formal_With_Extras (gnat_param))
1876 if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
1877 save_gnu_tree (gnat_param, NULL_TREE, false);
1879 if (DECL_FUNCTION_STUB (gnu_subprog_decl))
1880 build_function_stub (gnu_subprog_decl, gnat_subprog_id);
1882 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
1885 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
1886 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
1887 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
1888 If GNU_TARGET is non-null, this must be a function call and the result
1889 of the call is to be placed into that object. */
1892 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
1895 /* The GCC node corresponding to the GNAT subprogram name. This can either
1896 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
1897 or an indirect reference expression (an INDIRECT_REF node) pointing to a
1899 tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
1900 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
1901 tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
1902 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE,
1904 Entity_Id gnat_formal;
1905 Node_Id gnat_actual;
1906 tree gnu_actual_list = NULL_TREE;
1907 tree gnu_name_list = NULL_TREE;
1908 tree gnu_before_list = NULL_TREE;
1909 tree gnu_after_list = NULL_TREE;
1910 tree gnu_subprog_call;
1912 switch (Nkind (Name (gnat_node)))
1915 case N_Operator_Symbol:
1916 case N_Expanded_Name:
1917 case N_Attribute_Reference:
1918 if (Is_Eliminated (Entity (Name (gnat_node))))
1919 Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
1922 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
1924 /* If we are calling a stubbed function, make this into a raise of
1925 Program_Error. Elaborate all our args first. */
1926 if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
1927 && DECL_STUBBED_P (gnu_subprog_node))
1929 for (gnat_actual = First_Actual (gnat_node);
1930 Present (gnat_actual);
1931 gnat_actual = Next_Actual (gnat_actual))
1932 add_stmt (gnat_to_gnu (gnat_actual));
1936 = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node,
1937 N_Raise_Program_Error);
1939 if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
1941 *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
1942 return build1 (NULL_EXPR, *gnu_result_type_p, call_expr);
1949 /* If we are calling by supplying a pointer to a target, set up that
1950 pointer as the first argument. Use GNU_TARGET if one was passed;
1951 otherwise, make a target by building a variable of the maximum size
1953 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
1955 tree gnu_real_ret_type
1956 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
1961 = maybe_pad_type (gnu_real_ret_type,
1962 max_size (TYPE_SIZE (gnu_real_ret_type), true),
1963 0, Etype (Name (gnat_node)), "PAD", false,
1966 /* ??? We may be about to create a static temporary if we happen to
1967 be at the global binding level. That's a regression from what
1968 the 3.x back-end would generate in the same situation, but we
1969 don't have a mechanism in Gigi for creating automatic variables
1970 in the elaboration routines. */
1972 = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
1973 NULL, false, false, false, false, NULL,
1978 = tree_cons (NULL_TREE,
1979 build_unary_op (ADDR_EXPR, NULL_TREE,
1980 unchecked_convert (gnu_real_ret_type,
1987 /* The only way we can be making a call via an access type is if Name is an
1988 explicit dereference. In that case, get the list of formal args from the
1989 type the access type is pointing to. Otherwise, get the formals from
1990 entity being called. */
1991 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
1992 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
1993 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
1994 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
1997 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
1999 /* Create the list of the actual parameters as GCC expects it, namely a chain
2000 of TREE_LIST nodes in which the TREE_VALUE field of each node is a
2001 parameter-expression and the TREE_PURPOSE field is null. Skip OUT
2002 parameters not passed by reference and don't need to be copied in. */
2003 for (gnat_actual = First_Actual (gnat_node);
2004 Present (gnat_actual);
2005 gnat_formal = Next_Formal_With_Extras (gnat_formal),
2006 gnat_actual = Next_Actual (gnat_actual))
2009 = (present_gnu_tree (gnat_formal)
2010 ? get_gnu_tree (gnat_formal) : NULL_TREE);
2011 tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2012 /* We treat a conversion between aggregate types as if it is an
2013 unchecked conversion. */
2014 bool unchecked_convert_p
2015 = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2016 || (Nkind (gnat_actual) == N_Type_Conversion
2017 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2018 Node_Id gnat_name = (unchecked_convert_p
2019 ? Expression (gnat_actual) : gnat_actual);
2020 tree gnu_name = gnat_to_gnu (gnat_name);
2021 tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
2024 /* If it's possible we may need to use this expression twice, make sure
2025 than any side-effects are handled via SAVE_EXPRs. Likewise if we need
2026 to force side-effects before the call.
2028 ??? This is more conservative than we need since we don't need to do
2029 this for pass-by-ref with no conversion. If we are passing a
2030 non-addressable Out or In Out parameter by reference, pass the address
2031 of a copy and set up to copy back out after the call. */
2032 if (Ekind (gnat_formal) != E_In_Parameter)
2034 gnu_name = gnat_stabilize_reference (gnu_name, true);
2036 if (!addressable_p (gnu_name)
2038 && (DECL_BY_REF_P (gnu_formal)
2039 || (TREE_CODE (gnu_formal) == PARM_DECL
2040 && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2041 || (DECL_BY_DESCRIPTOR_P (gnu_formal))))))
2043 tree gnu_copy = gnu_name;
2046 /* If the type is by_reference, a copy is not allowed. */
2047 if (Is_By_Reference_Type (Etype (gnat_formal)))
2049 ("misaligned & cannot be passed by reference", gnat_actual);
2051 /* For users of Starlet we issue a warning because the
2052 interface apparently assumes that by-ref parameters
2053 outlive the procedure invocation. The code still
2054 will not work as intended, but we cannot do much
2055 better since other low-level parts of the back-end
2056 would allocate temporaries at will because of the
2057 misalignment if we did not do so here. */
2059 else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2062 ("?possible violation of implicit assumption",
2065 ("?made by pragma Import_Valued_Procedure on &",
2066 gnat_actual, Entity (Name (gnat_node)));
2068 ("?because of misalignment of &",
2069 gnat_actual, gnat_formal);
2072 /* Remove any unpadding on the actual and make a copy. But if
2073 the actual is a justified modular type, first convert
2075 if (TREE_CODE (gnu_name) == COMPONENT_REF
2076 && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
2078 && (TYPE_IS_PADDING_P
2079 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
2080 gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2081 else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2082 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)))
2083 gnu_name = convert (gnu_name_type, gnu_name);
2085 /* Make a SAVE_EXPR to both properly account for potential side
2086 effects and handle the creation of a temporary copy. Special
2087 code in gnat_gimplify_expr ensures that the same temporary is
2088 used as the actual and copied back after the call. */
2089 gnu_actual = save_expr (gnu_name);
2091 /* Set up to move the copy back to the original. */
2092 gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE,
2093 gnu_copy, gnu_actual);
2094 annotate_with_node (gnu_temp, gnat_actual);
2095 append_to_statement_list (gnu_temp, &gnu_after_list);
2097 /* Account for next statement just below. */
2098 gnu_name = gnu_actual;
2102 /* If this was a procedure call, we may not have removed any padding.
2103 So do it here for the part we will use as an input, if any. */
2104 gnu_actual = gnu_name;
2105 if (Ekind (gnat_formal) != E_Out_Parameter
2106 && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2107 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2108 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2111 /* Unless this is an In parameter, we must remove any LJM building
2113 if (Ekind (gnat_formal) != E_In_Parameter
2114 && TREE_CODE (gnu_name) == CONSTRUCTOR
2115 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2116 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2117 gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
2120 if (Ekind (gnat_formal) != E_Out_Parameter
2121 && !unchecked_convert_p
2122 && Do_Range_Check (gnat_actual))
2123 gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2125 /* Do any needed conversions. We need only check for unchecked
2126 conversion since normal conversions will be handled by just
2127 converting to the formal type. */
2128 if (unchecked_convert_p)
2131 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2133 (Nkind (gnat_actual)
2134 == N_Unchecked_Type_Conversion)
2135 && No_Truncation (gnat_actual));
2137 /* One we've done the unchecked conversion, we still must ensure that
2138 the object is in range of the formal's type. */
2139 if (Ekind (gnat_formal) != E_Out_Parameter
2140 && Do_Range_Check (gnat_actual))
2141 gnu_actual = emit_range_check (gnu_actual,
2142 Etype (gnat_formal));
2144 else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2145 /* We may have suppressed a conversion to the Etype of the actual since
2146 the parent is a procedure call. So add the conversion here. */
2147 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2150 if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2151 gnu_actual = convert (gnu_formal_type, gnu_actual);
2153 /* If we have not saved a GCC object for the formal, it means it is an
2154 OUT parameter not passed by reference and that does not need to be
2155 copied in. Otherwise, look at the PARM_DECL to see if it is passed by
2158 && TREE_CODE (gnu_formal) == PARM_DECL && DECL_BY_REF_P (gnu_formal))
2160 if (Ekind (gnat_formal) != E_In_Parameter)
2162 gnu_actual = gnu_name;
2164 /* If we have a padded type, be sure we've removed padding. */
2165 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2166 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2167 && TREE_CODE (gnu_actual) != SAVE_EXPR)
2168 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2171 /* If we have the constructed subtype of an aliased object
2172 with an unconstrained nominal subtype, the type of the
2173 actual includes the template, although it is formally
2174 constrained. So we need to convert it back to the real
2175 constructed subtype to retrieve the constrained part
2176 and takes its address. */
2177 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2178 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2179 && TREE_CODE (gnu_actual) != SAVE_EXPR
2180 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2181 && Is_Array_Type (Etype (gnat_actual)))
2182 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2186 /* Otherwise, if we have a non-addressable COMPONENT_REF of a
2187 variable-size type see if it's doing a unpadding operation. If
2188 so, remove that operation since we have no way of allocating the
2189 required temporary. */
2190 if (TREE_CODE (gnu_actual) == COMPONENT_REF
2191 && !TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2192 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0)))
2194 && TYPE_IS_PADDING_P (TREE_TYPE
2195 (TREE_OPERAND (gnu_actual, 0)))
2196 && !addressable_p (gnu_actual))
2197 gnu_actual = TREE_OPERAND (gnu_actual, 0);
2199 /* For In parameters, gnu_actual might still not be addressable at
2200 this point and we need the creation of a temporary copy since
2201 this is to be passed by ref. Resorting to save_expr to force a
2202 SAVE_EXPR temporary creation here is not guaranteed to work
2203 because the actual might be invariant or readonly without side
2204 effects, so we let the gimplifier process this case. */
2206 /* The symmetry of the paths to the type of an entity is broken here
2207 since arguments don't know that they will be passed by ref. */
2208 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2209 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2211 else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
2212 && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2214 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2215 gnu_actual = maybe_implicit_deref (gnu_actual);
2216 gnu_actual = maybe_unconstrained_array (gnu_actual);
2218 if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
2219 && TYPE_IS_PADDING_P (gnu_formal_type))
2221 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2222 gnu_actual = convert (gnu_formal_type, gnu_actual);
2225 /* Take the address of the object and convert to the proper pointer
2226 type. We'd like to actually compute the address of the beginning
2227 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2228 possibility that the ARRAY_REF might return a constant and we'd be
2229 getting the wrong address. Neither approach is exactly correct,
2230 but this is the most likely to work in all cases. */
2231 gnu_actual = convert (gnu_formal_type,
2232 build_unary_op (ADDR_EXPR, NULL_TREE,
2235 else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
2236 && DECL_BY_DESCRIPTOR_P (gnu_formal))
2238 /* If arg is 'Null_Parameter, pass zero descriptor. */
2239 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2240 || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2241 && TREE_PRIVATE (gnu_actual))
2242 gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
2245 gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2246 fill_vms_descriptor (gnu_actual,
2251 tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
2253 if (Ekind (gnat_formal) != E_In_Parameter)
2254 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2256 if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL)
2259 /* If this is 'Null_Parameter, pass a zero even though we are
2260 dereferencing it. */
2261 else if (TREE_CODE (gnu_actual) == INDIRECT_REF
2262 && TREE_PRIVATE (gnu_actual)
2263 && host_integerp (gnu_actual_size, 1)
2264 && 0 >= compare_tree_int (gnu_actual_size,
2267 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2268 convert (gnat_type_for_size
2269 (tree_low_cst (gnu_actual_size, 1),
2274 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2277 gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
2280 gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type),
2282 nreverse (gnu_actual_list));
2284 /* If we return by passing a target, the result is the target after the
2285 call. We must not emit the call directly here because this might be
2286 evaluated as part of an expression with conditions to control whether
2287 the call should be emitted or not. */
2288 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
2290 /* Conceptually, what we need is a COMPOUND_EXPR with the call followed
2291 by the target object converted to the proper type. Doing so would
2292 potentially be very inefficient, however, as this expresssion might
2293 end up wrapped into an outer SAVE_EXPR later on, which would incur a
2294 pointless temporary copy of the whole object.
2296 What we do instead is build a COMPOUND_EXPR returning the address of
2297 the target, and then dereference. Wrapping the COMPOUND_EXPR into a
2298 SAVE_EXPR later on then only incurs a pointer copy. */
2300 tree gnu_result_type
2301 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
2304 (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target] */
2306 tree gnu_target_address
2307 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target);
2310 = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address),
2311 gnu_subprog_call, gnu_target_address);
2314 = unchecked_convert (gnu_result_type,
2315 build_unary_op (INDIRECT_REF, NULL_TREE,
2319 *gnu_result_type_p = gnu_result_type;
2323 /* If it is a function call, the result is the call expression unless
2324 a target is specified, in which case we copy the result into the target
2325 and return the assignment statement. */
2326 else if (Nkind (gnat_node) == N_Function_Call)
2328 gnu_result = gnu_subprog_call;
2330 /* If the function returns an unconstrained array or by reference,
2331 we have to de-dereference the pointer. */
2332 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
2333 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
2334 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2337 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2338 gnu_target, gnu_result);
2340 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2345 /* If this is the case where the GNAT tree contains a procedure call
2346 but the Ada procedure has copy in copy out parameters, the special
2347 parameter passing mechanism must be used. */
2348 else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
2350 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
2351 in copy out parameters. */
2352 tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2353 int length = list_length (scalar_return_list);
2359 gnu_subprog_call = save_expr (gnu_subprog_call);
2360 gnu_name_list = nreverse (gnu_name_list);
2362 /* If any of the names had side-effects, ensure they are all
2363 evaluated before the call. */
2364 for (gnu_name = gnu_name_list; gnu_name;
2365 gnu_name = TREE_CHAIN (gnu_name))
2366 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
2367 append_to_statement_list (TREE_VALUE (gnu_name),
2371 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2372 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2374 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2376 for (gnat_actual = First_Actual (gnat_node);
2377 Present (gnat_actual);
2378 gnat_formal = Next_Formal_With_Extras (gnat_formal),
2379 gnat_actual = Next_Actual (gnat_actual))
2380 /* If we are dealing with a copy in copy out parameter, we must
2381 retrieve its value from the record returned in the call. */
2382 if (!(present_gnu_tree (gnat_formal)
2383 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2384 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2385 || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2386 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2387 || (DECL_BY_DESCRIPTOR_P
2388 (get_gnu_tree (gnat_formal))))))))
2389 && Ekind (gnat_formal) != E_In_Parameter)
2391 /* Get the value to assign to this OUT or IN OUT parameter. It is
2392 either the result of the function if there is only a single such
2393 parameter or the appropriate field from the record returned. */
2395 = length == 1 ? gnu_subprog_call
2396 : build_component_ref (gnu_subprog_call, NULL_TREE,
2397 TREE_PURPOSE (scalar_return_list),
2400 /* If the actual is a conversion, get the inner expression, which
2401 will be the real destination, and convert the result to the
2402 type of the actual parameter. */
2404 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
2406 /* If the result is a padded type, remove the padding. */
2407 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
2408 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
2409 gnu_result = convert (TREE_TYPE (TYPE_FIELDS
2410 (TREE_TYPE (gnu_result))),
2413 /* If the actual is a type conversion, the real target object is
2414 denoted by the inner Expression and we need to convert the
2415 result to the associated type.
2417 We also need to convert our gnu assignment target to this type
2418 if the corresponding gnu_name was constructed from the GNAT
2419 conversion node and not from the inner Expression. */
2420 if (Nkind (gnat_actual) == N_Type_Conversion)
2423 = convert_with_check
2424 (Etype (Expression (gnat_actual)), gnu_result,
2425 Do_Overflow_Check (gnat_actual),
2426 Do_Range_Check (Expression (gnat_actual)),
2427 Float_Truncate (gnat_actual));
2429 if (!Is_Composite_Type
2430 (Underlying_Type (Etype (gnat_formal))))
2432 = convert (TREE_TYPE (gnu_result), gnu_actual);
2435 /* Unchecked conversions as actuals for out parameters are not
2436 allowed in user code because they are not variables, but do
2437 occur in front-end expansions. The associated gnu_name is
2438 always obtained from the inner expression in such cases. */
2439 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2440 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
2442 No_Truncation (gnat_actual));
2445 if (Do_Range_Check (gnat_actual))
2446 gnu_result = emit_range_check (gnu_result,
2447 Etype (gnat_actual));
2449 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2450 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
2451 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
2454 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2455 gnu_actual, gnu_result);
2456 annotate_with_node (gnu_result, gnat_actual);
2457 append_to_statement_list (gnu_result, &gnu_before_list);
2458 scalar_return_list = TREE_CHAIN (scalar_return_list);
2459 gnu_name_list = TREE_CHAIN (gnu_name_list);
2464 annotate_with_node (gnu_subprog_call, gnat_node);
2465 append_to_statement_list (gnu_subprog_call, &gnu_before_list);
2468 append_to_statement_list (gnu_after_list, &gnu_before_list);
2469 return gnu_before_list;
2472 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2473 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
2476 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
2478 tree gnu_jmpsave_decl = NULL_TREE;
2479 tree gnu_jmpbuf_decl = NULL_TREE;
2480 /* If just annotating, ignore all EH and cleanups. */
2481 bool gcc_zcx = (!type_annotate_only
2482 && Present (Exception_Handlers (gnat_node))
2483 && Exception_Mechanism == Back_End_Exceptions);
2485 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
2486 && Exception_Mechanism == Setjmp_Longjmp);
2487 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
2488 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
2489 tree gnu_inner_block; /* The statement(s) for the block itself. */
2494 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2495 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
2496 add_cleanup, and when we leave the binding, end_stmt_group will create
2497 the TRY_FINALLY_EXPR.
2499 ??? The region level calls down there have been specifically put in place
2500 for a ZCX context and currently the order in which things are emitted
2501 (region/handlers) is different from the SJLJ case. Instead of putting
2502 other calls with different conditions at other places for the SJLJ case,
2503 it seems cleaner to reorder things for the SJLJ case and generalize the
2504 condition to make it not ZCX specific.
2506 If there are any exceptions or cleanup processing involved, we need an
2507 outer statement group (for Setjmp_Longjmp) and binding level. */
2508 if (binding_for_block)
2510 start_stmt_group ();
2514 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2515 area for address of previous buffer. Do this first since we need to have
2516 the setjmp buf known for any decls in this block. */
2519 gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
2520 NULL_TREE, jmpbuf_ptr_type,
2521 build_call_0_expr (get_jmpbuf_decl),
2522 false, false, false, false, NULL,
2524 DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
2526 /* The __builtin_setjmp receivers will immediately reinstall it. Now
2527 because of the unstructured form of EH used by setjmp_longjmp, there
2528 might be forward edges going to __builtin_setjmp receivers on which
2529 it is uninitialized, although they will never be actually taken. */
2530 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
2531 gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
2532 NULL_TREE, jmpbuf_type,
2533 NULL_TREE, false, false, false, false,
2535 DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
2537 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
2539 /* When we exit this block, restore the saved value. */
2540 add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
2541 End_Label (gnat_node));
2544 /* If we are to call a function when exiting this block, add a cleanup
2545 to the binding level we made above. Note that add_cleanup is FIFO
2546 so we must register this cleanup after the EH cleanup just above. */
2548 add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
2549 End_Label (gnat_node));
2551 /* Now build the tree for the declarations and statements inside this block.
2552 If this is SJLJ, set our jmp_buf as the current buffer. */
2553 start_stmt_group ();
2556 add_stmt (build_call_1_expr (set_jmpbuf_decl,
2557 build_unary_op (ADDR_EXPR, NULL_TREE,
2560 if (Present (First_Real_Statement (gnat_node)))
2561 process_decls (Statements (gnat_node), Empty,
2562 First_Real_Statement (gnat_node), true, true);
2564 /* Generate code for each statement in the block. */
2565 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
2566 ? First_Real_Statement (gnat_node)
2567 : First (Statements (gnat_node)));
2568 Present (gnat_temp); gnat_temp = Next (gnat_temp))
2569 add_stmt (gnat_to_gnu (gnat_temp));
2570 gnu_inner_block = end_stmt_group ();
2572 /* Now generate code for the two exception models, if either is relevant for
2576 tree *gnu_else_ptr = 0;
2579 /* Make a binding level for the exception handling declarations and code
2580 and set up gnu_except_ptr_stack for the handlers to use. */
2581 start_stmt_group ();
2584 push_stack (&gnu_except_ptr_stack, NULL_TREE,
2585 create_var_decl (get_identifier ("EXCEPT_PTR"),
2587 build_pointer_type (except_type_node),
2588 build_call_0_expr (get_excptr_decl), false,
2589 false, false, false, NULL, gnat_node));
2591 /* Generate code for each handler. The N_Exception_Handler case does the
2592 real work and returns a COND_EXPR for each handler, which we chain
2594 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2595 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
2597 gnu_expr = gnat_to_gnu (gnat_temp);
2599 /* If this is the first one, set it as the outer one. Otherwise,
2600 point the "else" part of the previous handler to us. Then point
2601 to our "else" part. */
2603 add_stmt (gnu_expr);
2605 *gnu_else_ptr = gnu_expr;
2607 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
2610 /* If none of the exception handlers did anything, re-raise but do not
2612 gnu_expr = build_call_1_expr (raise_nodefer_decl,
2613 TREE_VALUE (gnu_except_ptr_stack));
2614 annotate_with_node (gnu_expr, gnat_node);
2617 *gnu_else_ptr = gnu_expr;
2619 add_stmt (gnu_expr);
2621 /* End the binding level dedicated to the exception handlers and get the
2622 whole statement group. */
2623 pop_stack (&gnu_except_ptr_stack);
2625 gnu_handler = end_stmt_group ();
2627 /* If the setjmp returns 1, we restore our incoming longjmp value and
2628 then check the handlers. */
2629 start_stmt_group ();
2630 add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
2633 add_stmt (gnu_handler);
2634 gnu_handler = end_stmt_group ();
2636 /* This block is now "if (setjmp) ... <handlers> else <block>". */
2637 gnu_result = build3 (COND_EXPR, void_type_node,
2640 build_unary_op (ADDR_EXPR, NULL_TREE,
2642 gnu_handler, gnu_inner_block);
2648 /* First make a block containing the handlers. */
2649 start_stmt_group ();
2650 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2651 Present (gnat_temp);
2652 gnat_temp = Next_Non_Pragma (gnat_temp))
2653 add_stmt (gnat_to_gnu (gnat_temp));
2654 gnu_handlers = end_stmt_group ();
2656 /* Now make the TRY_CATCH_EXPR for the block. */
2657 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
2658 gnu_inner_block, gnu_handlers);
2661 gnu_result = gnu_inner_block;
2663 /* Now close our outer block, if we had to make one. */
2664 if (binding_for_block)
2666 add_stmt (gnu_result);
2668 gnu_result = end_stmt_group ();
2674 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2675 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
2676 exception handling. */
2679 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
2681 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
2682 an "if" statement to select the proper exceptions. For "Others", exclude
2683 exceptions where Handled_By_Others is nonzero unless the All_Others flag
2684 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
2685 tree gnu_choice = integer_zero_node;
2686 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
2689 for (gnat_temp = First (Exception_Choices (gnat_node));
2690 gnat_temp; gnat_temp = Next (gnat_temp))
2694 if (Nkind (gnat_temp) == N_Others_Choice)
2696 if (All_Others (gnat_temp))
2697 this_choice = integer_one_node;
2701 (EQ_EXPR, integer_type_node,
2706 (INDIRECT_REF, NULL_TREE,
2707 TREE_VALUE (gnu_except_ptr_stack)),
2708 get_identifier ("not_handled_by_others"), NULL_TREE,
2713 else if (Nkind (gnat_temp) == N_Identifier
2714 || Nkind (gnat_temp) == N_Expanded_Name)
2716 Entity_Id gnat_ex_id = Entity (gnat_temp);
2719 /* Exception may be a renaming. Recover original exception which is
2720 the one elaborated and registered. */
2721 if (Present (Renamed_Object (gnat_ex_id)))
2722 gnat_ex_id = Renamed_Object (gnat_ex_id);
2724 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2728 (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
2729 convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
2730 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
2732 /* If this is the distinguished exception "Non_Ada_Error" (and we are
2733 in VMS mode), also allow a non-Ada exception (a VMS condition) t
2735 if (Is_Non_Ada_Error (Entity (gnat_temp)))
2738 = build_component_ref
2739 (build_unary_op (INDIRECT_REF, NULL_TREE,
2740 TREE_VALUE (gnu_except_ptr_stack)),
2741 get_identifier ("lang"), NULL_TREE, false);
2745 (TRUTH_ORIF_EXPR, integer_type_node,
2746 build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
2747 build_int_cst (TREE_TYPE (gnu_comp), 'V')),
2754 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
2755 gnu_choice, this_choice);
2758 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
2761 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2762 to a GCC tree, which is returned. This is the variant for ZCX. */
2765 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
2767 tree gnu_etypes_list = NULL_TREE;
2770 tree gnu_current_exc_ptr;
2771 tree gnu_incoming_exc_ptr;
2774 /* We build a TREE_LIST of nodes representing what exception types this
2775 handler can catch, with special cases for others and all others cases.
2777 Each exception type is actually identified by a pointer to the exception
2778 id, or to a dummy object for "others" and "all others".
2780 Care should be taken to ensure that the control flow impact of "others"
2781 and "all others" is known to GCC. lang_eh_type_covers is doing the trick
2783 for (gnat_temp = First (Exception_Choices (gnat_node));
2784 gnat_temp; gnat_temp = Next (gnat_temp))
2786 if (Nkind (gnat_temp) == N_Others_Choice)
2789 = All_Others (gnat_temp) ? all_others_decl : others_decl;
2792 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2794 else if (Nkind (gnat_temp) == N_Identifier
2795 || Nkind (gnat_temp) == N_Expanded_Name)
2797 Entity_Id gnat_ex_id = Entity (gnat_temp);
2799 /* Exception may be a renaming. Recover original exception which is
2800 the one elaborated and registered. */
2801 if (Present (Renamed_Object (gnat_ex_id)))
2802 gnat_ex_id = Renamed_Object (gnat_ex_id);
2804 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2805 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2807 /* The Non_Ada_Error case for VMS exceptions is handled
2808 by the personality routine. */
2813 /* The GCC interface expects NULL to be passed for catch all handlers, so
2814 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
2815 is integer_zero_node. It would not work, however, because GCC's
2816 notion of "catch all" is stronger than our notion of "others". Until
2817 we correctly use the cleanup interface as well, doing that would
2818 prevent the "all others" handlers from being seen, because nothing
2819 can be caught beyond a catch all from GCC's point of view. */
2820 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
2823 start_stmt_group ();
2826 /* Expand a call to the begin_handler hook at the beginning of the handler,
2827 and arrange for a call to the end_handler hook to occur on every possible
2830 The hooks expect a pointer to the low level occurrence. This is required
2831 for our stack management scheme because a raise inside the handler pushes
2832 a new occurrence on top of the stack, which means that this top does not
2833 necessarily match the occurrence this handler was dealing with.
2835 The EXC_PTR_EXPR object references the exception occurrence being
2836 propagated. Upon handler entry, this is the exception for which the
2837 handler is triggered. This might not be the case upon handler exit,
2838 however, as we might have a new occurrence propagated by the handler's
2839 body, and the end_handler hook called as a cleanup in this context.
2841 We use a local variable to retrieve the incoming value at handler entry
2842 time, and reuse it to feed the end_handler hook's argument at exit. */
2843 gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
2844 gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
2845 ptr_type_node, gnu_current_exc_ptr,
2846 false, false, false, false, NULL,
2849 add_stmt_with_node (build_call_1_expr (begin_handler_decl,
2850 gnu_incoming_exc_ptr),
2852 /* ??? We don't seem to have an End_Label at hand to set the location. */
2853 add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
2855 add_stmt_list (Statements (gnat_node));
2858 return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
2862 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
2865 Compilation_Unit_to_gnu (Node_Id gnat_node)
2867 /* Make the decl for the elaboration procedure. */
2868 bool body_p = (Defining_Entity (Unit (gnat_node)),
2869 Nkind (Unit (gnat_node)) == N_Package_Body
2870 || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
2871 Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
2872 tree gnu_elab_proc_decl
2873 = create_subprog_decl
2874 (create_concat_name (gnat_unit_entity,
2875 body_p ? "elabb" : "elabs"),
2876 NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
2878 struct elab_info *info;
2880 push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
2882 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
2883 allocate_struct_function (gnu_elab_proc_decl);
2884 Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
2887 /* For a body, first process the spec if there is one. */
2888 if (Nkind (Unit (gnat_node)) == N_Package_Body
2889 || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
2890 && !Acts_As_Spec (gnat_node)))
2892 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
2893 finalize_from_with_types ();
2896 process_inlined_subprograms (gnat_node);
2898 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
2900 elaborate_all_entities (gnat_node);
2902 if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
2903 || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
2904 || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
2908 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
2910 add_stmt (gnat_to_gnu (Unit (gnat_node)));
2912 /* Process any pragmas and actions following the unit. */
2913 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
2914 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
2915 finalize_from_with_types ();
2917 /* Save away what we've made so far and record this potential elaboration
2919 info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
2920 set_current_block_context (gnu_elab_proc_decl);
2922 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
2923 info->next = elab_info_list;
2924 info->elab_proc = gnu_elab_proc_decl;
2925 info->gnat_node = gnat_node;
2926 elab_info_list = info;
2928 /* Generate elaboration code for this unit, if necessary, and say whether
2930 pop_stack (&gnu_elab_proc_stack);
2932 /* Invalidate the global renaming pointers. This is necessary because
2933 stabilization of the renamed entities may create SAVE_EXPRs which
2934 have been tied to a specific elaboration routine just above. */
2935 invalidate_global_renaming_pointers ();
2938 /* This function is the driver of the GNAT to GCC tree transformation
2939 process. It is the entry point of the tree transformer. GNAT_NODE is the
2940 root of some GNAT tree. Return the root of the corresponding GCC tree.
2941 If this is an expression, return the GCC equivalent of the expression. If
2942 it is a statement, return the statement. In the case when called for a
2943 statement, it may also add statements to the current statement group, in
2944 which case anything it returns is to be interpreted as occurring after
2945 anything `it already added. */
2948 gnat_to_gnu (Node_Id gnat_node)
2950 bool went_into_elab_proc = false;
2951 tree gnu_result = error_mark_node; /* Default to no value. */
2952 tree gnu_result_type = void_type_node;
2954 tree gnu_lhs, gnu_rhs;
2957 /* Save node number for error message and set location information. */
2958 error_gnat_node = gnat_node;
2959 Sloc_to_locus (Sloc (gnat_node), &input_location);
2961 if (type_annotate_only
2962 && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call))
2963 return alloc_stmt_list ();
2965 /* If this node is a non-static subexpression and we are only
2966 annotating types, make this into a NULL_EXPR. */
2967 if (type_annotate_only
2968 && IN (Nkind (gnat_node), N_Subexpr)
2969 && Nkind (gnat_node) != N_Identifier
2970 && !Compile_Time_Known_Value (gnat_node))
2971 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
2972 build_call_raise (CE_Range_Check_Failed, gnat_node,
2973 N_Raise_Constraint_Error));
2975 /* If this is a Statement and we are at top level, it must be part of the
2976 elaboration procedure, so mark us as being in that procedure and push our
2979 If we are in the elaboration procedure, check if we are violating a a
2980 No_Elaboration_Code restriction by having a statement there. */
2981 if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
2982 && Nkind (gnat_node) != N_Null_Statement)
2983 || Nkind (gnat_node) == N_Procedure_Call_Statement
2984 || Nkind (gnat_node) == N_Label
2985 || Nkind (gnat_node) == N_Implicit_Label_Declaration
2986 || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
2987 || ((Nkind (gnat_node) == N_Raise_Constraint_Error
2988 || Nkind (gnat_node) == N_Raise_Storage_Error
2989 || Nkind (gnat_node) == N_Raise_Program_Error)
2990 && (Ekind (Etype (gnat_node)) == E_Void)))
2992 if (!current_function_decl)
2994 current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
2995 start_stmt_group ();
2997 went_into_elab_proc = true;
3000 /* Don't check for a possible No_Elaboration_Code restriction violation
3001 on N_Handled_Sequence_Of_Statements, as we want to signal an error on
3002 every nested real statement instead. This also avoids triggering
3003 spurious errors on dummy (empty) sequences created by the front-end
3004 for package bodies in some cases. */
3006 if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
3007 && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
3008 Check_Elaboration_Code_Allowed (gnat_node);
3011 switch (Nkind (gnat_node))
3013 /********************************/
3014 /* Chapter 2: Lexical Elements: */
3015 /********************************/
3018 case N_Expanded_Name:
3019 case N_Operator_Symbol:
3020 case N_Defining_Identifier:
3021 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
3024 case N_Integer_Literal:
3028 /* Get the type of the result, looking inside any padding and
3029 justified modular types. Then get the value in that type. */
3030 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3032 if (TREE_CODE (gnu_type) == RECORD_TYPE
3033 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
3034 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3036 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
3038 /* If the result overflows (meaning it doesn't fit in its base type),
3039 abort. We would like to check that the value is within the range
3040 of the subtype, but that causes problems with subtypes whose usage
3041 will raise Constraint_Error and with biased representation, so
3043 gcc_assert (!TREE_OVERFLOW (gnu_result));
3047 case N_Character_Literal:
3048 /* If a Entity is present, it means that this was one of the
3049 literals in a user-defined character type. In that case,
3050 just return the value in the CONST_DECL. Otherwise, use the
3051 character code. In that case, the base type should be an
3052 INTEGER_TYPE, but we won't bother checking for that. */
3053 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3054 if (Present (Entity (gnat_node)))
3055 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
3058 = build_int_cst_type
3059 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
3062 case N_Real_Literal:
3063 /* If this is of a fixed-point type, the value we want is the
3064 value of the corresponding integer. */
3065 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
3067 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3068 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
3070 gcc_assert (!TREE_OVERFLOW (gnu_result));
3073 /* We should never see a Vax_Float type literal, since the front end
3074 is supposed to transform these using appropriate conversions */
3075 else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
3080 Ureal ur_realval = Realval (gnat_node);
3082 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3084 /* If the real value is zero, so is the result. Otherwise,
3085 convert it to a machine number if it isn't already. That
3086 forces BASE to 0 or 2 and simplifies the rest of our logic. */
3087 if (UR_Is_Zero (ur_realval))
3088 gnu_result = convert (gnu_result_type, integer_zero_node);
3091 if (!Is_Machine_Number (gnat_node))
3093 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
3094 ur_realval, Round_Even, gnat_node);
3097 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
3099 /* If we have a base of zero, divide by the denominator.
3100 Otherwise, the base must be 2 and we scale the value, which
3101 we know can fit in the mantissa of the type (hence the use
3102 of that type above). */
3103 if (No (Rbase (ur_realval)))
3105 = build_binary_op (RDIV_EXPR,
3106 get_base_type (gnu_result_type),
3108 UI_To_gnu (Denominator (ur_realval),
3112 REAL_VALUE_TYPE tmp;
3114 gcc_assert (Rbase (ur_realval) == 2);
3115 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
3116 - UI_To_Int (Denominator (ur_realval)));
3117 gnu_result = build_real (gnu_result_type, tmp);
3121 /* Now see if we need to negate the result. Do it this way to
3122 properly handle -0. */
3123 if (UR_Is_Negative (Realval (gnat_node)))
3125 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
3131 case N_String_Literal:
3132 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3133 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
3135 String_Id gnat_string = Strval (gnat_node);
3136 int length = String_Length (gnat_string);
3139 if (length >= ALLOCA_THRESHOLD)
3140 string = xmalloc (length + 1); /* in case of large strings */
3142 string = (char *) alloca (length + 1);
3144 /* Build the string with the characters in the literal. Note
3145 that Ada strings are 1-origin. */
3146 for (i = 0; i < length; i++)
3147 string[i] = Get_String_Char (gnat_string, i + 1);
3149 /* Put a null at the end of the string in case it's in a context
3150 where GCC will want to treat it as a C string. */
3153 gnu_result = build_string (length, string);
3155 /* Strings in GCC don't normally have types, but we want
3156 this to not be converted to the array type. */
3157 TREE_TYPE (gnu_result) = gnu_result_type;
3159 if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */
3164 /* Build a list consisting of each character, then make
3166 String_Id gnat_string = Strval (gnat_node);
3167 int length = String_Length (gnat_string);
3169 tree gnu_list = NULL_TREE;
3170 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
3172 for (i = 0; i < length; i++)
3175 = tree_cons (gnu_idx,
3176 build_int_cst (TREE_TYPE (gnu_result_type),
3177 Get_String_Char (gnat_string,
3181 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
3186 = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
3191 gnu_result = Pragma_to_gnu (gnat_node);
3194 /**************************************/
3195 /* Chapter 3: Declarations and Types: */
3196 /**************************************/
3198 case N_Subtype_Declaration:
3199 case N_Full_Type_Declaration:
3200 case N_Incomplete_Type_Declaration:
3201 case N_Private_Type_Declaration:
3202 case N_Private_Extension_Declaration:
3203 case N_Task_Type_Declaration:
3204 process_type (Defining_Entity (gnat_node));
3205 gnu_result = alloc_stmt_list ();
3208 case N_Object_Declaration:
3209 case N_Exception_Declaration:
3210 gnat_temp = Defining_Entity (gnat_node);
3211 gnu_result = alloc_stmt_list ();
3213 /* If we are just annotating types and this object has an unconstrained
3214 or task type, don't elaborate it. */
3215 if (type_annotate_only
3216 && (((Is_Array_Type (Etype (gnat_temp))
3217 || Is_Record_Type (Etype (gnat_temp)))
3218 && !Is_Constrained (Etype (gnat_temp)))
3219 || Is_Concurrent_Type (Etype (gnat_temp))))
3222 if (Present (Expression (gnat_node))
3223 && !(Nkind (gnat_node) == N_Object_Declaration
3224 && No_Initialization (gnat_node))
3225 && (!type_annotate_only
3226 || Compile_Time_Known_Value (Expression (gnat_node))))
3228 gnu_expr = gnat_to_gnu (Expression (gnat_node));
3229 if (Do_Range_Check (Expression (gnat_node)))
3230 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
3232 /* If this object has its elaboration delayed, we must force
3233 evaluation of GNU_EXPR right now and save it for when the object
3235 if (Present (Freeze_Node (gnat_temp)))
3237 if ((Is_Public (gnat_temp) || global_bindings_p ())
3238 && !TREE_CONSTANT (gnu_expr))
3240 = create_var_decl (create_concat_name (gnat_temp, "init"),
3241 NULL_TREE, TREE_TYPE (gnu_expr),
3242 gnu_expr, false, Is_Public (gnat_temp),
3243 false, false, NULL, gnat_temp);
3245 gnu_expr = maybe_variable (gnu_expr);
3247 save_gnu_tree (gnat_node, gnu_expr, true);
3251 gnu_expr = NULL_TREE;
3253 if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
3254 gnu_expr = NULL_TREE;
3256 if (No (Freeze_Node (gnat_temp)))
3257 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
3260 case N_Object_Renaming_Declaration:
3261 gnat_temp = Defining_Entity (gnat_node);
3263 /* Don't do anything if this renaming is handled by the front end or if
3264 we are just annotating types and this object has a composite or task
3265 type, don't elaborate it. We return the result in case it has any
3266 SAVE_EXPRs in it that need to be evaluated here. */
3267 if (!Is_Renaming_Of_Object (gnat_temp)
3268 && ! (type_annotate_only
3269 && (Is_Array_Type (Etype (gnat_temp))
3270 || Is_Record_Type (Etype (gnat_temp))
3271 || Is_Concurrent_Type (Etype (gnat_temp)))))
3273 = gnat_to_gnu_entity (gnat_temp,
3274 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
3276 gnu_result = alloc_stmt_list ();
3279 case N_Implicit_Label_Declaration:
3280 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3281 gnu_result = alloc_stmt_list ();
3284 case N_Exception_Renaming_Declaration:
3285 case N_Number_Declaration:
3286 case N_Package_Renaming_Declaration:
3287 case N_Subprogram_Renaming_Declaration:
3288 /* These are fully handled in the front end. */
3289 gnu_result = alloc_stmt_list ();
3292 /*************************************/
3293 /* Chapter 4: Names and Expressions: */
3294 /*************************************/
3296 case N_Explicit_Dereference:
3297 gnu_result = gnat_to_gnu (Prefix (gnat_node));
3298 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3299 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
3302 case N_Indexed_Component:
3304 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
3308 Node_Id *gnat_expr_array;
3310 gnu_array_object = maybe_implicit_deref (gnu_array_object);
3311 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
3313 /* If we got a padded type, remove it too. */
3314 if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
3315 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
3317 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
3320 gnu_result = gnu_array_object;
3322 /* First compute the number of dimensions of the array, then
3323 fill the expression array, the order depending on whether
3324 this is a Convention_Fortran array or not. */
3325 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
3326 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
3327 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
3328 ndim++, gnu_type = TREE_TYPE (gnu_type))
3331 gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
3333 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
3334 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
3336 i--, gnat_temp = Next (gnat_temp))
3337 gnat_expr_array[i] = gnat_temp;
3339 for (i = 0, gnat_temp = First (Expressions (gnat_node));
3341 i++, gnat_temp = Next (gnat_temp))
3342 gnat_expr_array[i] = gnat_temp;
3344 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
3345 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
3347 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
3348 gnat_temp = gnat_expr_array[i];
3349 gnu_expr = gnat_to_gnu (gnat_temp);
3351 if (Do_Range_Check (gnat_temp))
3354 (gnu_array_object, gnu_expr,
3355 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
3356 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
3358 gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
3359 gnu_result, gnu_expr);
3363 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3369 Node_Id gnat_range_node = Discrete_Range (gnat_node);
3371 gnu_result = gnat_to_gnu (Prefix (gnat_node));
3372 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3374 /* Do any implicit dereferences of the prefix and do any needed
3376 gnu_result = maybe_implicit_deref (gnu_result);
3377 gnu_result = maybe_unconstrained_array (gnu_result);
3378 gnu_type = TREE_TYPE (gnu_result);
3379 if (Do_Range_Check (gnat_range_node))
3381 /* Get the bounds of the slice. */
3383 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
3384 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
3385 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
3386 /* Get the permitted bounds. */
3387 tree gnu_base_index_type
3388 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
3389 tree gnu_base_min_expr = TYPE_MIN_VALUE (gnu_base_index_type);
3390 tree gnu_base_max_expr = TYPE_MAX_VALUE (gnu_base_index_type);
3391 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
3393 /* Check to see that the minimum slice value is in range. */
3394 gnu_expr_l = emit_index_check (gnu_result,
3399 /* Check to see that the maximum slice value is in range. */
3400 gnu_expr_h = emit_index_check (gnu_result,
3405 /* Derive a good type to convert everything to. */
3406 gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
3408 /* Build a compound expression that does the range checks and
3409 returns the low bound. */
3410 gnu_expr = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
3411 convert (gnu_expr_type, gnu_expr_h),
3412 convert (gnu_expr_type, gnu_expr_l));
3414 /* Build a conditional expression that does the range check and
3415 returns the low bound if the slice is not empty (max >= min),
3416 and returns the naked low bound otherwise (max < min), unless
3417 it is non-constant and the high bound is; this prevents VRP
3418 from inferring bogus ranges on the unlikely path. */
3419 gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type,
3420 build_binary_op (GE_EXPR, gnu_expr_type,
3421 convert (gnu_expr_type,
3423 convert (gnu_expr_type,
3426 TREE_CODE (gnu_min_expr) != INTEGER_CST
3427 && TREE_CODE (gnu_max_expr) == INTEGER_CST
3428 ? gnu_max_expr : gnu_min_expr);
3431 /* Simply return the naked low bound. */
3432 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
3434 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
3435 gnu_result, gnu_expr);
3439 case N_Selected_Component:
3441 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
3442 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
3443 Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
3446 while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
3447 || IN (Ekind (gnat_pref_type), Access_Kind))
3449 if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
3450 gnat_pref_type = Underlying_Type (gnat_pref_type);
3451 else if (IN (Ekind (gnat_pref_type), Access_Kind))
3452 gnat_pref_type = Designated_Type (gnat_pref_type);
3455 gnu_prefix = maybe_implicit_deref (gnu_prefix);
3457 /* For discriminant references in tagged types always substitute the
3458 corresponding discriminant as the actual selected component. */
3460 if (Is_Tagged_Type (gnat_pref_type))
3461 while (Present (Corresponding_Discriminant (gnat_field)))
3462 gnat_field = Corresponding_Discriminant (gnat_field);
3464 /* For discriminant references of untagged types always substitute the
3465 corresponding stored discriminant. */
3467 else if (Present (Corresponding_Discriminant (gnat_field)))
3468 gnat_field = Original_Record_Component (gnat_field);
3470 /* Handle extracting the real or imaginary part of a complex.
3471 The real part is the first field and the imaginary the last. */
3473 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
3474 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
3475 ? REALPART_EXPR : IMAGPART_EXPR,
3476 NULL_TREE, gnu_prefix);
3479 gnu_field = gnat_to_gnu_field_decl (gnat_field);
3481 /* If there are discriminants, the prefix might be
3482 evaluated more than once, which is a problem if it has
3484 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
3485 ? Designated_Type (Etype
3486 (Prefix (gnat_node)))
3487 : Etype (Prefix (gnat_node))))
3488 gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
3491 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
3492 (Nkind (Parent (gnat_node))
3493 == N_Attribute_Reference));
3496 gcc_assert (gnu_result);
3497 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3501 case N_Attribute_Reference:
3503 /* The attribute designator (like an enumeration value). */
3504 int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
3506 /* The Elab_Spec and Elab_Body attributes are special in that
3507 Prefix is a unit, not an object with a GCC equivalent. Similarly
3508 for Elaborated, since that variable isn't otherwise known. */
3509 if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
3510 return (create_subprog_decl
3511 (create_concat_name (Entity (Prefix (gnat_node)),
3512 attribute == Attr_Elab_Body
3513 ? "elabb" : "elabs"),
3514 NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
3517 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
3522 /* Like 'Access as far as we are concerned. */
3523 gnu_result = gnat_to_gnu (Prefix (gnat_node));
3524 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
3525 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3529 case N_Extension_Aggregate:
3533 /* ??? It is wrong to evaluate the type now, but there doesn't
3534 seem to be any other practical way of doing it. */
3536 gcc_assert (!Expansion_Delayed (gnat_node));
3538 gnu_aggr_type = gnu_result_type
3539 = get_unpadded_type (Etype (gnat_node));
3541 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
3542 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
3544 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
3546 if (Null_Record_Present (gnat_node))
3547 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
3549 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
3550 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
3552 = assoc_to_constructor (Etype (gnat_node),
3553 First (Component_Associations (gnat_node)),
3555 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
3556 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
3558 Component_Type (Etype (gnat_node)));
3559 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
3562 (COMPLEX_EXPR, gnu_aggr_type,
3563 gnat_to_gnu (Expression (First
3564 (Component_Associations (gnat_node)))),
3565 gnat_to_gnu (Expression
3567 (First (Component_Associations (gnat_node))))));
3571 gnu_result = convert (gnu_result_type, gnu_result);
3576 gnu_result = null_pointer_node;
3577 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3580 case N_Type_Conversion:
3581 case N_Qualified_Expression:
3582 /* Get the operand expression. */
3583 gnu_result = gnat_to_gnu (Expression (gnat_node));
3584 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3587 = convert_with_check (Etype (gnat_node), gnu_result,
3588 Do_Overflow_Check (gnat_node),
3589 Do_Range_Check (Expression (gnat_node)),
3590 Nkind (gnat_node) == N_Type_Conversion
3591 && Float_Truncate (gnat_node));
3594 case N_Unchecked_Type_Conversion:
3595 gnu_result = gnat_to_gnu (Expression (gnat_node));
3596 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3598 /* If the result is a pointer type, see if we are improperly
3599 converting to a stricter alignment. */
3601 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
3602 && IN (Ekind (Etype (gnat_node)), Access_Kind))
3604 unsigned int align = known_alignment (gnu_result);
3605 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
3606 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
3608 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
3609 post_error_ne_tree_2
3610 ("?source alignment (^) '< alignment of & (^)",
3611 gnat_node, Designated_Type (Etype (gnat_node)),
3612 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
3615 gnu_result = unchecked_convert (gnu_result_type, gnu_result,
3616 No_Truncation (gnat_node));
3622 tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
3623 Node_Id gnat_range = Right_Opnd (gnat_node);
3627 /* GNAT_RANGE is either an N_Range node or an identifier
3628 denoting a subtype. */
3629 if (Nkind (gnat_range) == N_Range)
3631 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
3632 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
3634 else if (Nkind (gnat_range) == N_Identifier
3635 || Nkind (gnat_range) == N_Expanded_Name)
3637 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
3639 gnu_low = TYPE_MIN_VALUE (gnu_range_type);
3640 gnu_high = TYPE_MAX_VALUE (gnu_range_type);
3645 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3647 /* If LOW and HIGH are identical, perform an equality test.
3648 Otherwise, ensure that GNU_OBJECT is only evaluated once
3649 and perform a full range test. */
3650 if (operand_equal_p (gnu_low, gnu_high, 0))
3651 gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
3652 gnu_object, gnu_low);
3655 gnu_object = protect_multiple_eval (gnu_object);
3657 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
3658 build_binary_op (GE_EXPR, gnu_result_type,
3659 gnu_object, gnu_low),
3660 build_binary_op (LE_EXPR, gnu_result_type,
3661 gnu_object, gnu_high));
3664 if (Nkind (gnat_node) == N_Not_In)
3665 gnu_result = invert_truthvalue (gnu_result);
3670 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3671 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3672 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3673 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
3675 : (Rounded_Result (gnat_node)
3676 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
3677 gnu_result_type, gnu_lhs, gnu_rhs);
3680 case N_Op_Or: case N_Op_And: case N_Op_Xor:
3681 /* These can either be operations on booleans or on modular types.
3682 Fall through for boolean types since that's the way GNU_CODES is
3684 if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
3685 Modular_Integer_Kind))
3688 = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
3689 : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
3692 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3693 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3694 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3695 gnu_result = build_binary_op (code, gnu_result_type,
3700 /* ... fall through ... */
3702 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
3703 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
3704 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
3705 case N_Op_Mod: case N_Op_Rem:
3706 case N_Op_Rotate_Left:
3707 case N_Op_Rotate_Right:
3708 case N_Op_Shift_Left:
3709 case N_Op_Shift_Right:
3710 case N_Op_Shift_Right_Arithmetic:
3711 case N_And_Then: case N_Or_Else:
3713 enum tree_code code = gnu_codes[Nkind (gnat_node)];
3714 bool ignore_lhs_overflow = false;
3717 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3718 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3719 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3721 /* If this is a comparison operator, convert any references to
3722 an unconstrained array value into a reference to the
3724 if (TREE_CODE_CLASS (code) == tcc_comparison)
3726 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
3727 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
3730 /* If the result type is a private type, its full view may be a
3731 numeric subtype. The representation we need is that of its base
3732 type, given that it is the result of an arithmetic operation. */
3733 else if (Is_Private_Type (Etype (gnat_node)))
3734 gnu_type = gnu_result_type
3735 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
3737 /* If this is a shift whose count is not guaranteed to be correct,
3738 we need to adjust the shift count. */
3739 if (IN (Nkind (gnat_node), N_Op_Shift)
3740 && !Shift_Count_OK (gnat_node))
3742 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
3744 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
3746 if (Nkind (gnat_node) == N_Op_Rotate_Left
3747 || Nkind (gnat_node) == N_Op_Rotate_Right)
3748 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
3749 gnu_rhs, gnu_max_shift);
3750 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
3753 (MIN_EXPR, gnu_count_type,
3754 build_binary_op (MINUS_EXPR,
3757 convert (gnu_count_type,
3762 /* For right shifts, the type says what kind of shift to do,
3763 so we may need to choose a different type. In this case,
3764 we have to ignore integer overflow lest it propagates all
3765 the way down and causes a CE to be explicitly raised. */
3766 if (Nkind (gnat_node) == N_Op_Shift_Right
3767 && !TYPE_UNSIGNED (gnu_type))
3769 gnu_type = gnat_unsigned_type (gnu_type);
3770 ignore_lhs_overflow = true;
3772 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
3773 && TYPE_UNSIGNED (gnu_type))
3775 gnu_type = gnat_signed_type (gnu_type);
3776 ignore_lhs_overflow = true;
3779 if (gnu_type != gnu_result_type)
3781 tree gnu_old_lhs = gnu_lhs;
3782 gnu_lhs = convert (gnu_type, gnu_lhs);
3783 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
3784 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
3785 gnu_rhs = convert (gnu_type, gnu_rhs);
3788 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
3790 /* If this is a logical shift with the shift count not verified,
3791 we must return zero if it is too large. We cannot compensate
3792 above in this case. */
3793 if ((Nkind (gnat_node) == N_Op_Shift_Left
3794 || Nkind (gnat_node) == N_Op_Shift_Right)
3795 && !Shift_Count_OK (gnat_node))
3799 build_binary_op (GE_EXPR, integer_type_node,
3801 convert (TREE_TYPE (gnu_rhs),
3802 TYPE_SIZE (gnu_type))),
3803 convert (gnu_type, integer_zero_node),
3808 case N_Conditional_Expression:
3810 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
3811 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
3813 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
3815 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3816 gnu_result = build_cond_expr (gnu_result_type,
3817 gnat_truthvalue_conversion (gnu_cond),
3818 gnu_true, gnu_false);
3823 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
3824 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3828 /* This case can apply to a boolean or a modular type.
3829 Fall through for a boolean operand since GNU_CODES is set
3830 up to handle this. */
3831 if (Is_Modular_Integer_Type (Etype (gnat_node))
3832 || (Ekind (Etype (gnat_node)) == E_Private_Type
3833 && Is_Modular_Integer_Type (Full_View (Etype (gnat_node)))))
3835 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3836 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3837 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
3842 /* ... fall through ... */
3844 case N_Op_Minus: case N_Op_Abs:
3845 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3847 if (Ekind (Etype (gnat_node)) != E_Private_Type)
3848 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3850 gnu_result_type = get_unpadded_type (Base_Type
3851 (Full_View (Etype (gnat_node))));
3853 gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
3854 gnu_result_type, gnu_expr);
3861 bool ignore_init_type = false;
3863 gnat_temp = Expression (gnat_node);
3865 /* The Expression operand can either be an N_Identifier or
3866 Expanded_Name, which must represent a type, or a
3867 N_Qualified_Expression, which contains both the object type and an
3868 initial value for the object. */
3869 if (Nkind (gnat_temp) == N_Identifier
3870 || Nkind (gnat_temp) == N_Expanded_Name)
3871 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
3872 else if (Nkind (gnat_temp) == N_Qualified_Expression)
3874 Entity_Id gnat_desig_type
3875 = Designated_Type (Underlying_Type (Etype (gnat_node)));
3877 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
3878 gnu_init = gnat_to_gnu (Expression (gnat_temp));
3880 gnu_init = maybe_unconstrained_array (gnu_init);
3881 if (Do_Range_Check (Expression (gnat_temp)))
3882 gnu_init = emit_range_check (gnu_init, gnat_desig_type);
3884 if (Is_Elementary_Type (gnat_desig_type)
3885 || Is_Constrained (gnat_desig_type))
3887 gnu_type = gnat_to_gnu_type (gnat_desig_type);
3888 gnu_init = convert (gnu_type, gnu_init);
3892 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
3893 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
3894 gnu_type = TREE_TYPE (gnu_init);
3896 gnu_init = convert (gnu_type, gnu_init);
3902 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3903 return build_allocator (gnu_type, gnu_init, gnu_result_type,
3904 Procedure_To_Call (gnat_node),
3905 Storage_Pool (gnat_node), gnat_node,
3910 /***************************/
3911 /* Chapter 5: Statements: */
3912 /***************************/
3915 gnu_result = build1 (LABEL_EXPR, void_type_node,
3916 gnat_to_gnu (Identifier (gnat_node)));
3919 case N_Null_Statement:
3920 gnu_result = alloc_stmt_list ();
3923 case N_Assignment_Statement:
3924 /* Get the LHS and RHS of the statement and convert any reference to an
3925 unconstrained array into a reference to the underlying array.
3926 If we are not to do range checking and the RHS is an N_Function_Call,
3927 pass the LHS to the call function. */
3928 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
3930 /* If the type has a size that overflows, convert this into raise of
3931 Storage_Error: execution shouldn't have gotten here anyway. */
3932 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
3933 && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
3934 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
3935 N_Raise_Storage_Error);
3936 else if (Nkind (Expression (gnat_node)) == N_Function_Call
3937 && !Do_Range_Check (Expression (gnat_node)))
3938 gnu_result = call_to_gnu (Expression (gnat_node),
3939 &gnu_result_type, gnu_lhs);
3943 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
3945 /* If range check is needed, emit code to generate it */
3946 if (Do_Range_Check (Expression (gnat_node)))
3947 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
3950 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
3954 case N_If_Statement:
3956 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
3958 /* Make the outer COND_EXPR. Avoid non-determinism. */
3959 gnu_result = build3 (COND_EXPR, void_type_node,
3960 gnat_to_gnu (Condition (gnat_node)),
3961 NULL_TREE, NULL_TREE);
3962 COND_EXPR_THEN (gnu_result)
3963 = build_stmt_group (Then_Statements (gnat_node), false);
3964 TREE_SIDE_EFFECTS (gnu_result) = 1;
3965 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
3967 /* Now make a COND_EXPR for each of the "else if" parts. Put each
3968 into the previous "else" part and point to where to put any
3969 outer "else". Also avoid non-determinism. */
3970 if (Present (Elsif_Parts (gnat_node)))
3971 for (gnat_temp = First (Elsif_Parts (gnat_node));
3972 Present (gnat_temp); gnat_temp = Next (gnat_temp))
3974 gnu_expr = build3 (COND_EXPR, void_type_node,
3975 gnat_to_gnu (Condition (gnat_temp)),
3976 NULL_TREE, NULL_TREE);
3977 COND_EXPR_THEN (gnu_expr)
3978 = build_stmt_group (Then_Statements (gnat_temp), false);
3979 TREE_SIDE_EFFECTS (gnu_expr) = 1;
3980 annotate_with_node (gnu_expr, gnat_temp);
3981 *gnu_else_ptr = gnu_expr;
3982 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3985 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
3989 case N_Case_Statement:
3990 gnu_result = Case_Statement_to_gnu (gnat_node);
3993 case N_Loop_Statement:
3994 gnu_result = Loop_Statement_to_gnu (gnat_node);
3997 case N_Block_Statement:
3998 start_stmt_group ();
4000 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
4001 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
4003 gnu_result = end_stmt_group ();
4005 if (Present (Identifier (gnat_node)))
4006 mark_out_of_scope (Entity (Identifier (gnat_node)));
4009 case N_Exit_Statement:
4011 = build2 (EXIT_STMT, void_type_node,
4012 (Present (Condition (gnat_node))
4013 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
4014 (Present (Name (gnat_node))
4015 ? get_gnu_tree (Entity (Name (gnat_node)))
4016 : TREE_VALUE (gnu_loop_label_stack)));
4019 case N_Return_Statement:
4021 /* The gnu function type of the subprogram currently processed. */
4022 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
4023 /* The return value from the subprogram. */
4024 tree gnu_ret_val = NULL_TREE;
4025 /* The place to put the return value. */
4028 /* If we are dealing with a "return;" from an Ada procedure with
4029 parameters passed by copy in copy out, we need to return a record
4030 containing the final values of these parameters. If the list
4031 contains only one entry, return just that entry.
4033 For a full description of the copy in copy out parameter mechanism,
4034 see the part of the gnat_to_gnu_entity routine dealing with the
4035 translation of subprograms.
4037 But if we have a return label defined, convert this into
4038 a branch to that label. */
4040 if (TREE_VALUE (gnu_return_label_stack))
4042 gnu_result = build1 (GOTO_EXPR, void_type_node,
4043 TREE_VALUE (gnu_return_label_stack));
4047 else if (TYPE_CI_CO_LIST (gnu_subprog_type))
4049 gnu_lhs = DECL_RESULT (current_function_decl);
4050 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
4051 gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
4054 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
4055 TYPE_CI_CO_LIST (gnu_subprog_type));
4058 /* If the Ada subprogram is a function, we just need to return the
4059 expression. If the subprogram returns an unconstrained
4060 array, we have to allocate a new version of the result and
4061 return it. If we return by reference, return a pointer. */
4063 else if (Present (Expression (gnat_node)))
4065 /* If the current function returns by target pointer and we
4066 are doing a call, pass that target to the call. */
4067 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
4068 && Nkind (Expression (gnat_node)) == N_Function_Call)
4071 = build_unary_op (INDIRECT_REF, NULL_TREE,
4072 DECL_ARGUMENTS (current_function_decl));
4073 gnu_result = call_to_gnu (Expression (gnat_node),
4074 &gnu_result_type, gnu_lhs);
4078 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
4080 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
4081 /* The original return type was unconstrained so dereference
4082 the TARGET pointer in the actual return value's type. */
4084 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
4085 DECL_ARGUMENTS (current_function_decl));
4087 gnu_lhs = DECL_RESULT (current_function_decl);
4089 /* Do not remove the padding from GNU_RET_VAL if the inner
4090 type is self-referential since we want to allocate the fixed
4091 size in that case. */
4092 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
4093 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
4095 && (TYPE_IS_PADDING_P
4096 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
4097 && (CONTAINS_PLACEHOLDER_P
4098 (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
4099 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
4101 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
4102 || By_Ref (gnat_node))
4104 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
4106 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
4108 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
4110 /* We have two cases: either the function returns with
4111 depressed stack or not. If not, we allocate on the
4112 secondary stack. If so, we allocate in the stack frame.
4113 if no copy is needed, the front end will set By_Ref,
4114 which we handle in the case above. */
4115 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
4117 = build_allocator (TREE_TYPE (gnu_ret_val),
4119 TREE_TYPE (gnu_subprog_type),
4120 0, -1, gnat_node, false);
4123 = build_allocator (TREE_TYPE (gnu_ret_val),
4125 TREE_TYPE (gnu_subprog_type),
4126 Procedure_To_Call (gnat_node),
4127 Storage_Pool (gnat_node),
4133 /* If the Ada subprogram is a regular procedure, just return. */
4134 gnu_lhs = NULL_TREE;
4136 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
4139 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
4140 gnu_lhs, gnu_ret_val);
4141 add_stmt_with_node (gnu_result, gnat_node);
4142 gnu_lhs = NULL_TREE;
4145 gnu_result = build_return_expr (gnu_lhs, gnu_ret_val);
4149 case N_Goto_Statement:
4150 gnu_result = build1 (GOTO_EXPR, void_type_node,
4151 gnat_to_gnu (Name (gnat_node)));
4154 /****************************/
4155 /* Chapter 6: Subprograms: */
4156 /****************************/
4158 case N_Subprogram_Declaration:
4159 /* Unless there is a freeze node, declare the subprogram. We consider
4160 this a "definition" even though we're not generating code for
4161 the subprogram because we will be making the corresponding GCC
4164 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
4165 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
4167 gnu_result = alloc_stmt_list ();
4170 case N_Abstract_Subprogram_Declaration:
4171 /* This subprogram doesn't exist for code generation purposes, but we
4172 have to elaborate the types of any parameters and result, unless
4173 they are imported types (nothing to generate in this case). */
4175 /* Process the parameter types first. */
4178 = First_Formal_With_Extras
4179 (Defining_Entity (Specification (gnat_node)));
4180 Present (gnat_temp);
4181 gnat_temp = Next_Formal_With_Extras (gnat_temp))
4182 if (Is_Itype (Etype (gnat_temp))
4183 && !From_With_Type (Etype (gnat_temp)))
4184 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
4187 /* Then the result type, set to Standard_Void_Type for procedures. */
4190 Entity_Id gnat_temp_type
4191 = Etype (Defining_Entity (Specification (gnat_node)));
4193 if (Is_Itype (gnat_temp_type) && !From_With_Type (gnat_temp_type))
4194 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
4197 gnu_result = alloc_stmt_list ();
4200 case N_Defining_Program_Unit_Name:
4201 /* For a child unit identifier go up a level to get the
4202 specification. We get this when we try to find the spec of
4203 a child unit package that is the compilation unit being compiled. */
4204 gnu_result = gnat_to_gnu (Parent (gnat_node));
4207 case N_Subprogram_Body:
4208 Subprogram_Body_to_gnu (gnat_node);
4209 gnu_result = alloc_stmt_list ();
4212 case N_Function_Call:
4213 case N_Procedure_Call_Statement:
4214 gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
4217 /*************************/
4218 /* Chapter 7: Packages: */
4219 /*************************/
4221 case N_Package_Declaration:
4222 gnu_result = gnat_to_gnu (Specification (gnat_node));
4225 case N_Package_Specification:
4227 start_stmt_group ();
4228 process_decls (Visible_Declarations (gnat_node),
4229 Private_Declarations (gnat_node), Empty, true, true);
4230 gnu_result = end_stmt_group ();
4233 case N_Package_Body:
4235 /* If this is the body of a generic package - do nothing */
4236 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
4238 gnu_result = alloc_stmt_list ();
4242 start_stmt_group ();
4243 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
4245 if (Present (Handled_Statement_Sequence (gnat_node)))
4246 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
4248 gnu_result = end_stmt_group ();
4251 /*********************************/
4252 /* Chapter 8: Visibility Rules: */
4253 /*********************************/
4255 case N_Use_Package_Clause:
4256 case N_Use_Type_Clause:
4257 /* Nothing to do here - but these may appear in list of declarations */
4258 gnu_result = alloc_stmt_list ();
4261 /***********************/
4262 /* Chapter 9: Tasks: */
4263 /***********************/
4265 case N_Protected_Type_Declaration:
4266 gnu_result = alloc_stmt_list ();
4269 case N_Single_Task_Declaration:
4270 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
4271 gnu_result = alloc_stmt_list ();
4274 /***********************************************************/
4275 /* Chapter 10: Program Structure and Compilation Issues: */
4276 /***********************************************************/
4278 case N_Compilation_Unit:
4280 /* This is not called for the main unit, which is handled in function
4282 start_stmt_group ();
4285 Compilation_Unit_to_gnu (gnat_node);
4286 gnu_result = alloc_stmt_list ();
4289 case N_Subprogram_Body_Stub:
4290 case N_Package_Body_Stub:
4291 case N_Protected_Body_Stub:
4292 case N_Task_Body_Stub:
4293 /* Simply process whatever unit is being inserted. */
4294 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
4298 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
4301 /***************************/
4302 /* Chapter 11: Exceptions: */
4303 /***************************/
4305 case N_Handled_Sequence_Of_Statements:
4306 /* If there is an At_End procedure attached to this node, and the EH
4307 mechanism is SJLJ, we must have at least a corresponding At_End
4308 handler, unless the No_Exception_Handlers restriction is set. */
4309 gcc_assert (type_annotate_only
4310 || Exception_Mechanism != Setjmp_Longjmp
4311 || No (At_End_Proc (gnat_node))
4312 || Present (Exception_Handlers (gnat_node))
4313 || No_Exception_Handlers_Set ());
4315 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
4318 case N_Exception_Handler:
4319 if (Exception_Mechanism == Setjmp_Longjmp)
4320 gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
4321 else if (Exception_Mechanism == Back_End_Exceptions)
4322 gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
4328 case N_Push_Constraint_Error_Label:
4329 push_exception_label_stack (&gnu_constraint_error_label_stack,
4330 Exception_Label (gnat_node));
4333 case N_Push_Storage_Error_Label:
4334 push_exception_label_stack (&gnu_storage_error_label_stack,
4335 Exception_Label (gnat_node));
4338 case N_Push_Program_Error_Label:
4339 push_exception_label_stack (&gnu_program_error_label_stack,
4340 Exception_Label (gnat_node));
4343 case N_Pop_Constraint_Error_Label:
4344 gnu_constraint_error_label_stack
4345 = TREE_CHAIN (gnu_constraint_error_label_stack);
4348 case N_Pop_Storage_Error_Label:
4349 gnu_storage_error_label_stack
4350 = TREE_CHAIN (gnu_storage_error_label_stack);
4353 case N_Pop_Program_Error_Label:
4354 gnu_program_error_label_stack
4355 = TREE_CHAIN (gnu_program_error_label_stack);
4358 /*******************************/
4359 /* Chapter 12: Generic Units: */
4360 /*******************************/
4362 case N_Generic_Function_Renaming_Declaration:
4363 case N_Generic_Package_Renaming_Declaration:
4364 case N_Generic_Procedure_Renaming_Declaration:
4365 case N_Generic_Package_Declaration:
4366 case N_Generic_Subprogram_Declaration:
4367 case N_Package_Instantiation:
4368 case N_Procedure_Instantiation:
4369 case N_Function_Instantiation:
4370 /* These nodes can appear on a declaration list but there is nothing to
4371 to be done with them. */
4372 gnu_result = alloc_stmt_list ();
4375 /***************************************************/
4376 /* Chapter 13: Representation Clauses and */
4377 /* Implementation-Dependent Features: */
4378 /***************************************************/
4380 case N_Attribute_Definition_Clause:
4382 gnu_result = alloc_stmt_list ();
4384 /* The only one we need deal with is for 'Address. For the others, SEM
4385 puts the information elsewhere. We need only deal with 'Address
4386 if the object has a Freeze_Node (which it never will currently). */
4387 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
4388 || No (Freeze_Node (Entity (Name (gnat_node)))))
4391 /* Get the value to use as the address and save it as the
4392 equivalent for GNAT_TEMP. When the object is frozen,
4393 gnat_to_gnu_entity will do the right thing. */
4394 save_gnu_tree (Entity (Name (gnat_node)),
4395 gnat_to_gnu (Expression (gnat_node)), true);
4398 case N_Enumeration_Representation_Clause:
4399 case N_Record_Representation_Clause:
4401 /* We do nothing with these. SEM puts the information elsewhere. */
4402 gnu_result = alloc_stmt_list ();
4405 case N_Code_Statement:
4406 if (!type_annotate_only)
4408 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
4409 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
4410 tree gnu_clobbers = NULL_TREE, tail;
4411 bool allows_mem, allows_reg, fake;
4412 int ninputs, noutputs, i;
4413 const char **oconstraints;
4414 const char *constraint;
4417 /* First retrieve the 3 operand lists built by the front-end. */
4418 Setup_Asm_Outputs (gnat_node);
4419 while (Present (gnat_temp = Asm_Output_Variable ()))
4421 tree gnu_value = gnat_to_gnu (gnat_temp);
4422 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
4423 (Asm_Output_Constraint ()));
4425 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
4429 Setup_Asm_Inputs (gnat_node);
4430 while (Present (gnat_temp = Asm_Input_Value ()))
4432 tree gnu_value = gnat_to_gnu (gnat_temp);
4433 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
4434 (Asm_Input_Constraint ()));
4436 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
4440 Clobber_Setup (gnat_node);
4441 while ((clobber = Clobber_Get_Next ()))
4443 = tree_cons (NULL_TREE,
4444 build_string (strlen (clobber) + 1, clobber),
4447 /* Then perform some standard checking and processing on the
4448 operands. In particular, mark them addressable if needed. */
4449 gnu_outputs = nreverse (gnu_outputs);
4450 noutputs = list_length (gnu_outputs);
4451 gnu_inputs = nreverse (gnu_inputs);
4452 ninputs = list_length (gnu_inputs);
4454 = (const char **) alloca (noutputs * sizeof (const char *));
4456 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
4458 tree output = TREE_VALUE (tail);
4460 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
4461 oconstraints[i] = constraint;
4463 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
4464 &allows_mem, &allows_reg, &fake))
4466 /* If the operand is going to end up in memory,
4467 mark it addressable. Note that we don't test
4468 allows_mem like in the input case below; this
4469 is modelled on the C front-end. */
4471 && !gnat_mark_addressable (output))
4472 output = error_mark_node;
4475 output = error_mark_node;
4477 TREE_VALUE (tail) = output;
4480 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
4482 tree input = TREE_VALUE (tail);
4484 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
4486 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
4488 &allows_mem, &allows_reg))
4490 /* If the operand is going to end up in memory,
4491 mark it addressable. */
4492 if (!allows_reg && allows_mem
4493 && !gnat_mark_addressable (input))
4494 input = error_mark_node;
4497 input = error_mark_node;
4499 TREE_VALUE (tail) = input;
4502 gnu_result = build4 (ASM_EXPR, void_type_node,
4503 gnu_template, gnu_outputs,
4504 gnu_inputs, gnu_clobbers);
4505 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
4508 gnu_result = alloc_stmt_list ();
4512 /***************************************************/
4514 /***************************************************/
4516 case N_Freeze_Entity:
4517 start_stmt_group ();
4518 process_freeze_entity (gnat_node);
4519 process_decls (Actions (gnat_node), Empty, Empty, true, true);
4520 gnu_result = end_stmt_group ();
4523 case N_Itype_Reference:
4524 if (!present_gnu_tree (Itype (gnat_node)))
4525 process_type (Itype (gnat_node));
4527 gnu_result = alloc_stmt_list ();
4530 case N_Free_Statement:
4531 if (!type_annotate_only)
4533 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
4534 tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
4536 tree gnu_actual_obj_type = 0;
4540 /* If this is a thin pointer, we must dereference it to create
4541 a fat pointer, then go back below to a thin pointer. The
4542 reason for this is that we need a fat pointer someplace in
4543 order to properly compute the size. */
4544 if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
4545 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
4546 build_unary_op (INDIRECT_REF, NULL_TREE,
4549 /* If this is an unconstrained array, we know the object must
4550 have been allocated with the template in front of the object.
4551 So pass the template address, but get the total size. Do this
4552 by converting to a thin pointer. */
4553 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
4555 = convert (build_pointer_type
4556 (TYPE_OBJECT_RECORD_TYPE
4557 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
4560 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
4562 if (Present (Actual_Designated_Subtype (gnat_node)))
4565 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
4567 if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
4569 = build_unc_object_type_from_ptr (gnu_ptr_type,
4570 gnu_actual_obj_type,
4571 get_identifier ("DEALLOC"));
4574 gnu_actual_obj_type = gnu_obj_type;
4576 gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
4577 align = TYPE_ALIGN (gnu_obj_type);
4579 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
4580 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
4582 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
4583 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
4584 tree gnu_byte_offset
4585 = convert (sizetype,
4586 size_diffop (size_zero_node, gnu_pos));
4587 gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
4589 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
4590 gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
4591 gnu_ptr, gnu_byte_offset);
4594 gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
4595 Procedure_To_Call (gnat_node),
4596 Storage_Pool (gnat_node),
4601 case N_Raise_Constraint_Error:
4602 case N_Raise_Program_Error:
4603 case N_Raise_Storage_Error:
4604 if (type_annotate_only)
4606 gnu_result = alloc_stmt_list ();
4610 gnu_result_type = get_unpadded_type (Etype (gnat_node));
4612 = build_call_raise (UI_To_Int (Reason (gnat_node)), gnat_node,
4615 /* If the type is VOID, this is a statement, so we need to
4616 generate the code for the call. Handle a Condition, if there
4618 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4620 annotate_with_node (gnu_result, gnat_node);
4622 if (Present (Condition (gnat_node)))
4623 gnu_result = build3 (COND_EXPR, void_type_node,
4624 gnat_to_gnu (Condition (gnat_node)),
4625 gnu_result, alloc_stmt_list ());
4628 gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
4631 case N_Validate_Unchecked_Conversion:
4632 /* If the result is a pointer type, see if we are either converting
4633 from a non-pointer or from a pointer to a type with a different
4634 alias set and warn if so. If the result defined in the same unit as
4635 this unchecked conversion, we can allow this because we can know to
4636 make that type have alias set 0. */
4638 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
4639 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
4641 if (POINTER_TYPE_P (gnu_target_type)
4642 && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node)
4643 && get_alias_set (TREE_TYPE (gnu_target_type)) != 0
4644 && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node)))
4645 && (!POINTER_TYPE_P (gnu_source_type)
4646 || (get_alias_set (TREE_TYPE (gnu_source_type))
4647 != get_alias_set (TREE_TYPE (gnu_target_type)))))
4650 ("?possible aliasing problem for type&",
4651 gnat_node, Target_Type (gnat_node));
4653 ("\\?use -fno-strict-aliasing switch for references",
4656 ("\\?or use `pragma No_Strict_Aliasing (&);`",
4657 gnat_node, Target_Type (gnat_node));
4660 /* The No_Strict_Aliasing flag is not propagated to the back-end for
4661 fat pointers so unconditionally warn in problematic cases. */
4662 else if (TYPE_FAT_POINTER_P (gnu_target_type))
4665 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
4667 if (get_alias_set (array_type) != 0
4668 && (!TYPE_FAT_POINTER_P (gnu_source_type)
4669 || (get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))))
4670 != get_alias_set (array_type))))
4673 ("?possible aliasing problem for type&",
4674 gnat_node, Target_Type (gnat_node));
4676 ("\\?use -fno-strict-aliasing switch for references",
4681 gnu_result = alloc_stmt_list ();
4684 case N_Raise_Statement:
4685 case N_Function_Specification:
4686 case N_Procedure_Specification:
4688 case N_Component_Association:
4691 gcc_assert (type_annotate_only);
4692 gnu_result = alloc_stmt_list ();
4695 /* If we pushed our level as part of processing the elaboration routine,
4697 if (went_into_elab_proc)
4699 add_stmt (gnu_result);
4701 gnu_result = end_stmt_group ();
4702 current_function_decl = NULL_TREE;
4705 /* Set the location information on the result if it is a real expression.
4706 References can be reused for multiple GNAT nodes and they would get
4707 the location information of their last use. Note that we may have
4708 no result if we tried to build a CALL_EXPR node to a procedure with
4709 no side-effects and optimization is enabled. */
4710 if (gnu_result && EXPR_P (gnu_result) && !REFERENCE_CLASS_P (gnu_result))
4711 annotate_with_node (gnu_result, gnat_node);
4713 /* If we're supposed to return something of void_type, it means we have
4714 something we're elaborating for effect, so just return. */
4715 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4718 /* If the result is a constant that overflows, raise constraint error. */
4719 else if (TREE_CODE (gnu_result) == INTEGER_CST
4720 && TREE_OVERFLOW (gnu_result))
4722 post_error ("Constraint_Error will be raised at run-time?", gnat_node);
4725 = build1 (NULL_EXPR, gnu_result_type,
4726 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
4727 N_Raise_Constraint_Error));
4730 /* If our result has side-effects and is of an unconstrained type,
4731 make a SAVE_EXPR so that we can be sure it will only be referenced
4732 once. Note we must do this before any conversions. */
4733 if (TREE_SIDE_EFFECTS (gnu_result)
4734 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
4735 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
4736 gnu_result = gnat_stabilize_reference (gnu_result, false);
4738 /* Now convert the result to the proper type. If the type is void or if
4739 we have no result, return error_mark_node to show we have no result.
4740 If the type of the result is correct or if we have a label (which doesn't
4741 have any well-defined type), return our result. Also don't do the
4742 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4743 since those are the cases where the front end may have the type wrong due
4744 to "instantiating" the unconstrained record with discriminant values
4745 or if this is a FIELD_DECL. If this is the Name of an assignment
4746 statement or a parameter of a procedure call, return what we have since
4747 the RHS has to be converted to our type there in that case, unless
4748 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
4749 record types with the same name, the expression type has integral mode,
4750 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
4751 we are converting from a packable type to its actual type and we need
4752 those conversions to be NOPs in order for assignments into these types to
4753 work properly if the inner object is a bitfield and hence can't have
4754 its address taken. Finally, don't convert integral types that are the
4755 operand of an unchecked conversion since we need to ignore those
4756 conversions (for 'Valid). Otherwise, convert the result to the proper
4759 if (Present (Parent (gnat_node))
4760 && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
4761 && Name (Parent (gnat_node)) == gnat_node)
4762 || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
4763 && Name (Parent (gnat_node)) != gnat_node)
4764 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
4765 && !AGGREGATE_TYPE_P (gnu_result_type)
4766 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4767 || Nkind (Parent (gnat_node)) == N_Parameter_Association)
4768 && !(TYPE_SIZE (gnu_result_type)
4769 && TYPE_SIZE (TREE_TYPE (gnu_result))
4770 && (AGGREGATE_TYPE_P (gnu_result_type)
4771 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4772 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
4773 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
4775 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4776 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
4777 && (CONTAINS_PLACEHOLDER_P
4778 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
4779 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
4780 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
4782 /* In this case remove padding only if the inner object is of
4783 self-referential size: in that case it must be an object of
4784 unconstrained type with a default discriminant. In other cases,
4785 we want to avoid copying too much data. */
4786 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4787 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
4788 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4789 (TREE_TYPE (TYPE_FIELDS
4790 (TREE_TYPE (gnu_result))))))
4791 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4795 else if (TREE_CODE (gnu_result) == LABEL_DECL
4796 || TREE_CODE (gnu_result) == FIELD_DECL
4797 || TREE_CODE (gnu_result) == ERROR_MARK
4798 || (TYPE_SIZE (gnu_result_type)
4799 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4800 && TREE_CODE (gnu_result) != INDIRECT_REF
4801 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
4802 || ((TYPE_NAME (gnu_result_type)
4803 == TYPE_NAME (TREE_TYPE (gnu_result)))
4804 && TREE_CODE (gnu_result_type) == RECORD_TYPE
4805 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4806 && TYPE_MODE (gnu_result_type) == BLKmode
4807 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
4810 /* Remove any padding record, but do nothing more in this case. */
4811 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4812 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4813 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4817 else if (gnu_result == error_mark_node
4818 || gnu_result_type == void_type_node)
4819 gnu_result = error_mark_node;
4820 else if (gnu_result_type != TREE_TYPE (gnu_result))
4821 gnu_result = convert (gnu_result_type, gnu_result);
4823 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4824 while ((TREE_CODE (gnu_result) == NOP_EXPR
4825 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4826 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4827 gnu_result = TREE_OPERAND (gnu_result, 0);
4832 /* Subroutine of above to push the exception label stack. GNU_STACK is
4833 a pointer to the stack to update and GNAT_LABEL, if present, is the
4834 label to push onto the stack. */
4837 push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label)
4839 tree gnu_label = (Present (gnat_label)
4840 ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
4843 *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack);
4846 /* Record the current code position in GNAT_NODE. */
4849 record_code_position (Node_Id gnat_node)
4851 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
4853 add_stmt_with_node (stmt_stmt, gnat_node);
4854 save_gnu_tree (gnat_node, stmt_stmt, true);
4857 /* Insert the code for GNAT_NODE at the position saved for that node. */
4860 insert_code_for (Node_Id gnat_node)
4862 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
4863 save_gnu_tree (gnat_node, NULL_TREE, true);
4866 /* Start a new statement group chained to the previous group. */
4869 start_stmt_group (void)
4871 struct stmt_group *group = stmt_group_free_list;
4873 /* First see if we can get one from the free list. */
4875 stmt_group_free_list = group->previous;
4877 group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group));
4879 group->previous = current_stmt_group;
4880 group->stmt_list = group->block = group->cleanups = NULL_TREE;
4881 current_stmt_group = group;
4884 /* Add GNU_STMT to the current statement group. */
4887 add_stmt (tree gnu_stmt)
4889 append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list);
4892 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
4895 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
4897 if (Present (gnat_node))
4898 annotate_with_node (gnu_stmt, gnat_node);
4899 add_stmt (gnu_stmt);
4902 /* Add a declaration statement for GNU_DECL to the current statement group.
4903 Get SLOC from Entity_Id. */
4906 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
4908 tree type = TREE_TYPE (gnu_decl);
4909 tree gnu_stmt, gnu_init, gnu_lhs;
4911 /* If this is a variable that Gigi is to ignore, we may have been given
4912 an ERROR_MARK. So test for it. We also might have been given a
4913 reference for a renaming. So only do something for a decl. Also
4914 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
4915 if (!DECL_P (gnu_decl)
4916 || (TREE_CODE (gnu_decl) == TYPE_DECL
4917 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
4920 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
4922 /* If we are global, we don't want to actually output the DECL_EXPR for
4923 this decl since we already have evaluated the expressions in the
4924 sizes and positions as globals and doing it again would be wrong. */
4925 if (global_bindings_p ())
4927 /* Mark everything as used to prevent node sharing with subprograms.
4928 Note that walk_tree knows how to handle TYPE_DECL, but neither
4929 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
4930 walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
4931 if (TREE_CODE (gnu_decl) == VAR_DECL
4932 || TREE_CODE (gnu_decl) == CONST_DECL)
4934 walk_tree (&DECL_SIZE (gnu_decl), mark_visited, NULL, NULL);
4935 walk_tree (&DECL_SIZE_UNIT (gnu_decl), mark_visited, NULL, NULL);
4936 walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL);
4940 add_stmt_with_node (gnu_stmt, gnat_entity);
4942 /* If this is a variable and an initializer is attached to it, it must be
4943 valid for the context. Similar to init_const in create_var_decl_1. */
4944 if (TREE_CODE (gnu_decl) == VAR_DECL
4945 && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE
4946 && (TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (TREE_TYPE (gnu_init))
4947 || (TREE_STATIC (gnu_decl)
4948 && !initializer_constant_valid_p (gnu_init,
4949 TREE_TYPE (gnu_init)))))
4951 /* If GNU_DECL has a padded type, convert it to the unpadded
4952 type so the assignment is done properly. */
4953 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
4954 gnu_lhs = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
4958 gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_init);
4960 DECL_INITIAL (gnu_decl) = NULL_TREE;
4961 if (TREE_READONLY (gnu_decl))
4963 TREE_READONLY (gnu_decl) = 0;
4964 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
4967 add_stmt_with_node (gnu_stmt, gnat_entity);
4971 /* Utility function to mark nodes with TREE_VISITED and types as having their
4972 sized gimplified. Called from walk_tree. We use this to indicate all
4973 variable sizes and positions in global types may not be shared by any
4977 mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
4979 if (TREE_VISITED (*tp))
4982 /* Don't mark a dummy type as visited because we want to mark its sizes
4983 and fields once it's filled in. */
4984 else if (!TYPE_IS_DUMMY_P (*tp))
4985 TREE_VISITED (*tp) = 1;
4988 TYPE_SIZES_GIMPLIFIED (*tp) = 1;
4993 /* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
4996 unshare_save_expr (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
4997 void *data ATTRIBUTE_UNUSED)
5001 if (TREE_CODE (t) == SAVE_EXPR)
5002 TREE_OPERAND (t, 0) = unshare_expr (TREE_OPERAND (t, 0));
5007 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
5008 set its location to that of GNAT_NODE if present. */
5011 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
5013 if (Present (gnat_node))
5014 annotate_with_node (gnu_cleanup, gnat_node);
5015 append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups);
5018 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
5021 set_block_for_group (tree gnu_block)
5023 gcc_assert (!current_stmt_group->block);
5024 current_stmt_group->block = gnu_block;
5027 /* Return code corresponding to the current code group. It is normally
5028 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
5029 BLOCK or cleanups were set. */
5032 end_stmt_group (void)
5034 struct stmt_group *group = current_stmt_group;
5035 tree gnu_retval = group->stmt_list;
5037 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
5038 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
5039 make a BIND_EXPR. Note that we nest in that because the cleanup may
5040 reference variables in the block. */
5041 if (gnu_retval == NULL_TREE)
5042 gnu_retval = alloc_stmt_list ();
5044 if (group->cleanups)
5045 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
5048 if (current_stmt_group->block)
5049 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
5050 gnu_retval, group->block);
5052 /* Remove this group from the stack and add it to the free list. */
5053 current_stmt_group = group->previous;
5054 group->previous = stmt_group_free_list;
5055 stmt_group_free_list = group;
5060 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
5064 add_stmt_list (List_Id gnat_list)
5068 if (Present (gnat_list))
5069 for (gnat_node = First (gnat_list); Present (gnat_node);
5070 gnat_node = Next (gnat_node))
5071 add_stmt (gnat_to_gnu (gnat_node));
5074 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
5075 If BINDING_P is true, push and pop a binding level around the list. */
5078 build_stmt_group (List_Id gnat_list, bool binding_p)
5080 start_stmt_group ();
5084 add_stmt_list (gnat_list);
5088 return end_stmt_group ();
5091 /* Push and pop routines for stacks. We keep a free list around so we
5092 don't waste tree nodes. */
5095 push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value)
5097 tree gnu_node = gnu_stack_free_list;
5101 gnu_stack_free_list = TREE_CHAIN (gnu_node);
5102 TREE_CHAIN (gnu_node) = *gnu_stack_ptr;
5103 TREE_PURPOSE (gnu_node) = gnu_purpose;
5104 TREE_VALUE (gnu_node) = gnu_value;
5107 gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr);
5109 *gnu_stack_ptr = gnu_node;
5113 pop_stack (tree *gnu_stack_ptr)
5115 tree gnu_node = *gnu_stack_ptr;
5117 *gnu_stack_ptr = TREE_CHAIN (gnu_node);
5118 TREE_CHAIN (gnu_node) = gnu_stack_free_list;
5119 gnu_stack_free_list = gnu_node;
5122 /* Generate GIMPLE in place for the expression at *EXPR_P. */
5125 gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED)
5127 tree expr = *expr_p;
5130 if (IS_ADA_STMT (expr))
5131 return gnat_gimplify_stmt (expr_p);
5133 switch (TREE_CODE (expr))
5136 /* If this is for a scalar, just make a VAR_DECL for it. If for
5137 an aggregate, get a null pointer of the appropriate type and
5139 if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
5140 *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
5141 convert (build_pointer_type (TREE_TYPE (expr)),
5142 integer_zero_node));
5145 *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
5146 TREE_NO_WARNING (*expr_p) = 1;
5149 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
5152 case UNCONSTRAINED_ARRAY_REF:
5153 /* We should only do this if we are just elaborating for side-effects,
5154 but we can't know that yet. */
5155 *expr_p = TREE_OPERAND (*expr_p, 0);
5159 op = TREE_OPERAND (expr, 0);
5161 /* If we're taking the address of a constant CONSTRUCTOR, force it to
5162 be put into static memory. We know it's going to be readonly given
5163 the semantics we have and it's required to be static memory in
5164 the case when the reference is in an elaboration procedure. */
5165 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
5167 tree new_var = create_tmp_var (TREE_TYPE (op), "C");
5169 TREE_READONLY (new_var) = 1;
5170 TREE_STATIC (new_var) = 1;
5171 TREE_ADDRESSABLE (new_var) = 1;
5172 DECL_INITIAL (new_var) = op;
5174 TREE_OPERAND (expr, 0) = new_var;
5175 recompute_tree_invariant_for_addr_expr (expr);
5179 /* If we are taking the address of a SAVE_EXPR, we are typically
5180 processing a misaligned argument to be passed by reference in a
5181 procedure call. We just mark the operand as addressable + not
5182 readonly here and let the common gimplifier code perform the
5183 temporary creation, initialization, and "instantiation" in place of
5184 the SAVE_EXPR in further operands, in particular in the copy back
5185 code inserted after the call. */
5186 else if (TREE_CODE (op) == SAVE_EXPR)
5188 TREE_ADDRESSABLE (op) = 1;
5189 TREE_READONLY (op) = 0;
5192 /* Otherwise, if we are taking the address of something that is neither
5193 reference, declaration, or constant, make a variable for the operand
5194 here and then take its address. If we don't do it this way, we may
5195 confuse the gimplifier because it needs to know the variable is
5196 addressable at this point. This duplicates code in
5197 internal_get_tmp_var, which is unfortunate. */
5198 else if (TREE_CODE_CLASS (TREE_CODE (op)) != tcc_reference
5199 && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_declaration
5200 && TREE_CODE_CLASS (TREE_CODE (op)) != tcc_constant)
5202 tree new_var = create_tmp_var (TREE_TYPE (op), "A");
5203 tree mod = build2 (GIMPLE_MODIFY_STMT, TREE_TYPE (op), new_var, op);
5205 TREE_ADDRESSABLE (new_var) = 1;
5207 if (EXPR_HAS_LOCATION (op))
5208 SET_EXPR_LOCUS (mod, EXPR_LOCUS (op));
5210 gimplify_and_add (mod, pre_p);
5211 TREE_OPERAND (expr, 0) = new_var;
5212 recompute_tree_invariant_for_addr_expr (expr);
5216 /* ... fall through ... */
5219 return GS_UNHANDLED;
5223 /* Generate GIMPLE in place for the statement at *STMT_P. */
5225 static enum gimplify_status
5226 gnat_gimplify_stmt (tree *stmt_p)
5228 tree stmt = *stmt_p;
5230 switch (TREE_CODE (stmt))
5233 *stmt_p = STMT_STMT_STMT (stmt);
5238 tree gnu_start_label = create_artificial_label ();
5239 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
5241 /* Set to emit the statements of the loop. */
5242 *stmt_p = NULL_TREE;
5244 /* We first emit the start label and then a conditional jump to
5245 the end label if there's a top condition, then the body of the
5246 loop, then a conditional branch to the end label, then the update,
5247 if any, and finally a jump to the start label and the definition
5248 of the end label. */
5249 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
5253 if (LOOP_STMT_TOP_COND (stmt))
5254 append_to_statement_list (build3 (COND_EXPR, void_type_node,
5255 LOOP_STMT_TOP_COND (stmt),
5262 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
5264 if (LOOP_STMT_BOT_COND (stmt))
5265 append_to_statement_list (build3 (COND_EXPR, void_type_node,
5266 LOOP_STMT_BOT_COND (stmt),
5273 if (LOOP_STMT_UPDATE (stmt))
5274 append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
5276 append_to_statement_list (build1 (GOTO_EXPR, void_type_node,
5279 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
5286 /* Build a statement to jump to the corresponding end label, then
5287 see if it needs to be conditional. */
5288 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
5289 if (EXIT_STMT_COND (stmt))
5290 *stmt_p = build3 (COND_EXPR, void_type_node,
5291 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
5299 /* Force references to each of the entities in packages withed by GNAT_NODE.
5300 Operate recursively but check that we aren't elaborating something more
5303 This routine is exclusively called in type_annotate mode, to compute DDA
5304 information for types in withed units, for ASIS use. */
5307 elaborate_all_entities (Node_Id gnat_node)
5309 Entity_Id gnat_with_clause, gnat_entity;
5311 /* Process each unit only once. As we trace the context of all relevant
5312 units transitively, including generic bodies, we may encounter the
5313 same generic unit repeatedly. */
5314 if (!present_gnu_tree (gnat_node))
5315 save_gnu_tree (gnat_node, integer_zero_node, true);
5317 /* Save entities in all context units. A body may have an implicit_with
5318 on its own spec, if the context includes a child unit, so don't save
5320 for (gnat_with_clause = First (Context_Items (gnat_node));
5321 Present (gnat_with_clause);
5322 gnat_with_clause = Next (gnat_with_clause))
5323 if (Nkind (gnat_with_clause) == N_With_Clause
5324 && !present_gnu_tree (Library_Unit (gnat_with_clause))
5325 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
5327 elaborate_all_entities (Library_Unit (gnat_with_clause));
5329 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
5331 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
5332 Present (gnat_entity);
5333 gnat_entity = Next_Entity (gnat_entity))
5334 if (Is_Public (gnat_entity)
5335 && Convention (gnat_entity) != Convention_Intrinsic
5336 && Ekind (gnat_entity) != E_Package
5337 && Ekind (gnat_entity) != E_Package_Body
5338 && Ekind (gnat_entity) != E_Operator
5339 && !(IN (Ekind (gnat_entity), Type_Kind)
5340 && !Is_Frozen (gnat_entity))
5341 && !((Ekind (gnat_entity) == E_Procedure
5342 || Ekind (gnat_entity) == E_Function)
5343 && Is_Intrinsic_Subprogram (gnat_entity))
5344 && !IN (Ekind (gnat_entity), Named_Kind)
5345 && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
5346 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5348 else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
5351 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
5353 /* Retrieve compilation unit node of generic body. */
5354 while (Present (gnat_body)
5355 && Nkind (gnat_body) != N_Compilation_Unit)
5356 gnat_body = Parent (gnat_body);
5358 /* If body is available, elaborate its context. */
5359 if (Present (gnat_body))
5360 elaborate_all_entities (gnat_body);
5364 if (Nkind (Unit (gnat_node)) == N_Package_Body)
5365 elaborate_all_entities (Library_Unit (gnat_node));
5368 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
5371 process_freeze_entity (Node_Id gnat_node)
5373 Entity_Id gnat_entity = Entity (gnat_node);
5377 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
5378 && present_gnu_tree (Declaration_Node (gnat_entity)))
5379 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
5381 /* If this is a package, need to generate code for the package. */
5382 if (Ekind (gnat_entity) == E_Package)
5385 (Parent (Corresponding_Body
5386 (Parent (Declaration_Node (gnat_entity)))));
5390 /* Check for old definition after the above call. This Freeze_Node
5391 might be for one its Itypes. */
5393 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
5395 /* If this entity has an Address representation clause, GNU_OLD is the
5396 address, so discard it here. */
5397 if (Present (Address_Clause (gnat_entity)))
5400 /* Don't do anything for class-wide types they are always
5401 transformed into their root type. */
5402 if (Ekind (gnat_entity) == E_Class_Wide_Type
5403 || (Ekind (gnat_entity) == E_Class_Wide_Subtype
5404 && Present (Equivalent_Type (gnat_entity))))
5407 /* Don't do anything for subprograms that may have been elaborated before
5408 their freeze nodes. This can happen, for example because of an inner call
5409 in an instance body, or a previous compilation of a spec for inlining
5412 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
5413 && (Ekind (gnat_entity) == E_Function
5414 || Ekind (gnat_entity) == E_Procedure))
5416 && TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE
5417 && Ekind (gnat_entity) == E_Subprogram_Type)))
5420 /* If we have a non-dummy type old tree, we have nothing to do, except
5421 aborting if this is the public view of a private type whose full view was
5422 not delayed, as this node was never delayed as it should have been. We
5423 let this happen for concurrent types and their Corresponding_Record_Type,
5424 however, because each might legitimately be elaborated before it's own
5425 freeze node, e.g. while processing the other. */
5427 && !(TREE_CODE (gnu_old) == TYPE_DECL
5428 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
5430 gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5431 && Present (Full_View (gnat_entity))
5432 && No (Freeze_Node (Full_View (gnat_entity))))
5433 || Is_Concurrent_Type (gnat_entity)
5434 || (IN (Ekind (gnat_entity), Record_Kind)
5435 && Is_Concurrent_Record_Type (gnat_entity)));
5439 /* Reset the saved tree, if any, and elaborate the object or type for real.
5440 If there is a full declaration, elaborate it and copy the type to
5441 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
5442 a class wide type or subtype. */
5445 save_gnu_tree (gnat_entity, NULL_TREE, false);
5446 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5447 && Present (Full_View (gnat_entity))
5448 && present_gnu_tree (Full_View (gnat_entity)))
5449 save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
5450 if (Present (Class_Wide_Type (gnat_entity))
5451 && Class_Wide_Type (gnat_entity) != gnat_entity)
5452 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
5455 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5456 && Present (Full_View (gnat_entity)))
5458 gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
5460 /* Propagate back-annotations from full view to partial view. */
5461 if (Unknown_Alignment (gnat_entity))
5462 Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
5464 if (Unknown_Esize (gnat_entity))
5465 Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
5467 if (Unknown_RM_Size (gnat_entity))
5468 Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
5470 /* The above call may have defined this entity (the simplest example
5471 of this is when we have a private enumeral type since the bounds
5472 will have the public view. */
5473 if (!present_gnu_tree (gnat_entity))
5474 save_gnu_tree (gnat_entity, gnu_new, false);
5475 if (Present (Class_Wide_Type (gnat_entity))
5476 && Class_Wide_Type (gnat_entity) != gnat_entity)
5477 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
5480 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
5482 /* If we've made any pointers to the old version of this type, we
5483 have to update them. */
5485 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
5486 TREE_TYPE (gnu_new));
5489 /* Process the list of inlined subprograms of GNAT_NODE, which is an
5490 N_Compilation_Unit. */
5493 process_inlined_subprograms (Node_Id gnat_node)
5495 Entity_Id gnat_entity;
5498 /* If we can inline, generate RTL for all the inlined subprograms.
5499 Define the entity first so we set DECL_EXTERNAL. */
5500 if (optimize > 0 && !flag_really_no_inline)
5501 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5502 Present (gnat_entity);
5503 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5505 gnat_body = Parent (Declaration_Node (gnat_entity));
5507 if (Nkind (gnat_body) != N_Subprogram_Body)
5509 /* ??? This really should always be Present. */
5510 if (No (Corresponding_Body (gnat_body)))
5514 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5517 if (Present (gnat_body))
5519 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
5520 add_stmt (gnat_to_gnu (gnat_body));
5525 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
5526 We make two passes, one to elaborate anything other than bodies (but
5527 we declare a function if there was no spec). The second pass
5528 elaborates the bodies.
5530 GNAT_END_LIST gives the element in the list past the end. Normally,
5531 this is Empty, but can be First_Real_Statement for a
5532 Handled_Sequence_Of_Statements.
5534 We make a complete pass through both lists if PASS1P is true, then make
5535 the second pass over both lists if PASS2P is true. The lists usually
5536 correspond to the public and private parts of a package. */
5539 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
5540 Node_Id gnat_end_list, bool pass1p, bool pass2p)
5542 List_Id gnat_decl_array[2];
5546 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
5549 for (i = 0; i <= 1; i++)
5550 if (Present (gnat_decl_array[i]))
5551 for (gnat_decl = First (gnat_decl_array[i]);
5552 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
5554 /* For package specs, we recurse inside the declarations,
5555 thus taking the two pass approach inside the boundary. */
5556 if (Nkind (gnat_decl) == N_Package_Declaration
5557 && (Nkind (Specification (gnat_decl)
5558 == N_Package_Specification)))
5559 process_decls (Visible_Declarations (Specification (gnat_decl)),
5560 Private_Declarations (Specification (gnat_decl)),
5561 Empty, true, false);
5563 /* Similarly for any declarations in the actions of a
5565 else if (Nkind (gnat_decl) == N_Freeze_Entity)
5567 process_freeze_entity (gnat_decl);
5568 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
5571 /* Package bodies with freeze nodes get their elaboration deferred
5572 until the freeze node, but the code must be placed in the right
5573 place, so record the code position now. */
5574 else if (Nkind (gnat_decl) == N_Package_Body
5575 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
5576 record_code_position (gnat_decl);
5578 else if (Nkind (gnat_decl) == N_Package_Body_Stub
5579 && Present (Library_Unit (gnat_decl))
5580 && Present (Freeze_Node
5583 (Library_Unit (gnat_decl)))))))
5584 record_code_position
5585 (Proper_Body (Unit (Library_Unit (gnat_decl))));
5587 /* We defer most subprogram bodies to the second pass. */
5588 else if (Nkind (gnat_decl) == N_Subprogram_Body)
5590 if (Acts_As_Spec (gnat_decl))
5592 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
5594 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
5595 && Ekind (gnat_subprog_id) != E_Generic_Function)
5596 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
5599 /* For bodies and stubs that act as their own specs, the entity
5600 itself must be elaborated in the first pass, because it may
5601 be used in other declarations. */
5602 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
5604 Node_Id gnat_subprog_id =
5605 Defining_Entity (Specification (gnat_decl));
5607 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
5608 && Ekind (gnat_subprog_id) != E_Generic_Procedure
5609 && Ekind (gnat_subprog_id) != E_Generic_Function)
5610 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
5613 /* Concurrent stubs stand for the corresponding subprogram bodies,
5614 which are deferred like other bodies. */
5615 else if (Nkind (gnat_decl) == N_Task_Body_Stub
5616 || Nkind (gnat_decl) == N_Protected_Body_Stub)
5619 add_stmt (gnat_to_gnu (gnat_decl));
5622 /* Here we elaborate everything we deferred above except for package bodies,
5623 which are elaborated at their freeze nodes. Note that we must also
5624 go inside things (package specs and freeze nodes) the first pass did. */
5626 for (i = 0; i <= 1; i++)
5627 if (Present (gnat_decl_array[i]))
5628 for (gnat_decl = First (gnat_decl_array[i]);
5629 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
5631 if (Nkind (gnat_decl) == N_Subprogram_Body
5632 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
5633 || Nkind (gnat_decl) == N_Task_Body_Stub
5634 || Nkind (gnat_decl) == N_Protected_Body_Stub)
5635 add_stmt (gnat_to_gnu (gnat_decl));
5637 else if (Nkind (gnat_decl) == N_Package_Declaration
5638 && (Nkind (Specification (gnat_decl)
5639 == N_Package_Specification)))
5640 process_decls (Visible_Declarations (Specification (gnat_decl)),
5641 Private_Declarations (Specification (gnat_decl)),
5642 Empty, false, true);
5644 else if (Nkind (gnat_decl) == N_Freeze_Entity)
5645 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
5649 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
5650 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
5651 which we have to check. */
5654 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
5656 tree gnu_range_type = get_unpadded_type (gnat_range_type);
5657 tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
5658 tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
5659 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
5661 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
5662 we can't do anything since we might be truncating the bounds. No
5663 check is needed in this case. */
5664 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
5665 && (TYPE_PRECISION (gnu_compare_type)
5666 < TYPE_PRECISION (get_base_type (gnu_range_type))))
5669 /* Checked expressions must be evaluated only once. */
5670 gnu_expr = protect_multiple_eval (gnu_expr);
5672 /* There's no good type to use here, so we might as well use
5673 integer_type_node. Note that the form of the check is
5674 (not (expr >= lo)) or (not (expr <= hi))
5675 the reason for this slightly convoluted form is that NaN's
5676 are not considered to be in range in the float case. */
5678 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5680 (build_binary_op (GE_EXPR, integer_type_node,
5681 convert (gnu_compare_type, gnu_expr),
5682 convert (gnu_compare_type, gnu_low))),
5684 (build_binary_op (LE_EXPR, integer_type_node,
5685 convert (gnu_compare_type, gnu_expr),
5686 convert (gnu_compare_type,
5688 gnu_expr, CE_Range_Check_Failed);
5691 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
5692 which we are about to index, GNU_EXPR is the index expression to be
5693 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
5694 against which GNU_EXPR has to be checked. Note that for index
5695 checking we cannot use the emit_range_check function (although very
5696 similar code needs to be generated in both cases) since for index
5697 checking the array type against which we are checking the indeces
5698 may be unconstrained and consequently we need to retrieve the
5699 actual index bounds from the array object itself
5700 (GNU_ARRAY_OBJECT). The place where we need to do that is in
5701 subprograms having unconstrained array formal parameters */
5704 emit_index_check (tree gnu_array_object,
5709 tree gnu_expr_check;
5711 /* Checked expressions must be evaluated only once. */
5712 gnu_expr = protect_multiple_eval (gnu_expr);
5714 /* Must do this computation in the base type in case the expression's
5715 type is an unsigned subtypes. */
5716 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
5718 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
5719 the object we are handling. */
5720 gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
5721 gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
5723 /* There's no good type to use here, so we might as well use
5724 integer_type_node. */
5726 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5727 build_binary_op (LT_EXPR, integer_type_node,
5729 convert (TREE_TYPE (gnu_expr_check),
5731 build_binary_op (GT_EXPR, integer_type_node,
5733 convert (TREE_TYPE (gnu_expr_check),
5735 gnu_expr, CE_Index_Check_Failed);
5738 /* GNU_COND contains the condition corresponding to an access, discriminant or
5739 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
5740 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
5741 REASON is the code that says why the exception was raised. */
5744 emit_check (tree gnu_cond, tree gnu_expr, int reason)
5749 gnu_call = build_call_raise (reason, Empty, N_Raise_Constraint_Error);
5751 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
5752 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
5753 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
5755 gnu_result = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
5756 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
5757 gnu_call, gnu_expr),
5760 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
5761 protect it. Otherwise, show GNU_RESULT has no side effects: we
5762 don't need to evaluate it just for the check. */
5763 if (TREE_SIDE_EFFECTS (gnu_expr))
5765 = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
5767 TREE_SIDE_EFFECTS (gnu_result) = 0;
5769 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
5770 we will repeatedly do the test. It would be nice if GCC was able
5771 to optimize this and only do it once. */
5772 return save_expr (gnu_result);
5775 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
5776 overflow checks if OVERFLOW_P is nonzero and range checks if
5777 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
5778 If TRUNCATE_P is nonzero, do a float to integer conversion with
5779 truncation; otherwise round. */
5782 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
5783 bool rangep, bool truncatep)
5785 tree gnu_type = get_unpadded_type (gnat_type);
5786 tree gnu_in_type = TREE_TYPE (gnu_expr);
5787 tree gnu_in_basetype = get_base_type (gnu_in_type);
5788 tree gnu_base_type = get_base_type (gnu_type);
5789 tree gnu_result = gnu_expr;
5791 /* If we are not doing any checks, the output is an integral type, and
5792 the input is not a floating type, just do the conversion. This
5793 shortcut is required to avoid problems with packed array types
5794 and simplifies code in all cases anyway. */
5795 if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
5796 && !FLOAT_TYPE_P (gnu_in_type))
5797 return convert (gnu_type, gnu_expr);
5799 /* First convert the expression to its base type. This
5800 will never generate code, but makes the tests below much simpler.
5801 But don't do this if converting from an integer type to an unconstrained
5802 array type since then we need to get the bounds from the original
5804 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
5805 gnu_result = convert (gnu_in_basetype, gnu_result);
5807 /* If overflow checks are requested, we need to be sure the result will
5808 fit in the output base type. But don't do this if the input
5809 is integer and the output floating-point. */
5811 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
5813 /* Ensure GNU_EXPR only gets evaluated once. */
5814 tree gnu_input = protect_multiple_eval (gnu_result);
5815 tree gnu_cond = integer_zero_node;
5816 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
5817 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
5818 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
5819 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
5821 /* Convert the lower bounds to signed types, so we're sure we're
5822 comparing them properly. Likewise, convert the upper bounds
5823 to unsigned types. */
5824 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
5825 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
5827 if (INTEGRAL_TYPE_P (gnu_in_basetype)
5828 && !TYPE_UNSIGNED (gnu_in_basetype))
5829 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
5831 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
5832 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
5834 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
5835 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
5837 /* Check each bound separately and only if the result bound
5838 is tighter than the bound on the input type. Note that all the
5839 types are base types, so the bounds must be constant. Also,
5840 the comparison is done in the base type of the input, which
5841 always has the proper signedness. First check for input
5842 integer (which means output integer), output float (which means
5843 both float), or mixed, in which case we always compare.
5844 Note that we have to do the comparison which would *fail* in the
5845 case of an error since if it's an FP comparison and one of the
5846 values is a NaN or Inf, the comparison will fail. */
5847 if (INTEGRAL_TYPE_P (gnu_in_basetype)
5848 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
5849 : (FLOAT_TYPE_P (gnu_base_type)
5850 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
5851 TREE_REAL_CST (gnu_out_lb))
5855 (build_binary_op (GE_EXPR, integer_type_node,
5856 gnu_input, convert (gnu_in_basetype,
5859 if (INTEGRAL_TYPE_P (gnu_in_basetype)
5860 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
5861 : (FLOAT_TYPE_P (gnu_base_type)
5862 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
5863 TREE_REAL_CST (gnu_in_lb))
5866 = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
5868 (build_binary_op (LE_EXPR, integer_type_node,
5870 convert (gnu_in_basetype,
5873 if (!integer_zerop (gnu_cond))
5874 gnu_result = emit_check (gnu_cond, gnu_input,
5875 CE_Overflow_Check_Failed);
5878 /* Now convert to the result base type. If this is a non-truncating
5879 float-to-integer conversion, round. */
5880 if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
5883 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
5884 tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
5885 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
5886 const struct real_format *fmt;
5888 /* The following calculations depend on proper rounding to even
5889 of each arithmetic operation. In order to prevent excess
5890 precision from spoiling this property, use the widest hardware
5891 floating-point type.
5893 FIXME: For maximum efficiency, this should only be done for machines
5894 and types where intermediates may have extra precision. */
5896 calc_type = longest_float_type_node;
5897 /* FIXME: Should not have padding in the first place */
5898 if (TREE_CODE (calc_type) == RECORD_TYPE
5899 && TYPE_IS_PADDING_P (calc_type))
5900 calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
5902 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
5903 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
5904 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
5905 REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
5906 half_minus_pred_half);
5907 gnu_pred_half = build_real (calc_type, pred_half);
5909 /* If the input is strictly negative, subtract this value
5910 and otherwise add it from the input. For 0.5, the result
5911 is exactly between 1.0 and the machine number preceding 1.0
5912 (for calc_type). Since the last bit of 1.0 is even, this 0.5
5913 will round to 1.0, while all other number with an absolute
5914 value less than 0.5 round to 0.0. For larger numbers exactly
5915 halfway between integers, rounding will always be correct as
5916 the true mathematical result will be closer to the higher
5917 integer compared to the lower one. So, this constant works
5918 for all floating-point numbers.
5920 The reason to use the same constant with subtract/add instead
5921 of a positive and negative constant is to allow the comparison
5922 to be scheduled in parallel with retrieval of the constant and
5923 conversion of the input to the calc_type (if necessary).
5926 gnu_zero = convert (gnu_in_basetype, integer_zero_node);
5927 gnu_saved_result = save_expr (gnu_result);
5928 gnu_conv = convert (calc_type, gnu_saved_result);
5929 gnu_comp = build2 (GE_EXPR, integer_type_node,
5930 gnu_saved_result, gnu_zero);
5932 = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5933 gnu_subtract_pred_half
5934 = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5935 gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
5936 gnu_add_pred_half, gnu_subtract_pred_half);
5939 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
5940 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
5941 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
5942 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
5944 gnu_result = convert (gnu_base_type, gnu_result);
5946 /* Finally, do the range check if requested. Note that if the
5947 result type is a modular type, the range check is actually
5948 an overflow check. */
5951 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
5952 && TYPE_MODULAR_P (gnu_base_type) && overflowp))
5953 gnu_result = emit_range_check (gnu_result, gnat_type);
5955 return convert (gnu_type, gnu_result);
5958 /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
5959 it is an expression involving computation or if it involves a reference
5960 to a bitfield or to a field not sufficiently aligned for its type. */
5963 addressable_p (tree gnu_expr)
5965 switch (TREE_CODE (gnu_expr))
5971 /* All DECLs are addressable: if they are in a register, we can force
5975 case UNCONSTRAINED_ARRAY_REF:
5983 return (!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
5984 && (!STRICT_ALIGNMENT
5985 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
5986 the field is sufficiently aligned, in case it is subject
5987 to a pragma Component_Alignment. But we don't need to
5988 check the alignment of the containing record, as it is
5989 guaranteed to be not smaller than that of its most
5990 aligned field that is not a bit-field. */
5991 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
5992 >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))
5993 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5995 case ARRAY_REF: case ARRAY_RANGE_REF:
5996 case REALPART_EXPR: case IMAGPART_EXPR:
5998 return addressable_p (TREE_OPERAND (gnu_expr, 0));
6001 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
6002 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
6004 case VIEW_CONVERT_EXPR:
6006 /* This is addressable if we can avoid a copy. */
6007 tree type = TREE_TYPE (gnu_expr);
6008 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
6010 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
6011 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
6012 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
6013 || ((TYPE_MODE (type) == BLKmode
6014 || TYPE_MODE (inner_type) == BLKmode)
6015 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
6016 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
6017 || TYPE_ALIGN_OK (type)
6018 || TYPE_ALIGN_OK (inner_type))))
6019 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
6027 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
6028 a separate Freeze node exists, delay the bulk of the processing. Otherwise
6029 make a GCC type for GNAT_ENTITY and set up the correspondence. */
6032 process_type (Entity_Id gnat_entity)
6035 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
6038 /* If we are to delay elaboration of this type, just do any
6039 elaborations needed for expressions within the declaration and
6040 make a dummy type entry for this node and its Full_View (if
6041 any) in case something points to it. Don't do this if it
6042 has already been done (the only way that can happen is if
6043 the private completion is also delayed). */
6044 if (Present (Freeze_Node (gnat_entity))
6045 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
6046 && Present (Full_View (gnat_entity))
6047 && Freeze_Node (Full_View (gnat_entity))
6048 && !present_gnu_tree (Full_View (gnat_entity))))
6050 elaborate_entity (gnat_entity);
6054 tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
6055 make_dummy_type (gnat_entity),
6056 NULL, false, false, gnat_entity);
6058 save_gnu_tree (gnat_entity, gnu_decl, false);
6059 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
6060 && Present (Full_View (gnat_entity)))
6061 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
6067 /* If we saved away a dummy type for this node it means that this
6068 made the type that corresponds to the full type of an incomplete
6069 type. Clear that type for now and then update the type in the
6073 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
6074 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
6076 save_gnu_tree (gnat_entity, NULL_TREE, false);
6079 /* Now fully elaborate the type. */
6080 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
6081 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
6083 /* If we have an old type and we've made pointers to this type,
6084 update those pointers. */
6086 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
6087 TREE_TYPE (gnu_new));
6089 /* If this is a record type corresponding to a task or protected type
6090 that is a completion of an incomplete type, perform a similar update
6092 /* ??? Including protected types here is a guess. */
6094 if (IN (Ekind (gnat_entity), Record_Kind)
6095 && Is_Concurrent_Record_Type (gnat_entity)
6096 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
6099 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
6101 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
6103 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
6106 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
6107 TREE_TYPE (gnu_new));
6111 /* GNAT_ENTITY is the type of the resulting constructors,
6112 GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
6113 and GNU_TYPE is the GCC type of the corresponding record.
6115 Return a CONSTRUCTOR to build the record. */
6118 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
6120 tree gnu_list, gnu_result;
6122 /* We test for GNU_FIELD being empty in the case where a variant
6123 was the last thing since we don't take things off GNAT_ASSOC in
6124 that case. We check GNAT_ASSOC in case we have a variant, but it
6127 for (gnu_list = NULL_TREE; Present (gnat_assoc);
6128 gnat_assoc = Next (gnat_assoc))
6130 Node_Id gnat_field = First (Choices (gnat_assoc));
6131 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
6132 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
6134 /* The expander is supposed to put a single component selector name
6135 in every record component association */
6136 gcc_assert (No (Next (gnat_field)));
6138 /* Ignore fields that have Corresponding_Discriminants since we'll
6139 be setting that field in the parent. */
6140 if (Present (Corresponding_Discriminant (Entity (gnat_field)))
6141 && Is_Tagged_Type (Scope (Entity (gnat_field))))
6144 /* Also ignore discriminants of Unchecked_Unions. */
6145 else if (Is_Unchecked_Union (gnat_entity)
6146 && Ekind (Entity (gnat_field)) == E_Discriminant)
6149 /* Before assigning a value in an aggregate make sure range checks
6150 are done if required. Then convert to the type of the field. */
6151 if (Do_Range_Check (Expression (gnat_assoc)))
6152 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
6154 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
6156 /* Add the field and expression to the list. */
6157 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
6160 gnu_result = extract_values (gnu_list, gnu_type);
6162 #ifdef ENABLE_CHECKING
6166 /* Verify every enty in GNU_LIST was used. */
6167 for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
6168 gcc_assert (TREE_ADDRESSABLE (gnu_field));
6175 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
6176 is the first element of an array aggregate. It may itself be an
6177 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
6178 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
6179 of the array component. It is needed for range checking. */
6182 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
6183 Entity_Id gnat_component_type)
6185 tree gnu_expr_list = NULL_TREE;
6186 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
6189 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
6191 /* If the expression is itself an array aggregate then first build the
6192 innermost constructor if it is part of our array (multi-dimensional
6195 if (Nkind (gnat_expr) == N_Aggregate
6196 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
6197 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
6198 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
6199 TREE_TYPE (gnu_array_type),
6200 gnat_component_type);
6203 gnu_expr = gnat_to_gnu (gnat_expr);
6205 /* before assigning the element to the array make sure it is
6207 if (Do_Range_Check (gnat_expr))
6208 gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
6212 = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
6215 gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
6218 return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
6221 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
6222 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
6223 of the associations that are from RECORD_TYPE. If we see an internal
6224 record, make a recursive call to fill it in as well. */
6227 extract_values (tree values, tree record_type)
6229 tree result = NULL_TREE;
6232 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
6236 /* _Parent is an internal field, but may have values in the aggregate,
6237 so check for values first. */
6238 if ((tem = purpose_member (field, values)))
6240 value = TREE_VALUE (tem);
6241 TREE_ADDRESSABLE (tem) = 1;
6244 else if (DECL_INTERNAL_P (field))
6246 value = extract_values (values, TREE_TYPE (field));
6247 if (TREE_CODE (value) == CONSTRUCTOR
6248 && VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (value)))
6252 /* If we have a record subtype, the names will match, but not the
6253 actual FIELD_DECLs. */
6254 for (tem = values; tem; tem = TREE_CHAIN (tem))
6255 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
6257 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
6258 TREE_ADDRESSABLE (tem) = 1;
6264 result = tree_cons (field, value, result);
6267 return gnat_build_constructor (record_type, nreverse (result));
6270 /* EXP is to be treated as an array or record. Handle the cases when it is
6271 an access object and perform the required dereferences. */
6274 maybe_implicit_deref (tree exp)
6276 /* If the type is a pointer, dereference it. */
6278 if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
6279 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
6281 /* If we got a padded type, remove it too. */
6282 if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
6283 && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
6284 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
6289 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
6292 protect_multiple_eval (tree exp)
6294 tree type = TREE_TYPE (exp);
6296 /* If this has no side effects, we don't need to do anything. */
6297 if (!TREE_SIDE_EFFECTS (exp))
6300 /* If it is a conversion, protect what's inside the conversion.
6301 Similarly, if we're indirectly referencing something, we only
6302 actually need to protect the address since the data itself can't
6303 change in these situations. */
6304 else if (TREE_CODE (exp) == NON_LVALUE_EXPR
6305 || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
6306 || TREE_CODE (exp) == VIEW_CONVERT_EXPR
6307 || TREE_CODE (exp) == INDIRECT_REF
6308 || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
6309 return build1 (TREE_CODE (exp), type,
6310 protect_multiple_eval (TREE_OPERAND (exp, 0)));
6312 /* If EXP is a fat pointer or something that can be placed into a register,
6313 just make a SAVE_EXPR. */
6314 if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
6315 return save_expr (exp);
6317 /* Otherwise, dereference, protect the address, and re-reference. */
6320 build_unary_op (INDIRECT_REF, type,
6321 save_expr (build_unary_op (ADDR_EXPR,
6322 build_reference_type (type),
6326 /* This is equivalent to stabilize_reference in tree.c, but we know how to
6327 handle our own nodes and we take extra arguments. FORCE says whether to
6328 force evaluation of everything. We set SUCCESS to true unless we walk
6329 through something we don't know how to stabilize. */
6332 maybe_stabilize_reference (tree ref, bool force, bool *success)
6334 tree type = TREE_TYPE (ref);
6335 enum tree_code code = TREE_CODE (ref);
6338 /* Assume we'll success unless proven otherwise. */
6347 /* No action is needed in this case. */
6354 case FIX_TRUNC_EXPR:
6355 case VIEW_CONVERT_EXPR:
6357 = build1 (code, type,
6358 maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6363 case UNCONSTRAINED_ARRAY_REF:
6364 result = build1 (code, type,
6365 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
6370 result = build3 (COMPONENT_REF, type,
6371 maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6373 TREE_OPERAND (ref, 1), NULL_TREE);
6377 result = build3 (BIT_FIELD_REF, type,
6378 maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6380 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
6382 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
6387 case ARRAY_RANGE_REF:
6388 result = build4 (code, type,
6389 maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
6391 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
6393 NULL_TREE, NULL_TREE);
6397 result = gnat_stabilize_reference_1 (ref, force);
6401 /* This generates better code than the scheme in protect_multiple_eval
6402 because large objects will be returned via invisible reference in
6403 most ABIs so the temporary will directly be filled by the callee. */
6404 result = gnat_stabilize_reference_1 (ref, force);
6408 ref = error_mark_node;
6410 /* ... Fallthru to failure ... */
6412 /* If arg isn't a kind of lvalue we recognize, make no change.
6413 Caller should recognize the error for an invalid lvalue. */
6419 TREE_READONLY (result) = TREE_READONLY (ref);
6421 /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
6422 expression may not be sustained across some paths, such as the way via
6423 build1 for INDIRECT_REF. We re-populate those flags here for the general
6424 case, which is consistent with the GCC version of this routine.
6426 Special care should be taken regarding TREE_SIDE_EFFECTS, because some
6427 paths introduce side effects where there was none initially (e.g. calls
6428 to save_expr), and we also want to keep track of that. */
6430 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
6431 TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
6436 /* Wrapper around maybe_stabilize_reference, for common uses without
6437 lvalue restrictions and without need to examine the success
6441 gnat_stabilize_reference (tree ref, bool force)
6444 return maybe_stabilize_reference (ref, force, &dummy);
6447 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
6448 arg to force a SAVE_EXPR for everything. */
6451 gnat_stabilize_reference_1 (tree e, bool force)
6453 enum tree_code code = TREE_CODE (e);
6454 tree type = TREE_TYPE (e);
6457 /* We cannot ignore const expressions because it might be a reference
6458 to a const array but whose index contains side-effects. But we can
6459 ignore things that are actual constant or that already have been
6460 handled by this function. */
6462 if (TREE_CONSTANT (e) || code == SAVE_EXPR)
6465 switch (TREE_CODE_CLASS (code))
6467 case tcc_exceptional:
6469 case tcc_declaration:
6470 case tcc_comparison:
6472 case tcc_expression:
6475 /* If this is a COMPONENT_REF of a fat pointer, save the entire
6476 fat pointer. This may be more efficient, but will also allow
6477 us to more easily find the match for the PLACEHOLDER_EXPR. */
6478 if (code == COMPONENT_REF
6479 && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
6480 result = build3 (COMPONENT_REF, type,
6481 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
6483 TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
6484 else if (TREE_SIDE_EFFECTS (e) || force)
6485 return save_expr (e);
6491 /* Constants need no processing. In fact, we should never reach
6496 /* Recursively stabilize each operand. */
6497 result = build2 (code, type,
6498 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
6499 gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
6504 /* Recursively stabilize each operand. */
6505 result = build1 (code, type,
6506 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
6514 TREE_READONLY (result) = TREE_READONLY (e);
6516 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
6517 TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
6521 extern char *__gnat_to_canonical_file_spec (char *);
6523 /* Convert Sloc into *LOCUS (a location_t). Return true if this Sloc
6524 corresponds to a source code location and false if it doesn't. In the
6525 latter case, we don't update *LOCUS. We also set the Gigi global variable
6526 REF_FILENAME to the reference file name as given by sinput (i.e no
6530 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
6532 /* If node not from source code, ignore. */
6536 /* Use the identifier table to make a hashed, permanent copy of the filename,
6537 since the name table gets reallocated after Gigi returns but before all
6538 the debugging information is output. The __gnat_to_canonical_file_spec
6539 call translates filenames from pragmas Source_Reference that contain host
6540 style syntax not understood by gdb. */
6542 = IDENTIFIER_POINTER
6544 (__gnat_to_canonical_file_spec
6545 (Get_Name_String (Full_Debug_Name (Get_Source_File_Index (Sloc))))));
6547 locus->line = Get_Logical_Line_Number (Sloc);
6550 = IDENTIFIER_POINTER
6552 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
6557 /* Similar to annotate_with_locus, but start with the Sloc of GNAT_NODE and
6558 don't do anything if it doesn't correspond to a source location. */
6561 annotate_with_node (tree node, Node_Id gnat_node)
6565 if (!Sloc_to_locus (Sloc (gnat_node), &locus))
6568 annotate_with_locus (node, locus);
6571 /* Post an error message. MSG is the error message, properly annotated.
6572 NODE is the node at which to post the error and the node to use for the
6573 "&" substitution. */
6576 post_error (const char *msg, Node_Id node)
6578 String_Template temp;
6581 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6582 fp.Array = msg, fp.Bounds = &temp;
6584 Error_Msg_N (fp, node);
6587 /* Similar, but NODE is the node at which to post the error and ENT
6588 is the node to use for the "&" substitution. */
6591 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
6593 String_Template temp;
6596 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6597 fp.Array = msg, fp.Bounds = &temp;
6599 Error_Msg_NE (fp, node, ent);
6602 /* Similar, but NODE is the node at which to post the error, ENT is the node
6603 to use for the "&" substitution, and N is the number to use for the ^. */
6606 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
6608 String_Template temp;
6611 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
6612 fp.Array = msg, fp.Bounds = &temp;
6613 Error_Msg_Uint_1 = UI_From_Int (n);
6616 Error_Msg_NE (fp, node, ent);
6619 /* Similar to post_error_ne_num, but T is a GCC tree representing the
6620 number to write. If the tree represents a constant that fits within
6621 a host integer, the text inside curly brackets in MSG will be output
6622 (presumably including a '^'). Otherwise that text will not be output
6623 and the text inside square brackets will be output instead. */
6626 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
6628 char *newmsg = alloca (strlen (msg) + 1);
6629 String_Template temp = {1, 0};
6631 char start_yes, end_yes, start_no, end_no;
6635 fp.Array = newmsg, fp.Bounds = &temp;
6637 if (host_integerp (t, 1)
6638 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
6641 (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
6645 Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
6646 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
6649 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
6651 for (p = msg, q = newmsg; *p; p++)
6653 if (*p == start_yes)
6654 for (p++; *p != end_yes; p++)
6656 else if (*p == start_no)
6657 for (p++; *p != end_no; p++)
6665 temp.High_Bound = strlen (newmsg);
6667 Error_Msg_NE (fp, node, ent);
6670 /* Similar to post_error_ne_tree, except that NUM is a second
6671 integer to write in the message. */
6674 post_error_ne_tree_2 (const char *msg,
6680 Error_Msg_Uint_2 = UI_From_Int (num);
6681 post_error_ne_tree (msg, node, ent, t);
6684 /* Initialize the table that maps GNAT codes to GCC codes for simple
6685 binary and unary operations. */
6688 init_code_table (void)
6690 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
6691 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
6693 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
6694 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
6695 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
6696 gnu_codes[N_Op_Eq] = EQ_EXPR;
6697 gnu_codes[N_Op_Ne] = NE_EXPR;
6698 gnu_codes[N_Op_Lt] = LT_EXPR;
6699 gnu_codes[N_Op_Le] = LE_EXPR;
6700 gnu_codes[N_Op_Gt] = GT_EXPR;
6701 gnu_codes[N_Op_Ge] = GE_EXPR;
6702 gnu_codes[N_Op_Add] = PLUS_EXPR;
6703 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
6704 gnu_codes[N_Op_Multiply] = MULT_EXPR;
6705 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
6706 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
6707 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
6708 gnu_codes[N_Op_Abs] = ABS_EXPR;
6709 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
6710 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
6711 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
6712 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
6713 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
6714 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
6717 #include "gt-ada-trans.h"
6718 /* Return a label to branch to for the exception type in KIND or NULL_TREE
6722 get_exception_label (char kind)
6724 if (kind == N_Raise_Constraint_Error)
6725 return TREE_VALUE (gnu_constraint_error_label_stack);
6726 else if (kind == N_Raise_Storage_Error)
6727 return TREE_VALUE (gnu_storage_error_label_stack);
6728 else if (kind == N_Raise_Program_Error)
6729 return TREE_VALUE (gnu_program_error_label_stack);
OSDN Git Service
