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)
387 aliased |= Has_Aliased_Components (Etype (Prefix (gnat_node)));
388 return lvalue_required_p (Parent (gnat_node), operand_type, aliased);
391 case N_Selected_Component:
392 aliased |= Is_Aliased (Entity (Selector_Name (gnat_node)));
393 return lvalue_required_p (Parent (gnat_node), operand_type, aliased);
395 case N_Object_Renaming_Declaration:
396 /* We need to make a real renaming only if the constant object is
397 aliased; otherwise we can optimize and return the rvalue. We
398 make an exception if the object is an identifier since in this
399 case the rvalue can be propagated attached to the CONST_DECL. */
400 return aliased || Nkind (Name (gnat_node)) == N_Identifier;
409 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
410 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
411 where we should place the result type. */
414 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
416 tree gnu_result_type;
418 Node_Id gnat_temp, gnat_temp_type;
420 /* Whether the parent of gnat_node requires an lvalue. Needed in
421 specific circumstances only, so evaluated lazily. < 0 means unknown,
422 > 0 means known true, 0 means known false. */
423 int parent_requires_lvalue = -1;
425 /* If GNAT_NODE is a constant, whether we should use the initialization
426 value instead of the constant entity, typically for scalars with an
427 address clause when the parent doesn't require an lvalue. */
428 bool use_constant_initializer = false;
430 /* If the Etype of this node does not equal the Etype of the Entity,
431 something is wrong with the entity map, probably in generic
432 instantiation. However, this does not apply to types. Since we sometime
433 have strange Ekind's, just do this test for objects. Also, if the Etype of
434 the Entity is private, the Etype of the N_Identifier is allowed to be the
435 full type and also we consider a packed array type to be the same as the
436 original type. Similarly, a class-wide type is equivalent to a subtype of
437 itself. Finally, if the types are Itypes, one may be a copy of the other,
438 which is also legal. */
439 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
440 ? gnat_node : Entity (gnat_node));
441 gnat_temp_type = Etype (gnat_temp);
443 gcc_assert (Etype (gnat_node) == gnat_temp_type
444 || (Is_Packed (gnat_temp_type)
445 && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
446 || (Is_Class_Wide_Type (Etype (gnat_node)))
447 || (IN (Ekind (gnat_temp_type), Private_Kind)
448 && Present (Full_View (gnat_temp_type))
449 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
450 || (Is_Packed (Full_View (gnat_temp_type))
451 && (Etype (gnat_node)
452 == Packed_Array_Type (Full_View
453 (gnat_temp_type))))))
454 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
455 || !(Ekind (gnat_temp) == E_Variable
456 || Ekind (gnat_temp) == E_Component
457 || Ekind (gnat_temp) == E_Constant
458 || Ekind (gnat_temp) == E_Loop_Parameter
459 || IN (Ekind (gnat_temp), Formal_Kind)));
461 /* If this is a reference to a deferred constant whose partial view is an
462 unconstrained private type, the proper type is on the full view of the
463 constant, not on the full view of the type, which may be unconstrained.
465 This may be a reference to a type, for example in the prefix of the
466 attribute Position, generated for dispatching code (see Make_DT in
467 exp_disp,adb). In that case we need the type itself, not is parent,
468 in particular if it is a derived type */
469 if (Is_Private_Type (gnat_temp_type)
470 && Has_Unknown_Discriminants (gnat_temp_type)
471 && Ekind (gnat_temp) == E_Constant
472 && Present (Full_View (gnat_temp)))
474 gnat_temp = Full_View (gnat_temp);
475 gnat_temp_type = Etype (gnat_temp);
479 /* We want to use the Actual_Subtype if it has already been elaborated,
480 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
482 if ((Ekind (gnat_temp) == E_Constant
483 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
484 && !(Is_Array_Type (Etype (gnat_temp))
485 && Present (Packed_Array_Type (Etype (gnat_temp))))
486 && Present (Actual_Subtype (gnat_temp))
487 && present_gnu_tree (Actual_Subtype (gnat_temp)))
488 gnat_temp_type = Actual_Subtype (gnat_temp);
490 gnat_temp_type = Etype (gnat_node);
493 /* Expand the type of this identifier first, in case it is an enumeral
494 literal, which only get made when the type is expanded. There is no
495 order-of-elaboration issue here. */
496 gnu_result_type = get_unpadded_type (gnat_temp_type);
498 /* If this is a non-imported scalar constant with an address clause,
499 retrieve the value instead of a pointer to be dereferenced unless the
500 parent requires an lvalue. This is generally more efficient and
501 actually required if this is a static expression because it might be used
502 in a context where a dereference is inappropriate, such as a case
503 statement alternative or a record discriminant. There is no possible
504 volatile-ness shortciruit here since Volatile constants must be imported
506 if (Ekind (gnat_temp) == E_Constant && Is_Scalar_Type (gnat_temp_type)
507 && !Is_Imported (gnat_temp)
508 && Present (Address_Clause (gnat_temp)))
510 parent_requires_lvalue
511 = lvalue_required_p (Parent (gnat_node), gnu_result_type,
512 Is_Aliased (gnat_temp));
513 use_constant_initializer = !parent_requires_lvalue;
516 if (use_constant_initializer)
518 /* If this is a deferred constant, the initializer is attached to the
520 if (Present (Full_View (gnat_temp)))
521 gnat_temp = Full_View (gnat_temp);
523 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
526 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
528 /* If we are in an exception handler, force this variable into memory to
529 ensure optimization does not remove stores that appear redundant but are
530 actually needed in case an exception occurs.
532 ??? Note that we need not do this if the variable is declared within the
533 handler, only if it is referenced in the handler and declared in an
534 enclosing block, but we have no way of testing that right now.
536 ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
537 here, but it can now be removed by the Tree aliasing machinery if the
538 address of the variable is never taken. All we can do is to make the
539 variable volatile, which might incur the generation of temporaries just
540 to access the memory in some circumstances. This can be avoided for
541 variables of non-constant size because they are automatically allocated
542 to memory. There might be no way of allocating a proper temporary for
543 them in any case. We only do this for SJLJ though. */
544 if (TREE_VALUE (gnu_except_ptr_stack)
545 && TREE_CODE (gnu_result) == VAR_DECL
546 && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST)
547 TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
549 /* Some objects (such as parameters passed by reference, globals of
550 variable size, and renamed objects) actually represent the address
551 of the object. In that case, we must do the dereference. Likewise,
552 deal with parameters to foreign convention subprograms. */
553 if (DECL_P (gnu_result)
554 && (DECL_BY_REF_P (gnu_result)
555 || (TREE_CODE (gnu_result) == PARM_DECL
556 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
558 bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
561 if (TREE_CODE (gnu_result) == PARM_DECL
562 && DECL_BY_COMPONENT_PTR_P (gnu_result))
564 = build_unary_op (INDIRECT_REF, NULL_TREE,
565 convert (build_pointer_type (gnu_result_type),
568 /* If it's a renaming pointer and we are at the right binding level,
569 we can reference the renamed object directly, since the renamed
570 expression has been protected against multiple evaluations. */
571 else if (TREE_CODE (gnu_result) == VAR_DECL
572 && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
573 && (! DECL_RENAMING_GLOBAL_P (gnu_result)
574 || global_bindings_p ()))
575 gnu_result = renamed_obj;
577 /* Return the underlying CST for a CONST_DECL like a few lines below,
578 after dereferencing in this case. */
579 else if (TREE_CODE (gnu_result) == CONST_DECL)
580 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
581 DECL_INITIAL (gnu_result));
584 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
586 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
589 /* The GNAT tree has the type of a function as the type of its result. Also
590 use the type of the result if the Etype is a subtype which is nominally
591 unconstrained. But remove any padding from the resulting type. */
592 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
593 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
595 gnu_result_type = TREE_TYPE (gnu_result);
596 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
597 && TYPE_IS_PADDING_P (gnu_result_type))
598 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
601 /* If we have a constant declaration and its initializer at hand,
602 try to return the latter to avoid the need to call fold in lots
603 of places and the need of elaboration code if this Id is used as
604 an initializer itself. */
605 if (TREE_CONSTANT (gnu_result)
606 && DECL_P (gnu_result) && DECL_INITIAL (gnu_result))
609 = (TREE_CODE (gnu_result) == CONST_DECL
610 ? DECL_CONST_CORRESPONDING_VAR (gnu_result) : gnu_result);
612 /* If there is a corresponding variable, we only want to return the CST
613 value if the parent doesn't require an lvalue. Evaluate this now if
614 we have not already done so. */
615 if (object && parent_requires_lvalue < 0)
616 parent_requires_lvalue
617 = lvalue_required_p (Parent (gnat_node), gnu_result_type,
618 Is_Aliased (gnat_temp));
620 if (!object || !parent_requires_lvalue)
621 gnu_result = DECL_INITIAL (gnu_result);
624 *gnu_result_type_p = gnu_result_type;
628 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
629 any statements we generate. */
632 Pragma_to_gnu (Node_Id gnat_node)
635 tree gnu_result = alloc_stmt_list ();
637 /* Check for (and ignore) unrecognized pragma and do nothing if we are just
639 if (type_annotate_only || !Is_Pragma_Name (Chars (gnat_node)))
642 switch (Get_Pragma_Id (Chars (gnat_node)))
644 case Pragma_Inspection_Point:
645 /* Do nothing at top level: all such variables are already viewable. */
646 if (global_bindings_p ())
649 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
651 gnat_temp = Next (gnat_temp))
653 Node_Id gnat_expr = Expression (gnat_temp);
654 tree gnu_expr = gnat_to_gnu (gnat_expr);
656 enum machine_mode mode;
657 tree asm_constraint = NULL_TREE;
658 #ifdef ASM_COMMENT_START
662 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
663 gnu_expr = TREE_OPERAND (gnu_expr, 0);
665 /* Use the value only if it fits into a normal register,
666 otherwise use the address. */
667 mode = TYPE_MODE (TREE_TYPE (gnu_expr));
668 use_address = ((GET_MODE_CLASS (mode) != MODE_INT
669 && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT)
670 || GET_MODE_SIZE (mode) > UNITS_PER_WORD);
673 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
675 #ifdef ASM_COMMENT_START
676 comment = concat (ASM_COMMENT_START,
677 " inspection point: ",
678 Get_Name_String (Chars (gnat_expr)),
679 use_address ? " address" : "",
682 asm_constraint = build_string (strlen (comment), comment);
685 gnu_expr = build4 (ASM_EXPR, void_type_node,
689 (build_tree_list (NULL_TREE,
690 build_string (1, "g")),
691 gnu_expr, NULL_TREE),
693 ASM_VOLATILE_P (gnu_expr) = 1;
694 annotate_with_node (gnu_expr, gnat_node);
695 append_to_statement_list (gnu_expr, &gnu_result);
699 case Pragma_Optimize:
700 switch (Chars (Expression
701 (First (Pragma_Argument_Associations (gnat_node)))))
703 case Name_Time: case Name_Space:
705 post_error ("insufficient -O value?", gnat_node);
710 post_error ("must specify -O0?", gnat_node);
718 case Pragma_Reviewable:
719 if (write_symbols == NO_DEBUG)
720 post_error ("must specify -g?", gnat_node);
726 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
727 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
728 where we should place the result type. ATTRIBUTE is the attribute ID. */
731 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
733 tree gnu_result = error_mark_node;
734 tree gnu_result_type;
736 bool prefix_unused = false;
737 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
738 tree gnu_type = TREE_TYPE (gnu_prefix);
740 /* If the input is a NULL_EXPR, make a new one. */
741 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
743 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
744 return build1 (NULL_EXPR, *gnu_result_type_p,
745 TREE_OPERAND (gnu_prefix, 0));
752 /* These are just conversions until since representation clauses for
753 enumerations are handled in the front end. */
755 bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
757 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
758 gnu_result_type = get_unpadded_type (Etype (gnat_node));
759 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
760 checkp, checkp, true);
766 /* These just add or subject the constant 1. Representation clauses for
767 enumerations are handled in the front-end. */
768 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
769 gnu_result_type = get_unpadded_type (Etype (gnat_node));
771 if (Do_Range_Check (First (Expressions (gnat_node))))
773 gnu_expr = protect_multiple_eval (gnu_expr);
776 (build_binary_op (EQ_EXPR, integer_type_node,
778 attribute == Attr_Pred
779 ? TYPE_MIN_VALUE (gnu_result_type)
780 : TYPE_MAX_VALUE (gnu_result_type)),
781 gnu_expr, CE_Range_Check_Failed);
785 = build_binary_op (attribute == Attr_Pred
786 ? MINUS_EXPR : PLUS_EXPR,
787 gnu_result_type, gnu_expr,
788 convert (gnu_result_type, integer_one_node));
792 case Attr_Unrestricted_Access:
793 /* Conversions don't change something's address but can cause us to miss
794 the COMPONENT_REF case below, so strip them off. */
795 gnu_prefix = remove_conversions (gnu_prefix,
796 !Must_Be_Byte_Aligned (gnat_node));
798 /* If we are taking 'Address of an unconstrained object, this is the
799 pointer to the underlying array. */
800 if (attribute == Attr_Address)
801 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
803 /* ... fall through ... */
806 case Attr_Unchecked_Access:
807 case Attr_Code_Address:
808 gnu_result_type = get_unpadded_type (Etype (gnat_node));
810 = build_unary_op (((attribute == Attr_Address
811 || attribute == Attr_Unrestricted_Access)
812 && !Must_Be_Byte_Aligned (gnat_node))
813 ? ATTR_ADDR_EXPR : ADDR_EXPR,
814 gnu_result_type, gnu_prefix);
816 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
817 don't try to build a trampoline. */
818 if (attribute == Attr_Code_Address)
820 for (gnu_expr = gnu_result;
821 TREE_CODE (gnu_expr) == NOP_EXPR
822 || TREE_CODE (gnu_expr) == CONVERT_EXPR;
823 gnu_expr = TREE_OPERAND (gnu_expr, 0))
824 TREE_CONSTANT (gnu_expr) = 1;
826 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
827 TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
831 case Attr_Pool_Address:
834 tree gnu_ptr = gnu_prefix;
836 gnu_result_type = get_unpadded_type (Etype (gnat_node));
838 /* If this is an unconstrained array, we know the object must have been
839 allocated with the template in front of the object. So compute the
841 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
843 = convert (build_pointer_type
844 (TYPE_OBJECT_RECORD_TYPE
845 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
848 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
849 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
850 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
852 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
853 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
856 size_diffop (size_zero_node, gnu_pos));
857 gnu_byte_offset = fold_build1 (NEGATE_EXPR, sizetype, gnu_byte_offset);
859 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
860 gnu_ptr = build_binary_op (POINTER_PLUS_EXPR, gnu_char_ptr_type,
861 gnu_ptr, gnu_byte_offset);
864 gnu_result = convert (gnu_result_type, gnu_ptr);
869 case Attr_Object_Size:
870 case Attr_Value_Size:
871 case Attr_Max_Size_In_Storage_Elements:
872 gnu_expr = gnu_prefix;
874 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
875 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
876 while (TREE_CODE (gnu_expr) == NOP_EXPR)
877 gnu_expr = TREE_OPERAND (gnu_expr, 0)
880 gnu_prefix = remove_conversions (gnu_prefix, true);
881 prefix_unused = true;
882 gnu_type = TREE_TYPE (gnu_prefix);
884 /* Replace an unconstrained array type with the type of the underlying
885 array. We can't do this with a call to maybe_unconstrained_array
886 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
887 use the record type that will be used to allocate the object and its
889 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
891 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
892 if (attribute != Attr_Max_Size_In_Storage_Elements)
893 gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
896 /* If we're looking for the size of a field, return the field size.
897 Otherwise, if the prefix is an object, or if 'Object_Size or
898 'Max_Size_In_Storage_Elements has been specified, the result is the
899 GCC size of the type. Otherwise, the result is the RM_Size of the
901 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
902 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
903 else if (TREE_CODE (gnu_prefix) != TYPE_DECL
904 || attribute == Attr_Object_Size
905 || attribute == Attr_Max_Size_In_Storage_Elements)
907 /* If this is a padded type, the GCC size isn't relevant to the
908 programmer. Normally, what we want is the RM_Size, which was set
909 from the specified size, but if it was not set, we want the size
910 of the relevant field. Using the MAX of those two produces the
911 right result in all case. Don't use the size of the field if it's
912 a self-referential type, since that's never what's wanted. */
913 if (TREE_CODE (gnu_type) == RECORD_TYPE
914 && TYPE_IS_PADDING_P (gnu_type)
915 && TREE_CODE (gnu_expr) == COMPONENT_REF)
917 gnu_result = rm_size (gnu_type);
918 if (!(CONTAINS_PLACEHOLDER_P
919 (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
921 = size_binop (MAX_EXPR, gnu_result,
922 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
924 else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
926 Node_Id gnat_deref = Prefix (gnat_node);
927 Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
928 tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
929 if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
930 && Present (gnat_actual_subtype))
932 tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
933 gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
934 gnu_actual_obj_type, get_identifier ("SIZE"));
937 gnu_result = TYPE_SIZE (gnu_type);
940 gnu_result = TYPE_SIZE (gnu_type);
943 gnu_result = rm_size (gnu_type);
945 gcc_assert (gnu_result);
947 /* Deal with a self-referential size by returning the maximum size for a
948 type and by qualifying the size with the object for 'Size of an
950 if (CONTAINS_PLACEHOLDER_P (gnu_result))
952 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
953 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr);
955 gnu_result = max_size (gnu_result, true);
958 /* If the type contains a template, subtract its size. */
959 if (TREE_CODE (gnu_type) == RECORD_TYPE
960 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
961 gnu_result = size_binop (MINUS_EXPR, gnu_result,
962 DECL_SIZE (TYPE_FIELDS (gnu_type)));
964 gnu_result_type = get_unpadded_type (Etype (gnat_node));
966 /* Always perform division using unsigned arithmetic as the size cannot
967 be negative, but may be an overflowed positive value. This provides
968 correct results for sizes up to 512 MB.
970 ??? Size should be calculated in storage elements directly. */
972 if (attribute == Attr_Max_Size_In_Storage_Elements)
973 gnu_result = convert (sizetype,
974 fold_build2 (CEIL_DIV_EXPR, bitsizetype,
975 gnu_result, bitsize_unit_node));
979 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
980 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
982 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
983 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
985 gnu_type = TREE_TYPE (gnu_prefix);
986 gnu_result_type = get_unpadded_type (Etype (gnat_node));
987 prefix_unused = true;
989 gnu_result = size_int ((TREE_CODE (gnu_prefix) == COMPONENT_REF
990 ? DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1))
991 : TYPE_ALIGN (gnu_type)) / BITS_PER_UNIT);
996 case Attr_Range_Length:
997 prefix_unused = true;
999 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
1001 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1003 if (attribute == Attr_First)
1004 gnu_result = TYPE_MIN_VALUE (gnu_type);
1005 else if (attribute == Attr_Last)
1006 gnu_result = TYPE_MAX_VALUE (gnu_type);
1010 (MAX_EXPR, get_base_type (gnu_result_type),
1012 (PLUS_EXPR, get_base_type (gnu_result_type),
1013 build_binary_op (MINUS_EXPR,
1014 get_base_type (gnu_result_type),
1015 convert (gnu_result_type,
1016 TYPE_MAX_VALUE (gnu_type)),
1017 convert (gnu_result_type,
1018 TYPE_MIN_VALUE (gnu_type))),
1019 convert (gnu_result_type, integer_one_node)),
1020 convert (gnu_result_type, integer_zero_node));
1025 /* ... fall through ... */
1029 int Dimension = (Present (Expressions (gnat_node))
1030 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
1032 struct parm_attr *pa = NULL;
1033 Entity_Id gnat_param = Empty;
1035 /* Make sure any implicit dereference gets done. */
1036 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1037 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1038 /* We treat unconstrained array IN parameters specially. */
1039 if (Nkind (Prefix (gnat_node)) == N_Identifier
1040 && !Is_Constrained (Etype (Prefix (gnat_node)))
1041 && Ekind (Entity (Prefix (gnat_node))) == E_In_Parameter)
1042 gnat_param = Entity (Prefix (gnat_node));
1043 gnu_type = TREE_TYPE (gnu_prefix);
1044 prefix_unused = true;
1045 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1047 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
1052 for (ndim = 1, gnu_type_temp = gnu_type;
1053 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
1054 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
1055 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
1058 Dimension = ndim + 1 - Dimension;
1061 for (i = 1; i < Dimension; i++)
1062 gnu_type = TREE_TYPE (gnu_type);
1064 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1066 /* When not optimizing, look up the slot associated with the parameter
1067 and the dimension in the cache and create a new one on failure. */
1068 if (!optimize && Present (gnat_param))
1070 for (i = 0; VEC_iterate (parm_attr, f_parm_attr_cache, i, pa); i++)
1071 if (pa->id == gnat_param && pa->dim == Dimension)
1076 pa = GGC_CNEW (struct parm_attr);
1077 pa->id = gnat_param;
1078 pa->dim = Dimension;
1079 VEC_safe_push (parm_attr, gc, f_parm_attr_cache, pa);
1083 /* Return the cached expression or build a new one. */
1084 if (attribute == Attr_First)
1086 if (pa && pa->first)
1088 gnu_result = pa->first;
1093 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1096 else if (attribute == Attr_Last)
1100 gnu_result = pa->last;
1105 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
1108 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
1110 tree gnu_compute_type;
1112 if (pa && pa->length)
1114 gnu_result = pa->length;
1119 = signed_or_unsigned_type_for (0,
1120 get_base_type (gnu_result_type));
1124 (MAX_EXPR, gnu_compute_type,
1126 (PLUS_EXPR, gnu_compute_type,
1128 (MINUS_EXPR, gnu_compute_type,
1129 convert (gnu_compute_type,
1131 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
1132 convert (gnu_compute_type,
1134 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
1135 convert (gnu_compute_type, integer_one_node)),
1136 convert (gnu_compute_type, integer_zero_node));
1139 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1140 handling. Note that these attributes could not have been used on
1141 an unconstrained array type. */
1142 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
1145 /* Cache the expression we have just computed. Since we want to do it
1146 at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1147 create the temporary. */
1151 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
1152 TREE_SIDE_EFFECTS (gnu_result) = 1;
1153 TREE_INVARIANT (gnu_result) = 1;
1154 if (attribute == Attr_First)
1155 pa->first = gnu_result;
1156 else if (attribute == Attr_Last)
1157 pa->last = gnu_result;
1159 pa->length = gnu_result;
1164 case Attr_Bit_Position:
1166 case Attr_First_Bit:
1170 HOST_WIDE_INT bitsize;
1171 HOST_WIDE_INT bitpos;
1173 tree gnu_field_bitpos;
1174 tree gnu_field_offset;
1176 enum machine_mode mode;
1177 int unsignedp, volatilep;
1179 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1180 gnu_prefix = remove_conversions (gnu_prefix, true);
1181 prefix_unused = true;
1183 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1184 the result is 0. Don't allow 'Bit on a bare component, though. */
1185 if (attribute == Attr_Bit
1186 && TREE_CODE (gnu_prefix) != COMPONENT_REF
1187 && TREE_CODE (gnu_prefix) != FIELD_DECL)
1189 gnu_result = integer_zero_node;
1194 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
1195 || (attribute == Attr_Bit_Position
1196 && TREE_CODE (gnu_prefix) == FIELD_DECL));
1198 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
1199 &mode, &unsignedp, &volatilep, false);
1201 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1203 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
1204 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
1206 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
1207 TREE_CODE (gnu_inner) == COMPONENT_REF
1208 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
1209 gnu_inner = TREE_OPERAND (gnu_inner, 0))
1212 = size_binop (PLUS_EXPR, gnu_field_bitpos,
1213 bit_position (TREE_OPERAND (gnu_inner, 1)));
1215 = size_binop (PLUS_EXPR, gnu_field_offset,
1216 byte_position (TREE_OPERAND (gnu_inner, 1)));
1219 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
1221 gnu_field_bitpos = bit_position (gnu_prefix);
1222 gnu_field_offset = byte_position (gnu_prefix);
1226 gnu_field_bitpos = bitsize_zero_node;
1227 gnu_field_offset = size_zero_node;
1233 gnu_result = gnu_field_offset;
1236 case Attr_First_Bit:
1238 gnu_result = size_int (bitpos % BITS_PER_UNIT);
1242 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
1243 gnu_result = size_binop (PLUS_EXPR, gnu_result,
1244 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
1245 gnu_result = size_binop (MINUS_EXPR, gnu_result,
1249 case Attr_Bit_Position:
1250 gnu_result = gnu_field_bitpos;
1254 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1256 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1263 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
1264 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
1266 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1267 gnu_result = build_binary_op (attribute == Attr_Min
1268 ? MIN_EXPR : MAX_EXPR,
1269 gnu_result_type, gnu_lhs, gnu_rhs);
1273 case Attr_Passed_By_Reference:
1274 gnu_result = size_int (default_pass_by_ref (gnu_type)
1275 || must_pass_by_ref (gnu_type));
1276 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1279 case Attr_Component_Size:
1280 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1281 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1283 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1284 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1286 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1287 gnu_type = TREE_TYPE (gnu_prefix);
1289 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1290 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1292 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1293 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1294 gnu_type = TREE_TYPE (gnu_type);
1296 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1298 /* Note this size cannot be self-referential. */
1299 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1300 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1301 prefix_unused = true;
1304 case Attr_Null_Parameter:
1305 /* This is just a zero cast to the pointer type for
1306 our prefix and dereferenced. */
1307 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1309 = build_unary_op (INDIRECT_REF, NULL_TREE,
1310 convert (build_pointer_type (gnu_result_type),
1311 integer_zero_node));
1312 TREE_PRIVATE (gnu_result) = 1;
1315 case Attr_Mechanism_Code:
1318 Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1320 prefix_unused = true;
1321 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1322 if (Present (Expressions (gnat_node)))
1324 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1326 for (gnat_obj = First_Formal (gnat_obj); i > 1;
1327 i--, gnat_obj = Next_Formal (gnat_obj))
1331 code = Mechanism (gnat_obj);
1332 if (code == Default)
1333 code = ((present_gnu_tree (gnat_obj)
1334 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1335 || ((TREE_CODE (get_gnu_tree (gnat_obj))
1337 && (DECL_BY_COMPONENT_PTR_P
1338 (get_gnu_tree (gnat_obj))))))
1339 ? By_Reference : By_Copy);
1340 gnu_result = convert (gnu_result_type, size_int (- code));
1345 /* Say we have an unimplemented attribute. Then set the value to be
1346 returned to be a zero and hope that's something we can convert to the
1347 type of this attribute. */
1348 post_error ("unimplemented attribute", gnat_node);
1349 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1350 gnu_result = integer_zero_node;
1354 /* If this is an attribute where the prefix was unused, force a use of it if
1355 it has a side-effect. But don't do it if the prefix is just an entity
1356 name. However, if an access check is needed, we must do it. See second
1357 example in AARM 11.6(5.e). */
1358 if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1359 && !Is_Entity_Name (Prefix (gnat_node)))
1360 gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1361 gnu_prefix, gnu_result);
1363 *gnu_result_type_p = gnu_result_type;
1367 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1368 to a GCC tree, which is returned. */
1371 Case_Statement_to_gnu (Node_Id gnat_node)
1377 gnu_expr = gnat_to_gnu (Expression (gnat_node));
1378 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1380 /* The range of values in a case statement is determined by the rules in
1381 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1382 of the expression. One exception arises in the case of a simple name that
1383 is parenthesized. This still has the Etype of the name, but since it is
1384 not a name, para 7 does not apply, and we need to go to the base type.
1385 This is the only case where parenthesization affects the dynamic
1386 semantics (i.e. the range of possible values at runtime that is covered
1387 by the others alternative.
1389 Another exception is if the subtype of the expression is non-static. In
1390 that case, we also have to use the base type. */
1391 if (Paren_Count (Expression (gnat_node)) != 0
1392 || !Is_OK_Static_Subtype (Underlying_Type
1393 (Etype (Expression (gnat_node)))))
1394 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1396 /* We build a SWITCH_EXPR that contains the code with interspersed
1397 CASE_LABEL_EXPRs for each label. */
1399 push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ());
1400 start_stmt_group ();
1401 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1402 Present (gnat_when);
1403 gnat_when = Next_Non_Pragma (gnat_when))
1405 Node_Id gnat_choice;
1406 int choices_added = 0;
1408 /* First compile all the different case choices for the current WHEN
1410 for (gnat_choice = First (Discrete_Choices (gnat_when));
1411 Present (gnat_choice); gnat_choice = Next (gnat_choice))
1413 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1415 switch (Nkind (gnat_choice))
1418 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1419 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1422 case N_Subtype_Indication:
1423 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1424 (Constraint (gnat_choice))));
1425 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1426 (Constraint (gnat_choice))));
1430 case N_Expanded_Name:
1431 /* This represents either a subtype range or a static value of
1432 some kind; Ekind says which. */
1433 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1435 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1437 gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1438 gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1442 /* ... fall through ... */
1444 case N_Character_Literal:
1445 case N_Integer_Literal:
1446 gnu_low = gnat_to_gnu (gnat_choice);
1449 case N_Others_Choice:
1456 /* If the case value is a subtype that raises Constraint_Error at
1457 run-time because of a wrong bound, then gnu_low or gnu_high
1458 is not translated into an INTEGER_CST. In such a case, we need
1459 to ensure that the when statement is not added in the tree,
1460 otherwise it will crash the gimplifier. */
1461 if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST)
1462 && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST))
1465 add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
1467 create_artificial_label ()),
1473 /* Push a binding level here in case variables are declared since we want
1474 them to be local to this set of statements instead of the block
1475 containing the Case statement. */
1477 if (choices_added > 0)
1479 add_stmt (build_stmt_group (Statements (gnat_when), true));
1480 add_stmt (build1 (GOTO_EXPR, void_type_node,
1481 TREE_VALUE (gnu_switch_label_stack)));
1485 /* Now emit a definition of the label all the cases branched to. */
1486 add_stmt (build1 (LABEL_EXPR, void_type_node,
1487 TREE_VALUE (gnu_switch_label_stack)));
1488 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
1489 end_stmt_group (), NULL_TREE);
1490 pop_stack (&gnu_switch_label_stack);
1495 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
1496 to a GCC tree, which is returned. */
1499 Loop_Statement_to_gnu (Node_Id gnat_node)
1501 /* ??? It would be nice to use "build" here, but there's no build5. */
1502 tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
1503 NULL_TREE, NULL_TREE, NULL_TREE);
1504 tree gnu_loop_var = NULL_TREE;
1505 Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
1506 tree gnu_cond_expr = NULL_TREE;
1509 TREE_TYPE (gnu_loop_stmt) = void_type_node;
1510 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
1511 LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
1512 annotate_with_node (gnu_loop_stmt, gnat_node);
1514 /* Save the end label of this LOOP_STMT in a stack so that the corresponding
1515 N_Exit_Statement can find it. */
1516 push_stack (&gnu_loop_label_stack, NULL_TREE,
1517 LOOP_STMT_LABEL (gnu_loop_stmt));
1519 /* Set the condition that under which the loop should continue.
1520 For "LOOP .... END LOOP;" the condition is always true. */
1521 if (No (gnat_iter_scheme))
1523 /* The case "WHILE condition LOOP ..... END LOOP;" */
1524 else if (Present (Condition (gnat_iter_scheme)))
1525 LOOP_STMT_TOP_COND (gnu_loop_stmt)
1526 = gnat_to_gnu (Condition (gnat_iter_scheme));
1529 /* We have an iteration scheme. */
1530 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
1531 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
1532 Entity_Id gnat_type = Etype (gnat_loop_var);
1533 tree gnu_type = get_unpadded_type (gnat_type);
1534 tree gnu_low = TYPE_MIN_VALUE (gnu_type);
1535 tree gnu_high = TYPE_MAX_VALUE (gnu_type);
1536 bool reversep = Reverse_Present (gnat_loop_spec);
1537 tree gnu_first = reversep ? gnu_high : gnu_low;
1538 tree gnu_last = reversep ? gnu_low : gnu_high;
1539 enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
1540 tree gnu_base_type = get_base_type (gnu_type);
1541 tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
1542 : TYPE_MAX_VALUE (gnu_base_type));
1544 /* We know the loop variable will not overflow if GNU_LAST is a constant
1545 and is not equal to GNU_LIMIT. If it might overflow, we have to move
1546 the limit test to the end of the loop. In that case, we have to test
1547 for an empty loop outside the loop. */
1548 if (TREE_CODE (gnu_last) != INTEGER_CST
1549 || TREE_CODE (gnu_limit) != INTEGER_CST
1550 || tree_int_cst_equal (gnu_last, gnu_limit))
1553 = build3 (COND_EXPR, void_type_node,
1554 build_binary_op (LE_EXPR, integer_type_node,
1556 NULL_TREE, alloc_stmt_list ());
1557 annotate_with_node (gnu_cond_expr, gnat_loop_spec);
1560 /* Open a new nesting level that will surround the loop to declare the
1561 loop index variable. */
1562 start_stmt_group ();
1565 /* Declare the loop index and set it to its initial value. */
1566 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
1567 if (DECL_BY_REF_P (gnu_loop_var))
1568 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
1570 /* The loop variable might be a padded type, so use `convert' to get a
1571 reference to the inner variable if so. */
1572 gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
1574 /* Set either the top or bottom exit condition as appropriate depending
1575 on whether or not we know an overflow cannot occur. */
1577 LOOP_STMT_BOT_COND (gnu_loop_stmt)
1578 = build_binary_op (NE_EXPR, integer_type_node,
1579 gnu_loop_var, gnu_last);
1581 LOOP_STMT_TOP_COND (gnu_loop_stmt)
1582 = build_binary_op (end_code, integer_type_node,
1583 gnu_loop_var, gnu_last);
1585 LOOP_STMT_UPDATE (gnu_loop_stmt)
1586 = build_binary_op (reversep ? PREDECREMENT_EXPR
1587 : PREINCREMENT_EXPR,
1588 TREE_TYPE (gnu_loop_var),
1590 convert (TREE_TYPE (gnu_loop_var),
1592 annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
1596 /* If the loop was named, have the name point to this loop. In this case,
1597 the association is not a ..._DECL node, but the end label from this
1599 if (Present (Identifier (gnat_node)))
1600 save_gnu_tree (Entity (Identifier (gnat_node)),
1601 LOOP_STMT_LABEL (gnu_loop_stmt), true);
1603 /* Make the loop body into its own block, so any allocated storage will be
1604 released every iteration. This is needed for stack allocation. */
1605 LOOP_STMT_BODY (gnu_loop_stmt)
1606 = build_stmt_group (Statements (gnat_node), true);
1608 /* If we declared a variable, then we are in a statement group for that
1609 declaration. Add the LOOP_STMT to it and make that the "loop". */
1612 add_stmt (gnu_loop_stmt);
1614 gnu_loop_stmt = end_stmt_group ();
1617 /* If we have an outer COND_EXPR, that's our result and this loop is its
1618 "true" statement. Otherwise, the result is the LOOP_STMT. */
1621 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
1622 gnu_result = gnu_cond_expr;
1623 recalculate_side_effects (gnu_cond_expr);
1626 gnu_result = gnu_loop_stmt;
1628 pop_stack (&gnu_loop_label_stack);
1633 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
1634 handler for the current function. */
1636 /* This is implemented by issuing a call to the appropriate VMS specific
1637 builtin. To avoid having VMS specific sections in the global gigi decls
1638 array, we maintain the decls of interest here. We can't declare them
1639 inside the function because we must mark them never to be GC'd, which we
1640 can only do at the global level. */
1642 static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE;
1643 static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE;
1646 establish_gnat_vms_condition_handler (void)
1648 tree establish_stmt;
1650 /* Elaborate the required decls on the first call. Check on the decl for
1651 the gnat condition handler to decide, as this is one we create so we are
1652 sure that it will be non null on subsequent calls. The builtin decl is
1653 looked up so remains null on targets where it is not implemented yet. */
1654 if (gnat_vms_condition_handler_decl == NULL_TREE)
1656 vms_builtin_establish_handler_decl
1658 (get_identifier ("__builtin_establish_vms_condition_handler"));
1660 gnat_vms_condition_handler_decl
1661 = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
1663 build_function_type_list (integer_type_node,
1667 NULL_TREE, 0, 1, 1, 0, Empty);
1670 /* Do nothing if the establish builtin is not available, which might happen
1671 on targets where the facility is not implemented. */
1672 if (vms_builtin_establish_handler_decl == NULL_TREE)
1676 = build_call_1_expr (vms_builtin_establish_handler_decl,
1678 (ADDR_EXPR, NULL_TREE,
1679 gnat_vms_condition_handler_decl));
1681 add_stmt (establish_stmt);
1684 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
1685 don't return anything. */
1688 Subprogram_Body_to_gnu (Node_Id gnat_node)
1690 /* Defining identifier of a parameter to the subprogram. */
1691 Entity_Id gnat_param;
1692 /* The defining identifier for the subprogram body. Note that if a
1693 specification has appeared before for this body, then the identifier
1694 occurring in that specification will also be a defining identifier and all
1695 the calls to this subprogram will point to that specification. */
1696 Entity_Id gnat_subprog_id
1697 = (Present (Corresponding_Spec (gnat_node))
1698 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
1699 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
1700 tree gnu_subprog_decl;
1701 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
1702 tree gnu_subprog_type;
1705 VEC(parm_attr,gc) *cache;
1707 /* If this is a generic object or if it has been eliminated,
1709 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
1710 || Ekind (gnat_subprog_id) == E_Generic_Function
1711 || Is_Eliminated (gnat_subprog_id))
1714 /* If this subprogram acts as its own spec, define it. Otherwise, just get
1715 the already-elaborated tree node. However, if this subprogram had its
1716 elaboration deferred, we will already have made a tree node for it. So
1717 treat it as not being defined in that case. Such a subprogram cannot
1718 have an address clause or a freeze node, so this test is safe, though it
1719 does disable some otherwise-useful error checking. */
1721 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
1722 Acts_As_Spec (gnat_node)
1723 && !present_gnu_tree (gnat_subprog_id));
1725 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
1727 /* Propagate the debug mode. */
1728 if (!Needs_Debug_Info (gnat_subprog_id))
1729 DECL_IGNORED_P (gnu_subprog_decl) = 1;
1731 /* Set the line number in the decl to correspond to that of the body so that
1732 the line number notes are written correctly. */
1733 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
1735 /* Initialize the information structure for the function. */
1736 allocate_struct_function (gnu_subprog_decl);
1737 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language
1738 = GGC_CNEW (struct language_function);
1740 begin_subprog_body (gnu_subprog_decl);
1741 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1743 /* If there are OUT parameters, we need to ensure that the return statement
1744 properly copies them out. We do this by making a new block and converting
1745 any inner return into a goto to a label at the end of the block. */
1746 push_stack (&gnu_return_label_stack, NULL_TREE,
1747 gnu_cico_list ? create_artificial_label () : NULL_TREE);
1749 /* Get a tree corresponding to the code for the subprogram. */
1750 start_stmt_group ();
1753 /* See if there are any parameters for which we don't yet have GCC entities.
1754 These must be for OUT parameters for which we will be making VAR_DECL
1755 nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
1756 entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
1757 the order of the parameters. */
1758 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
1759 Present (gnat_param);
1760 gnat_param = Next_Formal_With_Extras (gnat_param))
1761 if (!present_gnu_tree (gnat_param))
1763 /* Skip any entries that have been already filled in; they must
1764 correspond to IN OUT parameters. */
1765 for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
1766 gnu_cico_list = TREE_CHAIN (gnu_cico_list))
1769 /* Do any needed references for padded types. */
1770 TREE_VALUE (gnu_cico_list)
1771 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
1772 gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
1775 /* On VMS, establish our condition handler to possibly turn a condition into
1776 the corresponding exception if the subprogram has a foreign convention or
1779 To ensure proper execution of local finalizations on condition instances,
1780 we must turn a condition into the corresponding exception even if there
1781 is no applicable Ada handler, and need at least one condition handler per
1782 possible call chain involving GNAT code. OTOH, establishing the handler
1783 has a cost so we want to minimize the number of subprograms into which
1784 this happens. The foreign or exported condition is expected to satisfy
1785 all the constraints. */
1786 if (TARGET_ABI_OPEN_VMS
1787 && (Has_Foreign_Convention (gnat_node) || Is_Exported (gnat_node)))
1788 establish_gnat_vms_condition_handler ();
1790 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
1792 /* Generate the code of the subprogram itself. A return statement will be
1793 present and any OUT parameters will be handled there. */
1794 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
1796 gnu_result = end_stmt_group ();
1798 /* If we populated the parameter attributes cache, we need to make sure
1799 that the cached expressions are evaluated on all possible paths. */
1800 cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache;
1803 struct parm_attr *pa;
1806 start_stmt_group ();
1808 for (i = 0; VEC_iterate (parm_attr, cache, i, pa); i++)
1811 add_stmt (pa->first);
1813 add_stmt (pa->last);
1815 add_stmt (pa->length);
1818 add_stmt (gnu_result);
1819 gnu_result = end_stmt_group ();
1822 /* If we made a special return label, we need to make a block that contains
1823 the definition of that label and the copying to the return value. That
1824 block first contains the function, then the label and copy statement. */
1825 if (TREE_VALUE (gnu_return_label_stack))
1829 start_stmt_group ();
1831 add_stmt (gnu_result);
1832 add_stmt (build1 (LABEL_EXPR, void_type_node,
1833 TREE_VALUE (gnu_return_label_stack)));
1835 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1836 if (list_length (gnu_cico_list) == 1)
1837 gnu_retval = TREE_VALUE (gnu_cico_list);
1839 gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
1842 if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
1843 gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
1846 (build_return_expr (DECL_RESULT (gnu_subprog_decl), gnu_retval),
1849 gnu_result = end_stmt_group ();
1852 pop_stack (&gnu_return_label_stack);
1854 /* Set the end location. */
1856 ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
1857 ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
1858 : Sloc (gnat_node)),
1859 &DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_end_locus);
1861 end_subprog_body (gnu_result);
1863 /* Disconnect the trees for parameters that we made variables for from the
1864 GNAT entities since these are unusable after we end the function. */
1865 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
1866 Present (gnat_param);
1867 gnat_param = Next_Formal_With_Extras (gnat_param))
1868 if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
1869 save_gnu_tree (gnat_param, NULL_TREE, false);
1871 if (DECL_FUNCTION_STUB (gnu_subprog_decl))
1872 build_function_stub (gnu_subprog_decl, gnat_subprog_id);
1874 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
1877 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
1878 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
1879 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
1880 If GNU_TARGET is non-null, this must be a function call and the result
1881 of the call is to be placed into that object. */
1884 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
1887 /* The GCC node corresponding to the GNAT subprogram name. This can either
1888 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
1889 or an indirect reference expression (an INDIRECT_REF node) pointing to a
1891 tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
1892 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
1893 tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
1894 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE,
1896 Entity_Id gnat_formal;
1897 Node_Id gnat_actual;
1898 tree gnu_actual_list = NULL_TREE;
1899 tree gnu_name_list = NULL_TREE;
1900 tree gnu_before_list = NULL_TREE;
1901 tree gnu_after_list = NULL_TREE;
1902 tree gnu_subprog_call;
1904 switch (Nkind (Name (gnat_node)))
1907 case N_Operator_Symbol:
1908 case N_Expanded_Name:
1909 case N_Attribute_Reference:
1910 if (Is_Eliminated (Entity (Name (gnat_node))))
1911 Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
1914 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
1916 /* If we are calling a stubbed function, make this into a raise of
1917 Program_Error. Elaborate all our args first. */
1918 if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
1919 && DECL_STUBBED_P (gnu_subprog_node))
1921 for (gnat_actual = First_Actual (gnat_node);
1922 Present (gnat_actual);
1923 gnat_actual = Next_Actual (gnat_actual))
1924 add_stmt (gnat_to_gnu (gnat_actual));
1928 = build_call_raise (PE_Stubbed_Subprogram_Called, gnat_node,
1929 N_Raise_Program_Error);
1931 if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
1933 *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
1934 return build1 (NULL_EXPR, *gnu_result_type_p, call_expr);
1941 /* If we are calling by supplying a pointer to a target, set up that
1942 pointer as the first argument. Use GNU_TARGET if one was passed;
1943 otherwise, make a target by building a variable of the maximum size
1945 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
1947 tree gnu_real_ret_type
1948 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
1953 = maybe_pad_type (gnu_real_ret_type,
1954 max_size (TYPE_SIZE (gnu_real_ret_type), true),
1955 0, Etype (Name (gnat_node)), "PAD", false,
1958 /* ??? We may be about to create a static temporary if we happen to
1959 be at the global binding level. That's a regression from what
1960 the 3.x back-end would generate in the same situation, but we
1961 don't have a mechanism in Gigi for creating automatic variables
1962 in the elaboration routines. */
1964 = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
1965 NULL, false, false, false, false, NULL,
1970 = tree_cons (NULL_TREE,
1971 build_unary_op (ADDR_EXPR, NULL_TREE,
1972 unchecked_convert (gnu_real_ret_type,
1979 /* The only way we can be making a call via an access type is if Name is an
1980 explicit dereference. In that case, get the list of formal args from the
1981 type the access type is pointing to. Otherwise, get the formals from
1982 entity being called. */
1983 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
1984 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
1985 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
1986 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
1989 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
1991 /* Create the list of the actual parameters as GCC expects it, namely a chain
1992 of TREE_LIST nodes in which the TREE_VALUE field of each node is a
1993 parameter-expression and the TREE_PURPOSE field is null. Skip OUT
1994 parameters not passed by reference and don't need to be copied in. */
1995 for (gnat_actual = First_Actual (gnat_node);
1996 Present (gnat_actual);
1997 gnat_formal = Next_Formal_With_Extras (gnat_formal),
1998 gnat_actual = Next_Actual (gnat_actual))
2001 = (present_gnu_tree (gnat_formal)
2002 ? get_gnu_tree (gnat_formal) : NULL_TREE);
2003 tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
2004 /* We treat a conversion between aggregate types as if it is an
2005 unchecked conversion. */
2006 bool unchecked_convert_p
2007 = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
2008 || (Nkind (gnat_actual) == N_Type_Conversion
2009 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
2010 Node_Id gnat_name = (unchecked_convert_p
2011 ? Expression (gnat_actual) : gnat_actual);
2012 tree gnu_name = gnat_to_gnu (gnat_name);
2013 tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
2016 /* If it's possible we may need to use this expression twice, make sure
2017 than any side-effects are handled via SAVE_EXPRs. Likewise if we need
2018 to force side-effects before the call.
2020 ??? This is more conservative than we need since we don't need to do
2021 this for pass-by-ref with no conversion. If we are passing a
2022 non-addressable Out or In Out parameter by reference, pass the address
2023 of a copy and set up to copy back out after the call. */
2024 if (Ekind (gnat_formal) != E_In_Parameter)
2026 gnu_name = gnat_stabilize_reference (gnu_name, true);
2028 if (!addressable_p (gnu_name)
2030 && (DECL_BY_REF_P (gnu_formal)
2031 || (TREE_CODE (gnu_formal) == PARM_DECL
2032 && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
2033 || (DECL_BY_DESCRIPTOR_P (gnu_formal))))))
2035 tree gnu_copy = gnu_name;
2038 /* If the type is by_reference, a copy is not allowed. */
2039 if (Is_By_Reference_Type (Etype (gnat_formal)))
2041 ("misaligned & cannot be passed by reference", gnat_actual);
2043 /* For users of Starlet we issue a warning because the
2044 interface apparently assumes that by-ref parameters
2045 outlive the procedure invocation. The code still
2046 will not work as intended, but we cannot do much
2047 better since other low-level parts of the back-end
2048 would allocate temporaries at will because of the
2049 misalignment if we did not do so here. */
2051 else if (Is_Valued_Procedure (Entity (Name (gnat_node))))
2054 ("?possible violation of implicit assumption",
2057 ("?made by pragma Import_Valued_Procedure on &",
2058 gnat_actual, Entity (Name (gnat_node)));
2060 ("?because of misalignment of &",
2061 gnat_actual, gnat_formal);
2064 /* Remove any unpadding on the actual and make a copy. But if
2065 the actual is a justified modular type, first convert
2067 if (TREE_CODE (gnu_name) == COMPONENT_REF
2068 && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
2070 && (TYPE_IS_PADDING_P
2071 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
2072 gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
2073 else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
2074 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)))
2075 gnu_name = convert (gnu_name_type, gnu_name);
2077 /* Make a SAVE_EXPR to both properly account for potential side
2078 effects and handle the creation of a temporary copy. Special
2079 code in gnat_gimplify_expr ensures that the same temporary is
2080 used as the actual and copied back after the call. */
2081 gnu_actual = save_expr (gnu_name);
2083 /* Set up to move the copy back to the original. */
2084 gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE,
2085 gnu_copy, gnu_actual);
2086 annotate_with_node (gnu_temp, gnat_actual);
2087 append_to_statement_list (gnu_temp, &gnu_after_list);
2089 /* Account for next statement just below. */
2090 gnu_name = gnu_actual;
2094 /* If this was a procedure call, we may not have removed any padding.
2095 So do it here for the part we will use as an input, if any. */
2096 gnu_actual = gnu_name;
2097 if (Ekind (gnat_formal) != E_Out_Parameter
2098 && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2099 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
2100 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2103 /* Unless this is an In parameter, we must remove any LJM building
2105 if (Ekind (gnat_formal) != E_In_Parameter
2106 && TREE_CODE (gnu_name) == CONSTRUCTOR
2107 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
2108 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
2109 gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
2112 if (Ekind (gnat_formal) != E_Out_Parameter
2113 && !unchecked_convert_p
2114 && Do_Range_Check (gnat_actual))
2115 gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
2117 /* Do any needed conversions. We need only check for unchecked
2118 conversion since normal conversions will be handled by just
2119 converting to the formal type. */
2120 if (unchecked_convert_p)
2123 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
2125 (Nkind (gnat_actual)
2126 == N_Unchecked_Type_Conversion)
2127 && No_Truncation (gnat_actual));
2129 /* One we've done the unchecked conversion, we still must ensure that
2130 the object is in range of the formal's type. */
2131 if (Ekind (gnat_formal) != E_Out_Parameter
2132 && Do_Range_Check (gnat_actual))
2133 gnu_actual = emit_range_check (gnu_actual,
2134 Etype (gnat_formal));
2136 else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2137 /* We may have suppressed a conversion to the Etype of the actual since
2138 the parent is a procedure call. So add the conversion here. */
2139 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2142 if (TREE_CODE (gnu_actual) != SAVE_EXPR)
2143 gnu_actual = convert (gnu_formal_type, gnu_actual);
2145 /* If we have not saved a GCC object for the formal, it means it is an
2146 OUT parameter not passed by reference and that does not need to be
2147 copied in. Otherwise, look at the PARM_DECL to see if it is passed by
2150 && TREE_CODE (gnu_formal) == PARM_DECL && DECL_BY_REF_P (gnu_formal))
2152 if (Ekind (gnat_formal) != E_In_Parameter)
2154 gnu_actual = gnu_name;
2156 /* If we have a padded type, be sure we've removed padding. */
2157 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2158 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
2159 && TREE_CODE (gnu_actual) != SAVE_EXPR)
2160 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
2163 /* If we have the constructed subtype of an aliased object
2164 with an unconstrained nominal subtype, the type of the
2165 actual includes the template, although it is formally
2166 constrained. So we need to convert it back to the real
2167 constructed subtype to retrieve the constrained part
2168 and takes its address. */
2169 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
2170 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
2171 && TREE_CODE (gnu_actual) != SAVE_EXPR
2172 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
2173 && Is_Array_Type (Etype (gnat_actual)))
2174 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
2178 /* Otherwise, if we have a non-addressable COMPONENT_REF of a
2179 variable-size type see if it's doing a unpadding operation. If
2180 so, remove that operation since we have no way of allocating the
2181 required temporary. */
2182 if (TREE_CODE (gnu_actual) == COMPONENT_REF
2183 && !TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2184 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0)))
2186 && TYPE_IS_PADDING_P (TREE_TYPE
2187 (TREE_OPERAND (gnu_actual, 0)))
2188 && !addressable_p (gnu_actual))
2189 gnu_actual = TREE_OPERAND (gnu_actual, 0);
2191 /* For In parameters, gnu_actual might still not be addressable at
2192 this point and we need the creation of a temporary copy since
2193 this is to be passed by ref. Resorting to save_expr to force a
2194 SAVE_EXPR temporary creation here is not guaranteed to work
2195 because the actual might be invariant or readonly without side
2196 effects, so we let the gimplifier process this case. */
2198 /* The symmetry of the paths to the type of an entity is broken here
2199 since arguments don't know that they will be passed by ref. */
2200 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2201 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
2203 else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
2204 && DECL_BY_COMPONENT_PTR_P (gnu_formal))
2206 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
2207 gnu_actual = maybe_implicit_deref (gnu_actual);
2208 gnu_actual = maybe_unconstrained_array (gnu_actual);
2210 if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
2211 && TYPE_IS_PADDING_P (gnu_formal_type))
2213 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
2214 gnu_actual = convert (gnu_formal_type, gnu_actual);
2217 /* Take the address of the object and convert to the proper pointer
2218 type. We'd like to actually compute the address of the beginning
2219 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2220 possibility that the ARRAY_REF might return a constant and we'd be
2221 getting the wrong address. Neither approach is exactly correct,
2222 but this is the most likely to work in all cases. */
2223 gnu_actual = convert (gnu_formal_type,
2224 build_unary_op (ADDR_EXPR, NULL_TREE,
2227 else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
2228 && DECL_BY_DESCRIPTOR_P (gnu_formal))
2230 /* If arg is 'Null_Parameter, pass zero descriptor. */
2231 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
2232 || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
2233 && TREE_PRIVATE (gnu_actual))
2234 gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
2237 gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
2238 fill_vms_descriptor (gnu_actual,
2243 tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
2245 if (Ekind (gnat_formal) != E_In_Parameter)
2246 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
2248 if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL)
2251 /* If this is 'Null_Parameter, pass a zero even though we are
2252 dereferencing it. */
2253 else if (TREE_CODE (gnu_actual) == INDIRECT_REF
2254 && TREE_PRIVATE (gnu_actual)
2255 && host_integerp (gnu_actual_size, 1)
2256 && 0 >= compare_tree_int (gnu_actual_size,
2259 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
2260 convert (gnat_type_for_size
2261 (tree_low_cst (gnu_actual_size, 1),
2266 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
2269 gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
2272 gnu_subprog_call = build_call_list (TREE_TYPE (gnu_subprog_type),
2274 nreverse (gnu_actual_list));
2276 /* If we return by passing a target, the result is the target after the
2277 call. We must not emit the call directly here because this might be
2278 evaluated as part of an expression with conditions to control whether
2279 the call should be emitted or not. */
2280 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
2282 /* Conceptually, what we need is a COMPOUND_EXPR with the call followed
2283 by the target object converted to the proper type. Doing so would
2284 potentially be very inefficient, however, as this expresssion might
2285 end up wrapped into an outer SAVE_EXPR later on, which would incur a
2286 pointless temporary copy of the whole object.
2288 What we do instead is build a COMPOUND_EXPR returning the address of
2289 the target, and then dereference. Wrapping the COMPOUND_EXPR into a
2290 SAVE_EXPR later on then only incurs a pointer copy. */
2292 tree gnu_result_type
2293 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
2296 (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target] */
2298 tree gnu_target_address
2299 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_target);
2302 = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_target_address),
2303 gnu_subprog_call, gnu_target_address);
2306 = unchecked_convert (gnu_result_type,
2307 build_unary_op (INDIRECT_REF, NULL_TREE,
2311 *gnu_result_type_p = gnu_result_type;
2315 /* If it is a function call, the result is the call expression unless
2316 a target is specified, in which case we copy the result into the target
2317 and return the assignment statement. */
2318 else if (Nkind (gnat_node) == N_Function_Call)
2320 gnu_result = gnu_subprog_call;
2322 /* If the function returns an unconstrained array or by reference,
2323 we have to de-dereference the pointer. */
2324 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
2325 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
2326 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2329 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2330 gnu_target, gnu_result);
2332 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
2337 /* If this is the case where the GNAT tree contains a procedure call
2338 but the Ada procedure has copy in copy out parameters, the special
2339 parameter passing mechanism must be used. */
2340 else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
2342 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
2343 in copy out parameters. */
2344 tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
2345 int length = list_length (scalar_return_list);
2351 gnu_subprog_call = save_expr (gnu_subprog_call);
2352 gnu_name_list = nreverse (gnu_name_list);
2354 /* If any of the names had side-effects, ensure they are all
2355 evaluated before the call. */
2356 for (gnu_name = gnu_name_list; gnu_name;
2357 gnu_name = TREE_CHAIN (gnu_name))
2358 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
2359 append_to_statement_list (TREE_VALUE (gnu_name),
2363 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
2364 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
2366 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
2368 for (gnat_actual = First_Actual (gnat_node);
2369 Present (gnat_actual);
2370 gnat_formal = Next_Formal_With_Extras (gnat_formal),
2371 gnat_actual = Next_Actual (gnat_actual))
2372 /* If we are dealing with a copy in copy out parameter, we must
2373 retrieve its value from the record returned in the call. */
2374 if (!(present_gnu_tree (gnat_formal)
2375 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2376 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
2377 || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
2378 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
2379 || (DECL_BY_DESCRIPTOR_P
2380 (get_gnu_tree (gnat_formal))))))))
2381 && Ekind (gnat_formal) != E_In_Parameter)
2383 /* Get the value to assign to this OUT or IN OUT parameter. It is
2384 either the result of the function if there is only a single such
2385 parameter or the appropriate field from the record returned. */
2387 = length == 1 ? gnu_subprog_call
2388 : build_component_ref (gnu_subprog_call, NULL_TREE,
2389 TREE_PURPOSE (scalar_return_list),
2392 /* If the actual is a conversion, get the inner expression, which
2393 will be the real destination, and convert the result to the
2394 type of the actual parameter. */
2396 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
2398 /* If the result is a padded type, remove the padding. */
2399 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
2400 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
2401 gnu_result = convert (TREE_TYPE (TYPE_FIELDS
2402 (TREE_TYPE (gnu_result))),
2405 /* If the actual is a type conversion, the real target object is
2406 denoted by the inner Expression and we need to convert the
2407 result to the associated type.
2409 We also need to convert our gnu assignment target to this type
2410 if the corresponding gnu_name was constructed from the GNAT
2411 conversion node and not from the inner Expression. */
2412 if (Nkind (gnat_actual) == N_Type_Conversion)
2415 = convert_with_check
2416 (Etype (Expression (gnat_actual)), gnu_result,
2417 Do_Overflow_Check (gnat_actual),
2418 Do_Range_Check (Expression (gnat_actual)),
2419 Float_Truncate (gnat_actual));
2421 if (!Is_Composite_Type
2422 (Underlying_Type (Etype (gnat_formal))))
2424 = convert (TREE_TYPE (gnu_result), gnu_actual);
2427 /* Unchecked conversions as actuals for out parameters are not
2428 allowed in user code because they are not variables, but do
2429 occur in front-end expansions. The associated gnu_name is
2430 always obtained from the inner expression in such cases. */
2431 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
2432 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
2434 No_Truncation (gnat_actual));
2437 if (Do_Range_Check (gnat_actual))
2438 gnu_result = emit_range_check (gnu_result,
2439 Etype (gnat_actual));
2441 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
2442 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
2443 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
2446 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
2447 gnu_actual, gnu_result);
2448 annotate_with_node (gnu_result, gnat_actual);
2449 append_to_statement_list (gnu_result, &gnu_before_list);
2450 scalar_return_list = TREE_CHAIN (scalar_return_list);
2451 gnu_name_list = TREE_CHAIN (gnu_name_list);
2456 annotate_with_node (gnu_subprog_call, gnat_node);
2457 append_to_statement_list (gnu_subprog_call, &gnu_before_list);
2460 append_to_statement_list (gnu_after_list, &gnu_before_list);
2461 return gnu_before_list;
2464 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2465 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
2468 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
2470 tree gnu_jmpsave_decl = NULL_TREE;
2471 tree gnu_jmpbuf_decl = NULL_TREE;
2472 /* If just annotating, ignore all EH and cleanups. */
2473 bool gcc_zcx = (!type_annotate_only
2474 && Present (Exception_Handlers (gnat_node))
2475 && Exception_Mechanism == Back_End_Exceptions);
2477 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
2478 && Exception_Mechanism == Setjmp_Longjmp);
2479 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
2480 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
2481 tree gnu_inner_block; /* The statement(s) for the block itself. */
2486 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2487 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
2488 add_cleanup, and when we leave the binding, end_stmt_group will create
2489 the TRY_FINALLY_EXPR.
2491 ??? The region level calls down there have been specifically put in place
2492 for a ZCX context and currently the order in which things are emitted
2493 (region/handlers) is different from the SJLJ case. Instead of putting
2494 other calls with different conditions at other places for the SJLJ case,
2495 it seems cleaner to reorder things for the SJLJ case and generalize the
2496 condition to make it not ZCX specific.
2498 If there are any exceptions or cleanup processing involved, we need an
2499 outer statement group (for Setjmp_Longjmp) and binding level. */
2500 if (binding_for_block)
2502 start_stmt_group ();
2506 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2507 area for address of previous buffer. Do this first since we need to have
2508 the setjmp buf known for any decls in this block. */
2511 gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
2512 NULL_TREE, jmpbuf_ptr_type,
2513 build_call_0_expr (get_jmpbuf_decl),
2514 false, false, false, false, NULL,
2516 DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1;
2518 /* The __builtin_setjmp receivers will immediately reinstall it. Now
2519 because of the unstructured form of EH used by setjmp_longjmp, there
2520 might be forward edges going to __builtin_setjmp receivers on which
2521 it is uninitialized, although they will never be actually taken. */
2522 TREE_NO_WARNING (gnu_jmpsave_decl) = 1;
2523 gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
2524 NULL_TREE, jmpbuf_type,
2525 NULL_TREE, false, false, false, false,
2527 DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1;
2529 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
2531 /* When we exit this block, restore the saved value. */
2532 add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl),
2533 End_Label (gnat_node));
2536 /* If we are to call a function when exiting this block, add a cleanup
2537 to the binding level we made above. Note that add_cleanup is FIFO
2538 so we must register this cleanup after the EH cleanup just above. */
2540 add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))),
2541 End_Label (gnat_node));
2543 /* Now build the tree for the declarations and statements inside this block.
2544 If this is SJLJ, set our jmp_buf as the current buffer. */
2545 start_stmt_group ();
2548 add_stmt (build_call_1_expr (set_jmpbuf_decl,
2549 build_unary_op (ADDR_EXPR, NULL_TREE,
2552 if (Present (First_Real_Statement (gnat_node)))
2553 process_decls (Statements (gnat_node), Empty,
2554 First_Real_Statement (gnat_node), true, true);
2556 /* Generate code for each statement in the block. */
2557 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
2558 ? First_Real_Statement (gnat_node)
2559 : First (Statements (gnat_node)));
2560 Present (gnat_temp); gnat_temp = Next (gnat_temp))
2561 add_stmt (gnat_to_gnu (gnat_temp));
2562 gnu_inner_block = end_stmt_group ();
2564 /* Now generate code for the two exception models, if either is relevant for
2568 tree *gnu_else_ptr = 0;
2571 /* Make a binding level for the exception handling declarations and code
2572 and set up gnu_except_ptr_stack for the handlers to use. */
2573 start_stmt_group ();
2576 push_stack (&gnu_except_ptr_stack, NULL_TREE,
2577 create_var_decl (get_identifier ("EXCEPT_PTR"),
2579 build_pointer_type (except_type_node),
2580 build_call_0_expr (get_excptr_decl), false,
2581 false, false, false, NULL, gnat_node));
2583 /* Generate code for each handler. The N_Exception_Handler case does the
2584 real work and returns a COND_EXPR for each handler, which we chain
2586 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2587 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
2589 gnu_expr = gnat_to_gnu (gnat_temp);
2591 /* If this is the first one, set it as the outer one. Otherwise,
2592 point the "else" part of the previous handler to us. Then point
2593 to our "else" part. */
2595 add_stmt (gnu_expr);
2597 *gnu_else_ptr = gnu_expr;
2599 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
2602 /* If none of the exception handlers did anything, re-raise but do not
2604 gnu_expr = build_call_1_expr (raise_nodefer_decl,
2605 TREE_VALUE (gnu_except_ptr_stack));
2606 annotate_with_node (gnu_expr, gnat_node);
2609 *gnu_else_ptr = gnu_expr;
2611 add_stmt (gnu_expr);
2613 /* End the binding level dedicated to the exception handlers and get the
2614 whole statement group. */
2615 pop_stack (&gnu_except_ptr_stack);
2617 gnu_handler = end_stmt_group ();
2619 /* If the setjmp returns 1, we restore our incoming longjmp value and
2620 then check the handlers. */
2621 start_stmt_group ();
2622 add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
2625 add_stmt (gnu_handler);
2626 gnu_handler = end_stmt_group ();
2628 /* This block is now "if (setjmp) ... <handlers> else <block>". */
2629 gnu_result = build3 (COND_EXPR, void_type_node,
2632 build_unary_op (ADDR_EXPR, NULL_TREE,
2634 gnu_handler, gnu_inner_block);
2640 /* First make a block containing the handlers. */
2641 start_stmt_group ();
2642 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2643 Present (gnat_temp);
2644 gnat_temp = Next_Non_Pragma (gnat_temp))
2645 add_stmt (gnat_to_gnu (gnat_temp));
2646 gnu_handlers = end_stmt_group ();
2648 /* Now make the TRY_CATCH_EXPR for the block. */
2649 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
2650 gnu_inner_block, gnu_handlers);
2653 gnu_result = gnu_inner_block;
2655 /* Now close our outer block, if we had to make one. */
2656 if (binding_for_block)
2658 add_stmt (gnu_result);
2660 gnu_result = end_stmt_group ();
2666 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2667 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
2668 exception handling. */
2671 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
2673 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
2674 an "if" statement to select the proper exceptions. For "Others", exclude
2675 exceptions where Handled_By_Others is nonzero unless the All_Others flag
2676 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
2677 tree gnu_choice = integer_zero_node;
2678 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
2681 for (gnat_temp = First (Exception_Choices (gnat_node));
2682 gnat_temp; gnat_temp = Next (gnat_temp))
2686 if (Nkind (gnat_temp) == N_Others_Choice)
2688 if (All_Others (gnat_temp))
2689 this_choice = integer_one_node;
2693 (EQ_EXPR, integer_type_node,
2698 (INDIRECT_REF, NULL_TREE,
2699 TREE_VALUE (gnu_except_ptr_stack)),
2700 get_identifier ("not_handled_by_others"), NULL_TREE,
2705 else if (Nkind (gnat_temp) == N_Identifier
2706 || Nkind (gnat_temp) == N_Expanded_Name)
2708 Entity_Id gnat_ex_id = Entity (gnat_temp);
2711 /* Exception may be a renaming. Recover original exception which is
2712 the one elaborated and registered. */
2713 if (Present (Renamed_Object (gnat_ex_id)))
2714 gnat_ex_id = Renamed_Object (gnat_ex_id);
2716 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2720 (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
2721 convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
2722 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
2724 /* If this is the distinguished exception "Non_Ada_Error" (and we are
2725 in VMS mode), also allow a non-Ada exception (a VMS condition) t
2727 if (Is_Non_Ada_Error (Entity (gnat_temp)))
2730 = build_component_ref
2731 (build_unary_op (INDIRECT_REF, NULL_TREE,
2732 TREE_VALUE (gnu_except_ptr_stack)),
2733 get_identifier ("lang"), NULL_TREE, false);
2737 (TRUTH_ORIF_EXPR, integer_type_node,
2738 build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
2739 build_int_cst (TREE_TYPE (gnu_comp), 'V')),
2746 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
2747 gnu_choice, this_choice);
2750 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
2753 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2754 to a GCC tree, which is returned. This is the variant for ZCX. */
2757 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
2759 tree gnu_etypes_list = NULL_TREE;
2762 tree gnu_current_exc_ptr;
2763 tree gnu_incoming_exc_ptr;
2766 /* We build a TREE_LIST of nodes representing what exception types this
2767 handler can catch, with special cases for others and all others cases.
2769 Each exception type is actually identified by a pointer to the exception
2770 id, or to a dummy object for "others" and "all others".
2772 Care should be taken to ensure that the control flow impact of "others"
2773 and "all others" is known to GCC. lang_eh_type_covers is doing the trick
2775 for (gnat_temp = First (Exception_Choices (gnat_node));
2776 gnat_temp; gnat_temp = Next (gnat_temp))
2778 if (Nkind (gnat_temp) == N_Others_Choice)
2781 = All_Others (gnat_temp) ? all_others_decl : others_decl;
2784 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2786 else if (Nkind (gnat_temp) == N_Identifier
2787 || Nkind (gnat_temp) == N_Expanded_Name)
2789 Entity_Id gnat_ex_id = Entity (gnat_temp);
2791 /* Exception may be a renaming. Recover original exception which is
2792 the one elaborated and registered. */
2793 if (Present (Renamed_Object (gnat_ex_id)))
2794 gnat_ex_id = Renamed_Object (gnat_ex_id);
2796 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2797 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2799 /* The Non_Ada_Error case for VMS exceptions is handled
2800 by the personality routine. */
2805 /* The GCC interface expects NULL to be passed for catch all handlers, so
2806 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
2807 is integer_zero_node. It would not work, however, because GCC's
2808 notion of "catch all" is stronger than our notion of "others". Until
2809 we correctly use the cleanup interface as well, doing that would
2810 prevent the "all others" handlers from being seen, because nothing
2811 can be caught beyond a catch all from GCC's point of view. */
2812 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
2815 start_stmt_group ();
2818 /* Expand a call to the begin_handler hook at the beginning of the handler,
2819 and arrange for a call to the end_handler hook to occur on every possible
2822 The hooks expect a pointer to the low level occurrence. This is required
2823 for our stack management scheme because a raise inside the handler pushes
2824 a new occurrence on top of the stack, which means that this top does not
2825 necessarily match the occurrence this handler was dealing with.
2827 The EXC_PTR_EXPR object references the exception occurrence being
2828 propagated. Upon handler entry, this is the exception for which the
2829 handler is triggered. This might not be the case upon handler exit,
2830 however, as we might have a new occurrence propagated by the handler's
2831 body, and the end_handler hook called as a cleanup in this context.
2833 We use a local variable to retrieve the incoming value at handler entry
2834 time, and reuse it to feed the end_handler hook's argument at exit. */
2835 gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
2836 gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
2837 ptr_type_node, gnu_current_exc_ptr,
2838 false, false, false, false, NULL,
2841 add_stmt_with_node (build_call_1_expr (begin_handler_decl,
2842 gnu_incoming_exc_ptr),
2844 /* ??? We don't seem to have an End_Label at hand to set the location. */
2845 add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr),
2847 add_stmt_list (Statements (gnat_node));
2850 return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
2854 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
2857 Compilation_Unit_to_gnu (Node_Id gnat_node)
2859 /* Make the decl for the elaboration procedure. */
2860 bool body_p = (Defining_Entity (Unit (gnat_node)),
2861 Nkind (Unit (gnat_node)) == N_Package_Body
2862 || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
2863 Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
2864 tree gnu_elab_proc_decl
2865 = create_subprog_decl
2866 (create_concat_name (gnat_unit_entity,
2867 body_p ? "elabb" : "elabs"),
2868 NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
2870 struct elab_info *info;
2872 push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
2874 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
2875 allocate_struct_function (gnu_elab_proc_decl);
2876 Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
2879 /* For a body, first process the spec if there is one. */
2880 if (Nkind (Unit (gnat_node)) == N_Package_Body
2881 || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
2882 && !Acts_As_Spec (gnat_node)))
2884 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
2885 finalize_from_with_types ();
2888 process_inlined_subprograms (gnat_node);
2890 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
2892 elaborate_all_entities (gnat_node);
2894 if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
2895 || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
2896 || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
2900 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
2902 add_stmt (gnat_to_gnu (Unit (gnat_node)));
2904 /* Process any pragmas and actions following the unit. */
2905 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
2906 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
2907 finalize_from_with_types ();
2909 /* Save away what we've made so far and record this potential elaboration
2911 info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
2912 set_current_block_context (gnu_elab_proc_decl);
2914 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
2915 info->next = elab_info_list;
2916 info->elab_proc = gnu_elab_proc_decl;
2917 info->gnat_node = gnat_node;
2918 elab_info_list = info;
2920 /* Generate elaboration code for this unit, if necessary, and say whether
2922 pop_stack (&gnu_elab_proc_stack);
2924 /* Invalidate the global renaming pointers. This is necessary because
2925 stabilization of the renamed entities may create SAVE_EXPRs which
2926 have been tied to a specific elaboration routine just above. */
2927 invalidate_global_renaming_pointers ();
2930 /* This function is the driver of the GNAT to GCC tree transformation
2931 process. It is the entry point of the tree transformer. GNAT_NODE is the
2932 root of some GNAT tree. Return the root of the corresponding GCC tree.
2933 If this is an expression, return the GCC equivalent of the expression. If
2934 it is a statement, return the statement. In the case when called for a
2935 statement, it may also add statements to the current statement group, in
2936 which case anything it returns is to be interpreted as occurring after
2937 anything `it already added. */
2940 gnat_to_gnu (Node_Id gnat_node)
2942 bool went_into_elab_proc = false;
2943 tree gnu_result = error_mark_node; /* Default to no value. */
2944 tree gnu_result_type = void_type_node;
2946 tree gnu_lhs, gnu_rhs;
2949 /* Save node number for error message and set location information. */
2950 error_gnat_node = gnat_node;
2951 Sloc_to_locus (Sloc (gnat_node), &input_location);
2953 if (type_annotate_only
2954 && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call))
2955 return alloc_stmt_list ();
2957 /* If this node is a non-static subexpression and we are only
2958 annotating types, make this into a NULL_EXPR. */
2959 if (type_annotate_only
2960 && IN (Nkind (gnat_node), N_Subexpr)
2961 && Nkind (gnat_node) != N_Identifier
2962 && !Compile_Time_Known_Value (gnat_node))
2963 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
2964 build_call_raise (CE_Range_Check_Failed, gnat_node,
2965 N_Raise_Constraint_Error));
2967 /* If this is a Statement and we are at top level, it must be part of the
2968 elaboration procedure, so mark us as being in that procedure and push our
2971 If we are in the elaboration procedure, check if we are violating a a
2972 No_Elaboration_Code restriction by having a statement there. */
2973 if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
2974 && Nkind (gnat_node) != N_Null_Statement)
2975 || Nkind (gnat_node) == N_Procedure_Call_Statement
2976 || Nkind (gnat_node) == N_Label
2977 || Nkind (gnat_node) == N_Implicit_Label_Declaration
2978 || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
2979 || ((Nkind (gnat_node) == N_Raise_Constraint_Error
2980 || Nkind (gnat_node) == N_Raise_Storage_Error
2981 || Nkind (gnat_node) == N_Raise_Program_Error)
2982 && (Ekind (Etype (gnat_node)) == E_Void)))
2984 if (!current_function_decl)
2986 current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
2987 start_stmt_group ();
2989 went_into_elab_proc = true;
2992 /* Don't check for a possible No_Elaboration_Code restriction violation
2993 on N_Handled_Sequence_Of_Statements, as we want to signal an error on
2994 every nested real statement instead. This also avoids triggering
2995 spurious errors on dummy (empty) sequences created by the front-end
2996 for package bodies in some cases. */
2998 if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
2999 && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
3000 Check_Elaboration_Code_Allowed (gnat_node);
3003 switch (Nkind (gnat_node))
3005 /********************************/
3006 /* Chapter 2: Lexical Elements: */
3007 /********************************/
3010 case N_Expanded_Name:
3011 case N_Operator_Symbol:
3012 case N_Defining_Identifier:
3013 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
3016 case N_Integer_Literal:
3020 /* Get the type of the result, looking inside any padding and
3021 justified modular types. Then get the value in that type. */
3022 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3024 if (TREE_CODE (gnu_type) == RECORD_TYPE
3025 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
3026 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
3028 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
3030 /* If the result overflows (meaning it doesn't fit in its base type),
3031 abort. We would like to check that the value is within the range
3032 of the subtype, but that causes problems with subtypes whose usage
3033 will raise Constraint_Error and with biased representation, so
3035 gcc_assert (!TREE_OVERFLOW (gnu_result));
3039 case N_Character_Literal:
3040 /* If a Entity is present, it means that this was one of the
3041 literals in a user-defined character type. In that case,
3042 just return the value in the CONST_DECL. Otherwise, use the
3043 character code. In that case, the base type should be an
3044 INTEGER_TYPE, but we won't bother checking for that. */
3045 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3046 if (Present (Entity (gnat_node)))
3047 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
3050 = build_int_cst_type
3051 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node)));
3054 case N_Real_Literal:
3055 /* If this is of a fixed-point type, the value we want is the
3056 value of the corresponding integer. */
3057 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
3059 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3060 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
3062 gcc_assert (!TREE_OVERFLOW (gnu_result));
3065 /* We should never see a Vax_Float type literal, since the front end
3066 is supposed to transform these using appropriate conversions */
3067 else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
3072 Ureal ur_realval = Realval (gnat_node);
3074 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3076 /* If the real value is zero, so is the result. Otherwise,
3077 convert it to a machine number if it isn't already. That
3078 forces BASE to 0 or 2 and simplifies the rest of our logic. */
3079 if (UR_Is_Zero (ur_realval))
3080 gnu_result = convert (gnu_result_type, integer_zero_node);
3083 if (!Is_Machine_Number (gnat_node))
3085 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
3086 ur_realval, Round_Even, gnat_node);
3089 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
3091 /* If we have a base of zero, divide by the denominator.
3092 Otherwise, the base must be 2 and we scale the value, which
3093 we know can fit in the mantissa of the type (hence the use
3094 of that type above). */
3095 if (No (Rbase (ur_realval)))
3097 = build_binary_op (RDIV_EXPR,
3098 get_base_type (gnu_result_type),
3100 UI_To_gnu (Denominator (ur_realval),
3104 REAL_VALUE_TYPE tmp;
3106 gcc_assert (Rbase (ur_realval) == 2);
3107 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
3108 - UI_To_Int (Denominator (ur_realval)));
3109 gnu_result = build_real (gnu_result_type, tmp);
3113 /* Now see if we need to negate the result. Do it this way to
3114 properly handle -0. */
3115 if (UR_Is_Negative (Realval (gnat_node)))
3117 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
3123 case N_String_Literal:
3124 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3125 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
3127 String_Id gnat_string = Strval (gnat_node);
3128 int length = String_Length (gnat_string);
3131 if (length >= ALLOCA_THRESHOLD)
3132 string = xmalloc (length + 1); /* in case of large strings */
3134 string = (char *) alloca (length + 1);
3136 /* Build the string with the characters in the literal. Note
3137 that Ada strings are 1-origin. */
3138 for (i = 0; i < length; i++)
3139 string[i] = Get_String_Char (gnat_string, i + 1);
3141 /* Put a null at the end of the string in case it's in a context
3142 where GCC will want to treat it as a C string. */
3145 gnu_result = build_string (length, string);
3147 /* Strings in GCC don't normally have types, but we want
3148 this to not be converted to the array type. */
3149 TREE_TYPE (gnu_result) = gnu_result_type;
3151 if (length >= ALLOCA_THRESHOLD) /* free if heap-allocated */
3156 /* Build a list consisting of each character, then make
3158 String_Id gnat_string = Strval (gnat_node);
3159 int length = String_Length (gnat_string);
3161 tree gnu_list = NULL_TREE;
3162 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
3164 for (i = 0; i < length; i++)
3167 = tree_cons (gnu_idx,
3168 build_int_cst (TREE_TYPE (gnu_result_type),
3169 Get_String_Char (gnat_string,
3173 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
3178 = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
3183 gnu_result = Pragma_to_gnu (gnat_node);
3186 /**************************************/
3187 /* Chapter 3: Declarations and Types: */
3188 /**************************************/
3190 case N_Subtype_Declaration:
3191 case N_Full_Type_Declaration:
3192 case N_Incomplete_Type_Declaration:
3193 case N_Private_Type_Declaration:
3194 case N_Private_Extension_Declaration:
3195 case N_Task_Type_Declaration:
3196 process_type (Defining_Entity (gnat_node));
3197 gnu_result = alloc_stmt_list ();
3200 case N_Object_Declaration:
3201 case N_Exception_Declaration:
3202 gnat_temp = Defining_Entity (gnat_node);
3203 gnu_result = alloc_stmt_list ();
3205 /* If we are just annotating types and this object has an unconstrained
3206 or task type, don't elaborate it. */
3207 if (type_annotate_only
3208 && (((Is_Array_Type (Etype (gnat_temp))
3209 || Is_Record_Type (Etype (gnat_temp)))
3210 && !Is_Constrained (Etype (gnat_temp)))
3211 || Is_Concurrent_Type (Etype (gnat_temp))))
3214 if (Present (Expression (gnat_node))
3215 && !(Nkind (gnat_node) == N_Object_Declaration
3216 && No_Initialization (gnat_node))
3217 && (!type_annotate_only
3218 || Compile_Time_Known_Value (Expression (gnat_node))))
3220 gnu_expr = gnat_to_gnu (Expression (gnat_node));
3221 if (Do_Range_Check (Expression (gnat_node)))
3222 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
3224 /* If this object has its elaboration delayed, we must force
3225 evaluation of GNU_EXPR right now and save it for when the object
3227 if (Present (Freeze_Node (gnat_temp)))
3229 if ((Is_Public (gnat_temp) || global_bindings_p ())
3230 && !TREE_CONSTANT (gnu_expr))
3232 = create_var_decl (create_concat_name (gnat_temp, "init"),
3233 NULL_TREE, TREE_TYPE (gnu_expr),
3234 gnu_expr, false, Is_Public (gnat_temp),
3235 false, false, NULL, gnat_temp);
3237 gnu_expr = maybe_variable (gnu_expr);
3239 save_gnu_tree (gnat_node, gnu_expr, true);
3243 gnu_expr = NULL_TREE;
3245 if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
3246 gnu_expr = NULL_TREE;
3248 if (No (Freeze_Node (gnat_temp)))
3249 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
3252 case N_Object_Renaming_Declaration:
3253 gnat_temp = Defining_Entity (gnat_node);
3255 /* Don't do anything if this renaming is handled by the front end or if
3256 we are just annotating types and this object has a composite or task
3257 type, don't elaborate it. We return the result in case it has any
OSDN Git Service
