1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2008, 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 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
61 for fear of running out of stack space. If we need more, we use xmalloc
63 #define ALLOCA_THRESHOLD 1000
65 /* Let code below know whether we are targetting VMS without need of
66 intrusive preprocessor directives. */
67 #ifndef TARGET_ABI_OPEN_VMS
68 #define TARGET_ABI_OPEN_VMS 0
71 extern char *__gnat_to_canonical_file_spec (char *);
76 struct Node
*Nodes_Ptr
;
77 Node_Id
*Next_Node_Ptr
;
78 Node_Id
*Prev_Node_Ptr
;
79 struct Elist_Header
*Elists_Ptr
;
80 struct Elmt_Item
*Elmts_Ptr
;
81 struct String_Entry
*Strings_Ptr
;
82 Char_Code
*String_Chars_Ptr
;
83 struct List_Header
*List_Headers_Ptr
;
85 /* Current filename without path. */
86 const char *ref_filename
;
88 /* If true, then gigi is being called on an analyzed but unexpanded
89 tree, and the only purpose of the call is to properly annotate
90 types with representation information. */
91 bool type_annotate_only
;
93 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
94 of unconstrained array IN parameters to avoid emitting a great deal of
95 redundant instructions to recompute them each time. */
96 struct parm_attr
GTY (())
98 int id
; /* GTY doesn't like Entity_Id. */
105 typedef struct parm_attr
*parm_attr
;
107 DEF_VEC_P(parm_attr
);
108 DEF_VEC_ALLOC_P(parm_attr
,gc
);
110 struct language_function
GTY(())
112 VEC(parm_attr
,gc
) *parm_attr_cache
;
115 #define f_parm_attr_cache \
116 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
118 /* A structure used to gather together information about a statement group.
119 We use this to gather related statements, for example the "then" part
120 of a IF. In the case where it represents a lexical scope, we may also
121 have a BLOCK node corresponding to it and/or cleanups. */
123 struct stmt_group
GTY((chain_next ("%h.previous"))) {
124 struct stmt_group
*previous
; /* Previous code group. */
125 tree stmt_list
; /* List of statements for this code group. */
126 tree block
; /* BLOCK for this code group, if any. */
127 tree cleanups
; /* Cleanups for this code group, if any. */
130 static GTY(()) struct stmt_group
*current_stmt_group
;
132 /* List of unused struct stmt_group nodes. */
133 static GTY((deletable
)) struct stmt_group
*stmt_group_free_list
;
135 /* A structure used to record information on elaboration procedures
136 we've made and need to process.
138 ??? gnat_node should be Node_Id, but gengtype gets confused. */
140 struct elab_info
GTY((chain_next ("%h.next"))) {
141 struct elab_info
*next
; /* Pointer to next in chain. */
142 tree elab_proc
; /* Elaboration procedure. */
143 int gnat_node
; /* The N_Compilation_Unit. */
146 static GTY(()) struct elab_info
*elab_info_list
;
148 /* Free list of TREE_LIST nodes used for stacks. */
149 static GTY((deletable
)) tree gnu_stack_free_list
;
151 /* List of TREE_LIST nodes representing a stack of exception pointer
152 variables. TREE_VALUE is the VAR_DECL that stores the address of
153 the raised exception. Nonzero means we are in an exception
154 handler. Not used in the zero-cost case. */
155 static GTY(()) tree gnu_except_ptr_stack
;
157 /* List of TREE_LIST nodes used to store the current elaboration procedure
158 decl. TREE_VALUE is the decl. */
159 static GTY(()) tree gnu_elab_proc_stack
;
161 /* Variable that stores a list of labels to be used as a goto target instead of
162 a return in some functions. See processing for N_Subprogram_Body. */
163 static GTY(()) tree gnu_return_label_stack
;
165 /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
166 TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */
167 static GTY(()) tree gnu_loop_label_stack
;
169 /* List of TREE_LIST nodes representing labels for switch statements.
170 TREE_VALUE of each entry is the label at the end of the switch. */
171 static GTY(()) tree gnu_switch_label_stack
;
173 /* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */
174 static GTY(()) tree gnu_constraint_error_label_stack
;
175 static GTY(()) tree gnu_storage_error_label_stack
;
176 static GTY(()) tree gnu_program_error_label_stack
;
178 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
179 static enum tree_code gnu_codes
[Number_Node_Kinds
];
181 /* Current node being treated, in case abort called. */
182 Node_Id error_gnat_node
;
184 static void init_code_table (void);
185 static void Compilation_Unit_to_gnu (Node_Id
);
186 static void record_code_position (Node_Id
);
187 static void insert_code_for (Node_Id
);
188 static void add_cleanup (tree
, Node_Id
);
189 static tree
mark_visited (tree
*, int *, void *);
190 static tree
unshare_save_expr (tree
*, int *, void *);
191 static void add_stmt_list (List_Id
);
192 static void push_exception_label_stack (tree
*, Entity_Id
);
193 static tree
build_stmt_group (List_Id
, bool);
194 static void push_stack (tree
*, tree
, tree
);
195 static void pop_stack (tree
*);
196 static enum gimplify_status
gnat_gimplify_stmt (tree
*);
197 static void elaborate_all_entities (Node_Id
);
198 static void process_freeze_entity (Node_Id
);
199 static void process_inlined_subprograms (Node_Id
);
200 static void process_decls (List_Id
, List_Id
, Node_Id
, bool, bool);
201 static tree
emit_range_check (tree
, Node_Id
);
202 static tree
emit_index_check (tree
, tree
, tree
, tree
);
203 static tree
emit_check (tree
, tree
, int);
204 static tree
convert_with_check (Entity_Id
, tree
, bool, bool, bool);
205 static bool larger_record_type_p (tree
, tree
);
206 static bool addressable_p (tree
, tree
);
207 static tree
assoc_to_constructor (Entity_Id
, Node_Id
, tree
);
208 static tree
extract_values (tree
, tree
);
209 static tree
pos_to_constructor (Node_Id
, tree
, Entity_Id
);
210 static tree
maybe_implicit_deref (tree
);
211 static tree
gnat_stabilize_reference (tree
, bool);
212 static tree
gnat_stabilize_reference_1 (tree
, bool);
213 static void set_expr_location_from_node (tree
, Node_Id
);
214 static int lvalue_required_p (Node_Id
, tree
, int);
216 /* This is the main program of the back-end. It sets up all the table
217 structures and then generates code. */
220 gigi (Node_Id gnat_root
, int max_gnat_node
, int number_name
,
221 struct Node
*nodes_ptr
, Node_Id
*next_node_ptr
, Node_Id
*prev_node_ptr
,
222 struct Elist_Header
*elists_ptr
, struct Elmt_Item
*elmts_ptr
,
223 struct String_Entry
*strings_ptr
, Char_Code
*string_chars_ptr
,
224 struct List_Header
*list_headers_ptr
, Nat number_file
,
225 struct File_Info_Type
*file_info_ptr ATTRIBUTE_UNUSED
,
226 Entity_Id standard_integer
, Entity_Id standard_long_long_float
,
227 Entity_Id standard_exception_type
, Int gigi_operating_mode
)
229 tree gnu_standard_long_long_float
;
230 tree gnu_standard_exception_type
;
231 struct elab_info
*info
;
232 int i ATTRIBUTE_UNUSED
;
234 max_gnat_nodes
= max_gnat_node
;
235 number_names
= number_name
;
236 number_files
= number_file
;
237 Nodes_Ptr
= nodes_ptr
;
238 Next_Node_Ptr
= next_node_ptr
;
239 Prev_Node_Ptr
= prev_node_ptr
;
240 Elists_Ptr
= elists_ptr
;
241 Elmts_Ptr
= elmts_ptr
;
242 Strings_Ptr
= strings_ptr
;
243 String_Chars_Ptr
= string_chars_ptr
;
244 List_Headers_Ptr
= list_headers_ptr
;
246 type_annotate_only
= (gigi_operating_mode
== 1);
248 for (i
= 0; i
< number_files
; i
++)
250 /* Use the identifier table to make a permanent copy of the filename as
251 the name table gets reallocated after Gigi returns but before all the
252 debugging information is output. The __gnat_to_canonical_file_spec
253 call translates filenames from pragmas Source_Reference that contain
254 host style syntax not understood by gdb. */
258 (__gnat_to_canonical_file_spec
259 (Get_Name_String (file_info_ptr
[i
].File_Name
))));
261 /* We rely on the order isomorphism between files and line maps. */
262 gcc_assert ((int) line_table
->used
== i
);
264 /* We create the line map for a source file at once, with a fixed number
265 of columns chosen to avoid jumping over the next power of 2. */
266 linemap_add (line_table
, LC_ENTER
, 0, filename
, 1);
267 linemap_line_start (line_table
, file_info_ptr
[i
].Num_Source_Lines
, 252);
268 linemap_position_for_column (line_table
, 252 - 1);
269 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
272 /* Initialize ourselves. */
275 gnat_compute_largest_alignment ();
278 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
280 if (type_annotate_only
)
282 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
283 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
286 /* Enable GNAT stack checking method if needed */
287 if (!Stack_Check_Probes_On_Target
)
288 set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode
, "_gnat_stack_check"));
290 /* Give names and make TYPE_DECLs for common types. */
291 create_type_decl (get_identifier (SIZE_TYPE
), sizetype
,
292 NULL
, false, true, Empty
);
293 create_type_decl (get_identifier ("integer"), integer_type_node
,
294 NULL
, false, true, Empty
);
295 create_type_decl (get_identifier ("unsigned char"), char_type_node
,
296 NULL
, false, true, Empty
);
297 create_type_decl (get_identifier ("long integer"), long_integer_type_node
,
298 NULL
, false, true, Empty
);
300 /* Save the type we made for integer as the type for Standard.Integer.
301 Then make the rest of the standard types. Note that some of these
303 save_gnu_tree (Base_Type (standard_integer
), TYPE_NAME (integer_type_node
),
306 gnu_except_ptr_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
307 gnu_constraint_error_label_stack
308 = tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
309 gnu_storage_error_label_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
310 gnu_program_error_label_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
312 gnu_standard_long_long_float
313 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
314 gnu_standard_exception_type
315 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
317 init_gigi_decls (gnu_standard_long_long_float
, gnu_standard_exception_type
);
319 /* Process any Pragma Ident for the main unit. */
320 #ifdef ASM_OUTPUT_IDENT
321 if (Present (Ident_String (Main_Unit
)))
324 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
327 /* If we are using the GCC exception mechanism, let GCC know. */
328 if (Exception_Mechanism
== Back_End_Exceptions
)
331 gcc_assert (Nkind (gnat_root
) == N_Compilation_Unit
);
333 Compilation_Unit_to_gnu (gnat_root
);
335 /* Now see if we have any elaboration procedures to deal with. */
336 for (info
= elab_info_list
; info
; info
= info
->next
)
338 tree gnu_body
= DECL_SAVED_TREE (info
->elab_proc
);
341 /* Unshare SAVE_EXPRs between subprograms. These are not unshared by
342 the gimplifier for obvious reasons, but it turns out that we need to
343 unshare them for the global level because of SAVE_EXPRs made around
344 checks for global objects and around allocators for global objects
345 of variable size, in order to prevent node sharing in the underlying
346 expression. Note that this implicitly assumes that the SAVE_EXPR
347 nodes themselves are not shared between subprograms, which would be
348 an upstream bug for which we would not change the outcome. */
349 walk_tree_without_duplicates (&gnu_body
, unshare_save_expr
, NULL
);
351 /* Set the current function to be the elaboration procedure and gimplify
353 current_function_decl
= info
->elab_proc
;
354 gimplify_body (&gnu_body
, info
->elab_proc
, true);
356 /* We should have a BIND_EXPR, but it may or may not have any statements
357 in it. If it doesn't have any, we have nothing to do. */
358 gnu_stmts
= gnu_body
;
359 if (TREE_CODE (gnu_stmts
) == BIND_EXPR
)
360 gnu_stmts
= BIND_EXPR_BODY (gnu_stmts
);
362 /* If there are no statements, there is no elaboration code. */
363 if (!gnu_stmts
|| !STATEMENT_LIST_HEAD (gnu_stmts
))
365 Set_Has_No_Elaboration_Code (info
->gnat_node
, 1);
366 cgraph_remove_node (cgraph_node (info
->elab_proc
));
370 /* Otherwise, compile the function. Note that we'll be gimplifying
371 it twice, but that's fine for the nodes we use. */
372 begin_subprog_body (info
->elab_proc
);
373 end_subprog_body (gnu_body
);
377 /* We cannot track the location of errors past this point. */
378 error_gnat_node
= Empty
;
381 /* Return a positive value if an lvalue is required for GNAT_NODE.
382 GNU_TYPE is the type that will be used for GNAT_NODE in the
383 translated GNU tree. ALIASED indicates whether the underlying
384 object represented by GNAT_NODE is aliased in the Ada sense.
386 The function climbs up the GNAT tree starting from the node and
387 returns 1 upon encountering a node that effectively requires an
388 lvalue downstream. It returns int instead of bool to facilitate
389 usage in non purely binary logic contexts. */
392 lvalue_required_p (Node_Id gnat_node
, tree gnu_type
, int aliased
)
394 Node_Id gnat_parent
= Parent (gnat_node
), gnat_temp
;
396 switch (Nkind (gnat_parent
))
401 case N_Attribute_Reference
:
403 unsigned char id
= Get_Attribute_Id (Attribute_Name (gnat_parent
));
404 return id
== Attr_Address
406 || id
== Attr_Unchecked_Access
407 || id
== Attr_Unrestricted_Access
;
410 case N_Parameter_Association
:
411 case N_Function_Call
:
412 case N_Procedure_Call_Statement
:
413 return (must_pass_by_ref (gnu_type
) || default_pass_by_ref (gnu_type
));
415 case N_Indexed_Component
:
416 /* Only the array expression can require an lvalue. */
417 if (Prefix (gnat_parent
) != gnat_node
)
420 /* ??? Consider that referencing an indexed component with a
421 non-constant index forces the whole aggregate to memory.
422 Note that N_Integer_Literal is conservative, any static
423 expression in the RM sense could probably be accepted. */
424 for (gnat_temp
= First (Expressions (gnat_parent
));
426 gnat_temp
= Next (gnat_temp
))
427 if (Nkind (gnat_temp
) != N_Integer_Literal
)
430 /* ... fall through ... */
433 /* Only the array expression can require an lvalue. */
434 if (Prefix (gnat_parent
) != gnat_node
)
437 aliased
|= Has_Aliased_Components (Etype (gnat_node
));
438 return lvalue_required_p (gnat_parent
, gnu_type
, aliased
);
440 case N_Selected_Component
:
441 aliased
|= Is_Aliased (Entity (Selector_Name (gnat_parent
)));
442 return lvalue_required_p (gnat_parent
, gnu_type
, aliased
);
444 case N_Object_Renaming_Declaration
:
445 /* We need to make a real renaming only if the constant object is
446 aliased or if we may use a renaming pointer; otherwise we can
447 optimize and return the rvalue. We make an exception if the object
448 is an identifier since in this case the rvalue can be propagated
449 attached to the CONST_DECL. */
451 /* This should match the constant case of the renaming code. */
452 || Is_Composite_Type (Etype (Name (gnat_parent
)))
453 || Nkind (Name (gnat_parent
)) == N_Identifier
);
462 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
463 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
464 to where we should place the result type. */
467 Identifier_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
)
469 Node_Id gnat_temp
, gnat_temp_type
;
470 tree gnu_result
, gnu_result_type
;
472 /* Whether we should require an lvalue for GNAT_NODE. Needed in
473 specific circumstances only, so evaluated lazily. < 0 means
474 unknown, > 0 means known true, 0 means known false. */
475 int require_lvalue
= -1;
477 /* If GNAT_NODE is a constant, whether we should use the initialization
478 value instead of the constant entity, typically for scalars with an
479 address clause when the parent doesn't require an lvalue. */
480 bool use_constant_initializer
= false;
482 /* If the Etype of this node does not equal the Etype of the Entity,
483 something is wrong with the entity map, probably in generic
484 instantiation. However, this does not apply to types. Since we sometime
485 have strange Ekind's, just do this test for objects. Also, if the Etype of
486 the Entity is private, the Etype of the N_Identifier is allowed to be the
487 full type and also we consider a packed array type to be the same as the
488 original type. Similarly, a class-wide type is equivalent to a subtype of
489 itself. Finally, if the types are Itypes, one may be a copy of the other,
490 which is also legal. */
491 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
492 ? gnat_node
: Entity (gnat_node
));
493 gnat_temp_type
= Etype (gnat_temp
);
495 gcc_assert (Etype (gnat_node
) == gnat_temp_type
496 || (Is_Packed (gnat_temp_type
)
497 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
498 || (Is_Class_Wide_Type (Etype (gnat_node
)))
499 || (IN (Ekind (gnat_temp_type
), Private_Kind
)
500 && Present (Full_View (gnat_temp_type
))
501 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
502 || (Is_Packed (Full_View (gnat_temp_type
))
503 && (Etype (gnat_node
)
504 == Packed_Array_Type (Full_View
505 (gnat_temp_type
))))))
506 || (Is_Itype (Etype (gnat_node
)) && Is_Itype (gnat_temp_type
))
507 || !(Ekind (gnat_temp
) == E_Variable
508 || Ekind (gnat_temp
) == E_Component
509 || Ekind (gnat_temp
) == E_Constant
510 || Ekind (gnat_temp
) == E_Loop_Parameter
511 || IN (Ekind (gnat_temp
), Formal_Kind
)));
513 /* If this is a reference to a deferred constant whose partial view is an
514 unconstrained private type, the proper type is on the full view of the
515 constant, not on the full view of the type, which may be unconstrained.
517 This may be a reference to a type, for example in the prefix of the
518 attribute Position, generated for dispatching code (see Make_DT in
519 exp_disp,adb). In that case we need the type itself, not is parent,
520 in particular if it is a derived type */
521 if (Is_Private_Type (gnat_temp_type
)
522 && Has_Unknown_Discriminants (gnat_temp_type
)
523 && Ekind (gnat_temp
) == E_Constant
524 && Present (Full_View (gnat_temp
)))
526 gnat_temp
= Full_View (gnat_temp
);
527 gnat_temp_type
= Etype (gnat_temp
);
531 /* We want to use the Actual_Subtype if it has already been elaborated,
532 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to
534 if ((Ekind (gnat_temp
) == E_Constant
535 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
536 && !(Is_Array_Type (Etype (gnat_temp
))
537 && Present (Packed_Array_Type (Etype (gnat_temp
))))
538 && Present (Actual_Subtype (gnat_temp
))
539 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
540 gnat_temp_type
= Actual_Subtype (gnat_temp
);
542 gnat_temp_type
= Etype (gnat_node
);
545 /* Expand the type of this identifier first, in case it is an enumeral
546 literal, which only get made when the type is expanded. There is no
547 order-of-elaboration issue here. */
548 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
550 /* If this is a non-imported scalar constant with an address clause,
551 retrieve the value instead of a pointer to be dereferenced unless
552 an lvalue is required. This is generally more efficient and actually
553 required if this is a static expression because it might be used
554 in a context where a dereference is inappropriate, such as a case
555 statement alternative or a record discriminant. There is no possible
556 volatile-ness shortciruit here since Volatile constants must be imported
558 if (Ekind (gnat_temp
) == E_Constant
&& Is_Scalar_Type (gnat_temp_type
)
559 && !Is_Imported (gnat_temp
)
560 && Present (Address_Clause (gnat_temp
)))
562 require_lvalue
= lvalue_required_p (gnat_node
, gnu_result_type
,
563 Is_Aliased (gnat_temp
));
564 use_constant_initializer
= !require_lvalue
;
567 if (use_constant_initializer
)
569 /* If this is a deferred constant, the initializer is attached to the
571 if (Present (Full_View (gnat_temp
)))
572 gnat_temp
= Full_View (gnat_temp
);
574 gnu_result
= gnat_to_gnu (Expression (Declaration_Node (gnat_temp
)));
577 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
579 /* If we are in an exception handler, force this variable into memory to
580 ensure optimization does not remove stores that appear redundant but are
581 actually needed in case an exception occurs.
583 ??? Note that we need not do this if the variable is declared within the
584 handler, only if it is referenced in the handler and declared in an
585 enclosing block, but we have no way of testing that right now.
587 ??? We used to essentially set the TREE_ADDRESSABLE flag on the variable
588 here, but it can now be removed by the Tree aliasing machinery if the
589 address of the variable is never taken. All we can do is to make the
590 variable volatile, which might incur the generation of temporaries just
591 to access the memory in some circumstances. This can be avoided for
592 variables of non-constant size because they are automatically allocated
593 to memory. There might be no way of allocating a proper temporary for
594 them in any case. We only do this for SJLJ though. */
595 if (TREE_VALUE (gnu_except_ptr_stack
)
596 && TREE_CODE (gnu_result
) == VAR_DECL
597 && TREE_CODE (DECL_SIZE_UNIT (gnu_result
)) == INTEGER_CST
)
598 TREE_THIS_VOLATILE (gnu_result
) = TREE_SIDE_EFFECTS (gnu_result
) = 1;
600 /* Some objects (such as parameters passed by reference, globals of
601 variable size, and renamed objects) actually represent the address
602 of the object. In that case, we must do the dereference. Likewise,
603 deal with parameters to foreign convention subprograms. */
604 if (DECL_P (gnu_result
)
605 && (DECL_BY_REF_P (gnu_result
)
606 || (TREE_CODE (gnu_result
) == PARM_DECL
607 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
609 bool ro
= DECL_POINTS_TO_READONLY_P (gnu_result
);
612 if (TREE_CODE (gnu_result
) == PARM_DECL
613 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
615 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
616 convert (build_pointer_type (gnu_result_type
),
619 /* If it's a renaming pointer and we are at the right binding level,
620 we can reference the renamed object directly, since the renamed
621 expression has been protected against multiple evaluations. */
622 else if (TREE_CODE (gnu_result
) == VAR_DECL
623 && (renamed_obj
= DECL_RENAMED_OBJECT (gnu_result
)) != 0
624 && (! DECL_RENAMING_GLOBAL_P (gnu_result
)
625 || global_bindings_p ()))
626 gnu_result
= renamed_obj
;
628 /* Return the underlying CST for a CONST_DECL like a few lines below,
629 after dereferencing in this case. */
630 else if (TREE_CODE (gnu_result
) == CONST_DECL
)
631 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
632 DECL_INITIAL (gnu_result
));
635 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
637 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
) = ro
;
640 /* The GNAT tree has the type of a function as the type of its result. Also
641 use the type of the result if the Etype is a subtype which is nominally
642 unconstrained. But remove any padding from the resulting type. */
643 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
644 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
646 gnu_result_type
= TREE_TYPE (gnu_result
);
647 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
648 && TYPE_IS_PADDING_P (gnu_result_type
))
649 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
652 /* If we have a constant declaration and its initializer at hand,
653 try to return the latter to avoid the need to call fold in lots
654 of places and the need of elaboration code if this Id is used as
655 an initializer itself. */
656 if (TREE_CONSTANT (gnu_result
)
657 && DECL_P (gnu_result
)
658 && DECL_INITIAL (gnu_result
))
661 = (TREE_CODE (gnu_result
) == CONST_DECL
662 ? DECL_CONST_CORRESPONDING_VAR (gnu_result
) : gnu_result
);
664 /* If there is a corresponding variable, we only want to return
665 the CST value if an lvalue is not required. Evaluate this
666 now if we have not already done so. */
667 if (object
&& require_lvalue
< 0)
668 require_lvalue
= lvalue_required_p (gnat_node
, gnu_result_type
,
669 Is_Aliased (gnat_temp
));
671 if (!object
|| !require_lvalue
)
672 gnu_result
= unshare_expr (DECL_INITIAL (gnu_result
));
675 *gnu_result_type_p
= gnu_result_type
;
679 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
680 any statements we generate. */
683 Pragma_to_gnu (Node_Id gnat_node
)
686 tree gnu_result
= alloc_stmt_list ();
688 /* Check for (and ignore) unrecognized pragma and do nothing if we are just
690 if (type_annotate_only
691 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node
))))
694 switch (Get_Pragma_Id (Pragma_Identifier (Chars (gnat_node
))))
696 case Pragma_Inspection_Point
:
697 /* Do nothing at top level: all such variables are already viewable. */
698 if (global_bindings_p ())
701 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
703 gnat_temp
= Next (gnat_temp
))
705 Node_Id gnat_expr
= Expression (gnat_temp
);
706 tree gnu_expr
= gnat_to_gnu (gnat_expr
);
708 enum machine_mode mode
;
709 tree asm_constraint
= NULL_TREE
;
710 #ifdef ASM_COMMENT_START
714 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
715 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
717 /* Use the value only if it fits into a normal register,
718 otherwise use the address. */
719 mode
= TYPE_MODE (TREE_TYPE (gnu_expr
));
720 use_address
= ((GET_MODE_CLASS (mode
) != MODE_INT
721 && GET_MODE_CLASS (mode
) != MODE_PARTIAL_INT
)
722 || GET_MODE_SIZE (mode
) > UNITS_PER_WORD
);
725 gnu_expr
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
727 #ifdef ASM_COMMENT_START
728 comment
= concat (ASM_COMMENT_START
,
729 " inspection point: ",
730 Get_Name_String (Chars (gnat_expr
)),
731 use_address
? " address" : "",
734 asm_constraint
= build_string (strlen (comment
), comment
);
737 gnu_expr
= build4 (ASM_EXPR
, void_type_node
,
741 (build_tree_list (NULL_TREE
,
742 build_string (1, "g")),
743 gnu_expr
, NULL_TREE
),
745 ASM_VOLATILE_P (gnu_expr
) = 1;
746 set_expr_location_from_node (gnu_expr
, gnat_node
);
747 append_to_statement_list (gnu_expr
, &gnu_result
);
751 case Pragma_Optimize
:
752 switch (Chars (Expression
753 (First (Pragma_Argument_Associations (gnat_node
)))))
755 case Name_Time
: case Name_Space
:
757 post_error ("insufficient -O value?", gnat_node
);
762 post_error ("must specify -O0?", gnat_node
);
770 case Pragma_Reviewable
:
771 if (write_symbols
== NO_DEBUG
)
772 post_error ("must specify -g?", gnat_node
);
778 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
779 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
780 where we should place the result type. ATTRIBUTE is the attribute ID. */
783 Attribute_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, int attribute
)
785 tree gnu_result
= error_mark_node
;
786 tree gnu_result_type
;
788 bool prefix_unused
= false;
789 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
790 tree gnu_type
= TREE_TYPE (gnu_prefix
);
792 /* If the input is a NULL_EXPR, make a new one. */
793 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
795 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
796 return build1 (NULL_EXPR
, *gnu_result_type_p
,
797 TREE_OPERAND (gnu_prefix
, 0));
804 /* These are just conversions until since representation clauses for
805 enumerations are handled in the front end. */
807 bool checkp
= Do_Range_Check (First (Expressions (gnat_node
)));
809 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
810 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
811 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
812 checkp
, checkp
, true);
818 /* These just add or subject the constant 1. Representation clauses for
819 enumerations are handled in the front-end. */
820 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
821 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
823 if (Do_Range_Check (First (Expressions (gnat_node
))))
825 gnu_expr
= protect_multiple_eval (gnu_expr
);
828 (build_binary_op (EQ_EXPR
, integer_type_node
,
830 attribute
== Attr_Pred
831 ? TYPE_MIN_VALUE (gnu_result_type
)
832 : TYPE_MAX_VALUE (gnu_result_type
)),
833 gnu_expr
, CE_Range_Check_Failed
);
837 = build_binary_op (attribute
== Attr_Pred
838 ? MINUS_EXPR
: PLUS_EXPR
,
839 gnu_result_type
, gnu_expr
,
840 convert (gnu_result_type
, integer_one_node
));
844 case Attr_Unrestricted_Access
:
845 /* Conversions don't change something's address but can cause us to miss
846 the COMPONENT_REF case below, so strip them off. */
847 gnu_prefix
= remove_conversions (gnu_prefix
,
848 !Must_Be_Byte_Aligned (gnat_node
));
850 /* If we are taking 'Address of an unconstrained object, this is the
851 pointer to the underlying array. */
852 if (attribute
== Attr_Address
)
853 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
855 /* ... fall through ... */
858 case Attr_Unchecked_Access
:
859 case Attr_Code_Address
:
860 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
862 = build_unary_op (((attribute
== Attr_Address
863 || attribute
== Attr_Unrestricted_Access
)
864 && !Must_Be_Byte_Aligned (gnat_node
))
865 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
866 gnu_result_type
, gnu_prefix
);
868 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
869 don't try to build a trampoline. */
870 if (attribute
== Attr_Code_Address
)
872 for (gnu_expr
= gnu_result
;
873 TREE_CODE (gnu_expr
) == NOP_EXPR
874 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
875 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
876 TREE_CONSTANT (gnu_expr
) = 1;
878 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
879 TREE_STATIC (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
882 /* For other address attributes applied to a nested function,
883 find an inner ADDR_EXPR and annotate it so that we can issue
884 a useful warning with -Wtrampolines. */
885 else if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == FUNCTION_TYPE
)
887 for (gnu_expr
= gnu_result
;
888 TREE_CODE (gnu_expr
) == NOP_EXPR
889 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
890 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
893 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
894 && decl_function_context (TREE_OPERAND (gnu_expr
, 0)))
896 set_expr_location_from_node (gnu_expr
, gnat_node
);
898 /* Check that we're not violating the No_Implicit_Dynamic_Code
899 restriction. Be conservative if we don't know anything
900 about the trampoline strategy for the target. */
901 Check_Implicit_Dynamic_Code_Allowed (gnat_node
);
906 case Attr_Pool_Address
:
909 tree gnu_ptr
= gnu_prefix
;
911 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
913 /* If this is an unconstrained array, we know the object must have been
914 allocated with the template in front of the object. So compute the
916 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
918 = convert (build_pointer_type
919 (TYPE_OBJECT_RECORD_TYPE
920 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
923 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
924 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
925 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
927 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
928 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
931 size_diffop (size_zero_node
, gnu_pos
));
932 gnu_byte_offset
= fold_build1 (NEGATE_EXPR
, sizetype
, gnu_byte_offset
);
934 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
935 gnu_ptr
= build_binary_op (POINTER_PLUS_EXPR
, gnu_char_ptr_type
,
936 gnu_ptr
, gnu_byte_offset
);
939 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
944 case Attr_Object_Size
:
945 case Attr_Value_Size
:
946 case Attr_Max_Size_In_Storage_Elements
:
947 gnu_expr
= gnu_prefix
;
949 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
950 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
951 while (TREE_CODE (gnu_expr
) == NOP_EXPR
)
952 gnu_expr
= TREE_OPERAND (gnu_expr
, 0)
955 gnu_prefix
= remove_conversions (gnu_prefix
, true);
956 prefix_unused
= true;
957 gnu_type
= TREE_TYPE (gnu_prefix
);
959 /* Replace an unconstrained array type with the type of the underlying
960 array. We can't do this with a call to maybe_unconstrained_array
961 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
962 use the record type that will be used to allocate the object and its
964 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
966 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
967 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
968 gnu_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)));
971 /* If we're looking for the size of a field, return the field size.
972 Otherwise, if the prefix is an object, or if 'Object_Size or
973 'Max_Size_In_Storage_Elements has been specified, the result is the
974 GCC size of the type. Otherwise, the result is the RM_Size of the
976 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
977 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
978 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
979 || attribute
== Attr_Object_Size
980 || attribute
== Attr_Max_Size_In_Storage_Elements
)
982 /* If this is a padded type, the GCC size isn't relevant to the
983 programmer. Normally, what we want is the RM_Size, which was set
984 from the specified size, but if it was not set, we want the size
985 of the relevant field. Using the MAX of those two produces the
986 right result in all case. Don't use the size of the field if it's
987 a self-referential type, since that's never what's wanted. */
988 if (TREE_CODE (gnu_type
) == RECORD_TYPE
989 && TYPE_IS_PADDING_P (gnu_type
)
990 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
992 gnu_result
= rm_size (gnu_type
);
993 if (!(CONTAINS_PLACEHOLDER_P
994 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)))))
996 = size_binop (MAX_EXPR
, gnu_result
,
997 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
999 else if (Nkind (Prefix (gnat_node
)) == N_Explicit_Dereference
)
1001 Node_Id gnat_deref
= Prefix (gnat_node
);
1002 Node_Id gnat_actual_subtype
= Actual_Designated_Subtype (gnat_deref
);
1003 tree gnu_ptr_type
= TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref
)));
1004 if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type
)
1005 && Present (gnat_actual_subtype
))
1007 tree gnu_actual_obj_type
= gnat_to_gnu_type (gnat_actual_subtype
);
1008 gnu_type
= build_unc_object_type_from_ptr (gnu_ptr_type
,
1009 gnu_actual_obj_type
, get_identifier ("SIZE"));
1012 gnu_result
= TYPE_SIZE (gnu_type
);
1015 gnu_result
= TYPE_SIZE (gnu_type
);
1018 gnu_result
= rm_size (gnu_type
);
1020 gcc_assert (gnu_result
);
1022 /* Deal with a self-referential size by returning the maximum size for a
1023 type and by qualifying the size with the object for 'Size of an
1025 if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1027 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1028 gnu_result
= substitute_placeholder_in_expr (gnu_result
, gnu_expr
);
1030 gnu_result
= max_size (gnu_result
, true);
1033 /* If the type contains a template, subtract its size. */
1034 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1035 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1036 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1037 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1039 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1041 /* Always perform division using unsigned arithmetic as the size cannot
1042 be negative, but may be an overflowed positive value. This provides
1043 correct results for sizes up to 512 MB.
1045 ??? Size should be calculated in storage elements directly. */
1047 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1048 gnu_result
= convert (sizetype
,
1049 fold_build2 (CEIL_DIV_EXPR
, bitsizetype
,
1050 gnu_result
, bitsize_unit_node
));
1053 case Attr_Alignment
:
1054 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1055 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1057 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1058 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1060 gnu_type
= TREE_TYPE (gnu_prefix
);
1061 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1062 prefix_unused
= true;
1064 gnu_result
= size_int ((TREE_CODE (gnu_prefix
) == COMPONENT_REF
1065 ? DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1))
1066 : TYPE_ALIGN (gnu_type
)) / BITS_PER_UNIT
);
1071 case Attr_Range_Length
:
1072 prefix_unused
= true;
1074 if (INTEGRAL_TYPE_P (gnu_type
) || TREE_CODE (gnu_type
) == REAL_TYPE
)
1076 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1078 if (attribute
== Attr_First
)
1079 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1080 else if (attribute
== Attr_Last
)
1081 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1085 (MAX_EXPR
, get_base_type (gnu_result_type
),
1087 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1088 build_binary_op (MINUS_EXPR
,
1089 get_base_type (gnu_result_type
),
1090 convert (gnu_result_type
,
1091 TYPE_MAX_VALUE (gnu_type
)),
1092 convert (gnu_result_type
,
1093 TYPE_MIN_VALUE (gnu_type
))),
1094 convert (gnu_result_type
, integer_one_node
)),
1095 convert (gnu_result_type
, integer_zero_node
));
1100 /* ... fall through ... */
1104 int Dimension
= (Present (Expressions (gnat_node
))
1105 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1107 struct parm_attr
*pa
= NULL
;
1108 Entity_Id gnat_param
= Empty
;
1110 /* Make sure any implicit dereference gets done. */
1111 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1112 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1113 /* We treat unconstrained array In parameters specially. */
1114 if (Nkind (Prefix (gnat_node
)) == N_Identifier
1115 && !Is_Constrained (Etype (Prefix (gnat_node
)))
1116 && Ekind (Entity (Prefix (gnat_node
))) == E_In_Parameter
)
1117 gnat_param
= Entity (Prefix (gnat_node
));
1118 gnu_type
= TREE_TYPE (gnu_prefix
);
1119 prefix_unused
= true;
1120 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1122 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1127 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1128 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1129 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1130 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1133 Dimension
= ndim
+ 1 - Dimension
;
1136 for (i
= 1; i
< Dimension
; i
++)
1137 gnu_type
= TREE_TYPE (gnu_type
);
1139 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
1141 /* When not optimizing, look up the slot associated with the parameter
1142 and the dimension in the cache and create a new one on failure. */
1143 if (!optimize
&& Present (gnat_param
))
1145 for (i
= 0; VEC_iterate (parm_attr
, f_parm_attr_cache
, i
, pa
); i
++)
1146 if (pa
->id
== gnat_param
&& pa
->dim
== Dimension
)
1151 pa
= GGC_CNEW (struct parm_attr
);
1152 pa
->id
= gnat_param
;
1153 pa
->dim
= Dimension
;
1154 VEC_safe_push (parm_attr
, gc
, f_parm_attr_cache
, pa
);
1158 /* Return the cached expression or build a new one. */
1159 if (attribute
== Attr_First
)
1161 if (pa
&& pa
->first
)
1163 gnu_result
= pa
->first
;
1168 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1171 else if (attribute
== Attr_Last
)
1175 gnu_result
= pa
->last
;
1180 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1183 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
1185 if (pa
&& pa
->length
)
1187 gnu_result
= pa
->length
;
1192 tree gnu_compute_type
1193 = signed_or_unsigned_type_for
1194 (0, get_base_type (gnu_result_type
));
1197 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
));
1199 = convert (gnu_compute_type
, TYPE_MIN_VALUE (index_type
));
1201 = convert (gnu_compute_type
, TYPE_MAX_VALUE (index_type
));
1203 /* We used to compute the length as max (hb - lb + 1, 0),
1204 which could overflow for some cases of empty arrays, e.g.
1205 when lb == index_type'first.
1207 We now compute it as (hb < lb) ? 0 : hb - lb + 1, which
1208 could overflow as well, but only for extremely large arrays
1209 which we expect never to encounter in practice. */
1213 (COND_EXPR
, gnu_compute_type
,
1214 build_binary_op (LT_EXPR
, gnu_compute_type
, hb
, lb
),
1215 convert (gnu_compute_type
, integer_zero_node
),
1217 (PLUS_EXPR
, gnu_compute_type
,
1218 build_binary_op (MINUS_EXPR
, gnu_compute_type
, hb
, lb
),
1219 convert (gnu_compute_type
, integer_one_node
)));
1223 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
1224 handling. Note that these attributes could not have been used on
1225 an unconstrained array type. */
1226 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
,
1229 /* Cache the expression we have just computed. Since we want to do it
1230 at runtime, we force the use of a SAVE_EXPR and let the gimplifier
1231 create the temporary. */
1235 = build1 (SAVE_EXPR
, TREE_TYPE (gnu_result
), gnu_result
);
1236 TREE_SIDE_EFFECTS (gnu_result
) = 1;
1237 TREE_INVARIANT (gnu_result
) = 1;
1238 if (attribute
== Attr_First
)
1239 pa
->first
= gnu_result
;
1240 else if (attribute
== Attr_Last
)
1241 pa
->last
= gnu_result
;
1243 pa
->length
= gnu_result
;
1248 case Attr_Bit_Position
:
1250 case Attr_First_Bit
:
1254 HOST_WIDE_INT bitsize
;
1255 HOST_WIDE_INT bitpos
;
1257 tree gnu_field_bitpos
;
1258 tree gnu_field_offset
;
1260 enum machine_mode mode
;
1261 int unsignedp
, volatilep
;
1263 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1264 gnu_prefix
= remove_conversions (gnu_prefix
, true);
1265 prefix_unused
= true;
1267 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
1268 the result is 0. Don't allow 'Bit on a bare component, though. */
1269 if (attribute
== Attr_Bit
1270 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1271 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1273 gnu_result
= integer_zero_node
;
1278 gcc_assert (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1279 || (attribute
== Attr_Bit_Position
1280 && TREE_CODE (gnu_prefix
) == FIELD_DECL
));
1282 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1283 &mode
, &unsignedp
, &volatilep
, false);
1285 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1287 gnu_field_bitpos
= bit_position (TREE_OPERAND (gnu_prefix
, 1));
1288 gnu_field_offset
= byte_position (TREE_OPERAND (gnu_prefix
, 1));
1290 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1291 TREE_CODE (gnu_inner
) == COMPONENT_REF
1292 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1293 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1296 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1297 bit_position (TREE_OPERAND (gnu_inner
, 1)));
1299 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1300 byte_position (TREE_OPERAND (gnu_inner
, 1)));
1303 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1305 gnu_field_bitpos
= bit_position (gnu_prefix
);
1306 gnu_field_offset
= byte_position (gnu_prefix
);
1310 gnu_field_bitpos
= bitsize_zero_node
;
1311 gnu_field_offset
= size_zero_node
;
1317 gnu_result
= gnu_field_offset
;
1320 case Attr_First_Bit
:
1322 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1326 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1327 gnu_result
= size_binop (PLUS_EXPR
, gnu_result
,
1328 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1329 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1333 case Attr_Bit_Position
:
1334 gnu_result
= gnu_field_bitpos
;
1338 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1340 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
, gnu_prefix
);
1347 tree gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1348 tree gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1350 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1351 gnu_result
= build_binary_op (attribute
== Attr_Min
1352 ? MIN_EXPR
: MAX_EXPR
,
1353 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1357 case Attr_Passed_By_Reference
:
1358 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1359 || must_pass_by_ref (gnu_type
));
1360 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1363 case Attr_Component_Size
:
1364 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1365 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1367 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1368 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1370 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1371 gnu_type
= TREE_TYPE (gnu_prefix
);
1373 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1374 gnu_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1376 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1377 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1378 gnu_type
= TREE_TYPE (gnu_type
);
1380 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
1382 /* Note this size cannot be self-referential. */
1383 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1384 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1385 prefix_unused
= true;
1388 case Attr_Null_Parameter
:
1389 /* This is just a zero cast to the pointer type for
1390 our prefix and dereferenced. */
1391 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1393 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1394 convert (build_pointer_type (gnu_result_type
),
1395 integer_zero_node
));
1396 TREE_PRIVATE (gnu_result
) = 1;
1399 case Attr_Mechanism_Code
:
1402 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1404 prefix_unused
= true;
1405 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1406 if (Present (Expressions (gnat_node
)))
1408 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1410 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1411 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1415 code
= Mechanism (gnat_obj
);
1416 if (code
== Default
)
1417 code
= ((present_gnu_tree (gnat_obj
)
1418 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1419 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
1421 && (DECL_BY_COMPONENT_PTR_P
1422 (get_gnu_tree (gnat_obj
))))))
1423 ? By_Reference
: By_Copy
);
1424 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1429 /* Say we have an unimplemented attribute. Then set the value to be
1430 returned to be a zero and hope that's something we can convert to the
1431 type of this attribute. */
1432 post_error ("unimplemented attribute", gnat_node
);
1433 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1434 gnu_result
= integer_zero_node
;
1438 /* If this is an attribute where the prefix was unused, force a use of it if
1439 it has a side-effect. But don't do it if the prefix is just an entity
1440 name. However, if an access check is needed, we must do it. See second
1441 example in AARM 11.6(5.e). */
1442 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
)
1443 && !Is_Entity_Name (Prefix (gnat_node
)))
1444 gnu_result
= fold_build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_result
),
1445 gnu_prefix
, gnu_result
);
1447 *gnu_result_type_p
= gnu_result_type
;
1451 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1452 to a GCC tree, which is returned. */
1455 Case_Statement_to_gnu (Node_Id gnat_node
)
1461 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
1462 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
1464 /* The range of values in a case statement is determined by the rules in
1465 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1466 of the expression. One exception arises in the case of a simple name that
1467 is parenthesized. This still has the Etype of the name, but since it is
1468 not a name, para 7 does not apply, and we need to go to the base type.
1469 This is the only case where parenthesization affects the dynamic
1470 semantics (i.e. the range of possible values at runtime that is covered
1471 by the others alternative.
1473 Another exception is if the subtype of the expression is non-static. In
1474 that case, we also have to use the base type. */
1475 if (Paren_Count (Expression (gnat_node
)) != 0
1476 || !Is_OK_Static_Subtype (Underlying_Type
1477 (Etype (Expression (gnat_node
)))))
1478 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
1480 /* We build a SWITCH_EXPR that contains the code with interspersed
1481 CASE_LABEL_EXPRs for each label. */
1483 push_stack (&gnu_switch_label_stack
, NULL_TREE
, create_artificial_label ());
1484 start_stmt_group ();
1485 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
1486 Present (gnat_when
);
1487 gnat_when
= Next_Non_Pragma (gnat_when
))
1489 Node_Id gnat_choice
;
1490 int choices_added
= 0;
1492 /* First compile all the different case choices for the current WHEN
1494 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
1495 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
1497 tree gnu_low
= NULL_TREE
, gnu_high
= NULL_TREE
;
1499 switch (Nkind (gnat_choice
))
1502 gnu_low
= gnat_to_gnu (Low_Bound (gnat_choice
));
1503 gnu_high
= gnat_to_gnu (High_Bound (gnat_choice
));
1506 case N_Subtype_Indication
:
1507 gnu_low
= gnat_to_gnu (Low_Bound (Range_Expression
1508 (Constraint (gnat_choice
))));
1509 gnu_high
= gnat_to_gnu (High_Bound (Range_Expression
1510 (Constraint (gnat_choice
))));
1514 case N_Expanded_Name
:
1515 /* This represents either a subtype range or a static value of
1516 some kind; Ekind says which. */
1517 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
1519 tree gnu_type
= get_unpadded_type (Entity (gnat_choice
));
1521 gnu_low
= fold (TYPE_MIN_VALUE (gnu_type
));
1522 gnu_high
= fold (TYPE_MAX_VALUE (gnu_type
));
1526 /* ... fall through ... */
1528 case N_Character_Literal
:
1529 case N_Integer_Literal
:
1530 gnu_low
= gnat_to_gnu (gnat_choice
);
1533 case N_Others_Choice
:
1540 /* If the case value is a subtype that raises Constraint_Error at
1541 run-time because of a wrong bound, then gnu_low or gnu_high is
1542 not transtaleted into an INTEGER_CST. In such a case, we need
1543 to ensure that the when statement is not added in the tree,
1544 otherwise it will crash the gimplifier. */
1545 if ((!gnu_low
|| TREE_CODE (gnu_low
) == INTEGER_CST
)
1546 && (!gnu_high
|| TREE_CODE (gnu_high
) == INTEGER_CST
))
1548 add_stmt_with_node (build3 (CASE_LABEL_EXPR
, void_type_node
,
1550 create_artificial_label ()),
1556 /* Push a binding level here in case variables are declared as we want
1557 them to be local to this set of statements instead of to the block
1558 containing the Case statement. */
1559 if (choices_added
> 0)
1561 add_stmt (build_stmt_group (Statements (gnat_when
), true));
1562 add_stmt (build1 (GOTO_EXPR
, void_type_node
,
1563 TREE_VALUE (gnu_switch_label_stack
)));
1567 /* Now emit a definition of the label all the cases branched to. */
1568 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
1569 TREE_VALUE (gnu_switch_label_stack
)));
1570 gnu_result
= build3 (SWITCH_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
,
1571 end_stmt_group (), NULL_TREE
);
1572 pop_stack (&gnu_switch_label_stack
);
1577 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
1578 to a GCC tree, which is returned. */
1581 Loop_Statement_to_gnu (Node_Id gnat_node
)
1583 /* ??? It would be nice to use "build" here, but there's no build5. */
1584 tree gnu_loop_stmt
= build_nt (LOOP_STMT
, NULL_TREE
, NULL_TREE
,
1585 NULL_TREE
, NULL_TREE
, NULL_TREE
);
1586 tree gnu_loop_var
= NULL_TREE
;
1587 Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
1588 tree gnu_cond_expr
= NULL_TREE
;
1591 TREE_TYPE (gnu_loop_stmt
) = void_type_node
;
1592 TREE_SIDE_EFFECTS (gnu_loop_stmt
) = 1;
1593 LOOP_STMT_LABEL (gnu_loop_stmt
) = create_artificial_label ();
1594 set_expr_location_from_node (gnu_loop_stmt
, gnat_node
);
1595 Sloc_to_locus (Sloc (End_Label (gnat_node
)),
1596 &DECL_SOURCE_LOCATION (LOOP_STMT_LABEL (gnu_loop_stmt
)));
1598 /* Save the end label of this LOOP_STMT in a stack so that the corresponding
1599 N_Exit_Statement can find it. */
1600 push_stack (&gnu_loop_label_stack
, NULL_TREE
,
1601 LOOP_STMT_LABEL (gnu_loop_stmt
));
1603 /* Set the condition that under which the loop should continue.
1604 For "LOOP .... END LOOP;" the condition is always true. */
1605 if (No (gnat_iter_scheme
))
1607 /* The case "WHILE condition LOOP ..... END LOOP;" */
1608 else if (Present (Condition (gnat_iter_scheme
)))
1609 LOOP_STMT_TOP_COND (gnu_loop_stmt
)
1610 = gnat_to_gnu (Condition (gnat_iter_scheme
));
1613 /* We have an iteration scheme. */
1614 Node_Id gnat_loop_spec
= Loop_Parameter_Specification (gnat_iter_scheme
);
1615 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
1616 Entity_Id gnat_type
= Etype (gnat_loop_var
);
1617 tree gnu_type
= get_unpadded_type (gnat_type
);
1618 tree gnu_low
= TYPE_MIN_VALUE (gnu_type
);
1619 tree gnu_high
= TYPE_MAX_VALUE (gnu_type
);
1620 bool reversep
= Reverse_Present (gnat_loop_spec
);
1621 tree gnu_first
= reversep
? gnu_high
: gnu_low
;
1622 tree gnu_last
= reversep
? gnu_low
: gnu_high
;
1623 enum tree_code end_code
= reversep
? GE_EXPR
: LE_EXPR
;
1624 tree gnu_base_type
= get_base_type (gnu_type
);
1625 tree gnu_limit
= (reversep
? TYPE_MIN_VALUE (gnu_base_type
)
1626 : TYPE_MAX_VALUE (gnu_base_type
));
1628 /* We know the loop variable will not overflow if GNU_LAST is a constant
1629 and is not equal to GNU_LIMIT. If it might overflow, we have to move
1630 the limit test to the end of the loop. In that case, we have to test
1631 for an empty loop outside the loop. */
1632 if (TREE_CODE (gnu_last
) != INTEGER_CST
1633 || TREE_CODE (gnu_limit
) != INTEGER_CST
1634 || tree_int_cst_equal (gnu_last
, gnu_limit
))
1637 = build3 (COND_EXPR
, void_type_node
,
1638 build_binary_op (LE_EXPR
, integer_type_node
,
1640 NULL_TREE
, alloc_stmt_list ());
1641 set_expr_location_from_node (gnu_cond_expr
, gnat_loop_spec
);
1644 /* Open a new nesting level that will surround the loop to declare the
1645 loop index variable. */
1646 start_stmt_group ();
1649 /* Declare the loop index and set it to its initial value. */
1650 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
1651 if (DECL_BY_REF_P (gnu_loop_var
))
1652 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_loop_var
);
1654 /* The loop variable might be a padded type, so use `convert' to get a
1655 reference to the inner variable if so. */
1656 gnu_loop_var
= convert (get_base_type (gnu_type
), gnu_loop_var
);
1658 /* Set either the top or bottom exit condition as appropriate depending
1659 on whether or not we know an overflow cannot occur. */
1661 LOOP_STMT_BOT_COND (gnu_loop_stmt
)
1662 = build_binary_op (NE_EXPR
, integer_type_node
,
1663 gnu_loop_var
, gnu_last
);
1665 LOOP_STMT_TOP_COND (gnu_loop_stmt
)
1666 = build_binary_op (end_code
, integer_type_node
,
1667 gnu_loop_var
, gnu_last
);
1669 LOOP_STMT_UPDATE (gnu_loop_stmt
)
1670 = build_binary_op (reversep
? PREDECREMENT_EXPR
1671 : PREINCREMENT_EXPR
,
1672 TREE_TYPE (gnu_loop_var
),
1674 convert (TREE_TYPE (gnu_loop_var
),
1676 set_expr_location_from_node (LOOP_STMT_UPDATE (gnu_loop_stmt
),
1680 /* If the loop was named, have the name point to this loop. In this case,
1681 the association is not a ..._DECL node, but the end label from this
1683 if (Present (Identifier (gnat_node
)))
1684 save_gnu_tree (Entity (Identifier (gnat_node
)),
1685 LOOP_STMT_LABEL (gnu_loop_stmt
), true);
1687 /* Make the loop body into its own block, so any allocated storage will be
1688 released every iteration. This is needed for stack allocation. */
1689 LOOP_STMT_BODY (gnu_loop_stmt
)
1690 = build_stmt_group (Statements (gnat_node
), true);
1692 /* If we declared a variable, then we are in a statement group for that
1693 declaration. Add the LOOP_STMT to it and make that the "loop". */
1696 add_stmt (gnu_loop_stmt
);
1698 gnu_loop_stmt
= end_stmt_group ();
1701 /* If we have an outer COND_EXPR, that's our result and this loop is its
1702 "true" statement. Otherwise, the result is the LOOP_STMT. */
1705 COND_EXPR_THEN (gnu_cond_expr
) = gnu_loop_stmt
;
1706 gnu_result
= gnu_cond_expr
;
1707 recalculate_side_effects (gnu_cond_expr
);
1710 gnu_result
= gnu_loop_stmt
;
1712 pop_stack (&gnu_loop_label_stack
);
1717 /* Emit statements to establish __gnat_handle_vms_condition as a VMS condition
1718 handler for the current function. */
1720 /* This is implemented by issuing a call to the appropriate VMS specific
1721 builtin. To avoid having VMS specific sections in the global gigi decls
1722 array, we maintain the decls of interest here. We can't declare them
1723 inside the function because we must mark them never to be GC'd, which we
1724 can only do at the global level. */
1726 static GTY(()) tree vms_builtin_establish_handler_decl
= NULL_TREE
;
1727 static GTY(()) tree gnat_vms_condition_handler_decl
= NULL_TREE
;
1730 establish_gnat_vms_condition_handler (void)
1732 tree establish_stmt
;
1734 /* Elaborate the required decls on the first call. Check on the decl for
1735 the gnat condition handler to decide, as this is one we create so we are
1736 sure that it will be non null on subsequent calls. The builtin decl is
1737 looked up so remains null on targets where it is not implemented yet. */
1738 if (gnat_vms_condition_handler_decl
== NULL_TREE
)
1740 vms_builtin_establish_handler_decl
1742 (get_identifier ("__builtin_establish_vms_condition_handler"));
1744 gnat_vms_condition_handler_decl
1745 = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"),
1747 build_function_type_list (integer_type_node
,
1751 NULL_TREE
, 0, 1, 1, 0, Empty
);
1754 /* Do nothing if the establish builtin is not available, which might happen
1755 on targets where the facility is not implemented. */
1756 if (vms_builtin_establish_handler_decl
== NULL_TREE
)
1760 = build_call_1_expr (vms_builtin_establish_handler_decl
,
1762 (ADDR_EXPR
, NULL_TREE
,
1763 gnat_vms_condition_handler_decl
));
1765 add_stmt (establish_stmt
);
1768 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
1769 don't return anything. */
1772 Subprogram_Body_to_gnu (Node_Id gnat_node
)
1774 /* Defining identifier of a parameter to the subprogram. */
1775 Entity_Id gnat_param
;
1776 /* The defining identifier for the subprogram body. Note that if a
1777 specification has appeared before for this body, then the identifier
1778 occurring in that specification will also be a defining identifier and all
1779 the calls to this subprogram will point to that specification. */
1780 Entity_Id gnat_subprog_id
1781 = (Present (Corresponding_Spec (gnat_node
))
1782 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
1783 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
1784 tree gnu_subprog_decl
;
1785 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
1786 tree gnu_subprog_type
;
1789 VEC(parm_attr
,gc
) *cache
;
1791 /* If this is a generic object or if it has been eliminated,
1793 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
1794 || Ekind (gnat_subprog_id
) == E_Generic_Function
1795 || Is_Eliminated (gnat_subprog_id
))
1798 /* If this subprogram acts as its own spec, define it. Otherwise, just get
1799 the already-elaborated tree node. However, if this subprogram had its
1800 elaboration deferred, we will already have made a tree node for it. So
1801 treat it as not being defined in that case. Such a subprogram cannot
1802 have an address clause or a freeze node, so this test is safe, though it
1803 does disable some otherwise-useful error checking. */
1805 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
1806 Acts_As_Spec (gnat_node
)
1807 && !present_gnu_tree (gnat_subprog_id
));
1809 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
1811 /* Propagate the debug mode. */
1812 if (!Needs_Debug_Info (gnat_subprog_id
))
1813 DECL_IGNORED_P (gnu_subprog_decl
) = 1;
1815 /* Set the line number in the decl to correspond to that of the body so that
1816 the line number notes are written correctly. */
1817 Sloc_to_locus (Sloc (gnat_node
), &DECL_SOURCE_LOCATION (gnu_subprog_decl
));
1819 /* Initialize the information structure for the function. */
1820 allocate_struct_function (gnu_subprog_decl
, false);
1821 DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
1822 = GGC_CNEW (struct language_function
);
1824 begin_subprog_body (gnu_subprog_decl
);
1825 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
1827 /* If there are Out parameters, we need to ensure that the return statement
1828 properly copies them out. We do this by making a new block and converting
1829 any inner return into a goto to a label at the end of the block. */
1830 push_stack (&gnu_return_label_stack
, NULL_TREE
,
1831 gnu_cico_list
? create_artificial_label () : NULL_TREE
);
1833 /* Get a tree corresponding to the code for the subprogram. */
1834 start_stmt_group ();
1837 /* See if there are any parameters for which we don't yet have GCC entities.
1838 These must be for Out parameters for which we will be making VAR_DECL
1839 nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
1840 entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
1841 the order of the parameters. */
1842 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
1843 Present (gnat_param
);
1844 gnat_param
= Next_Formal_With_Extras (gnat_param
))
1845 if (!present_gnu_tree (gnat_param
))
1847 /* Skip any entries that have been already filled in; they must
1848 correspond to In Out parameters. */
1849 for (; gnu_cico_list
&& TREE_VALUE (gnu_cico_list
);
1850 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
))
1853 /* Do any needed references for padded types. */
1854 TREE_VALUE (gnu_cico_list
)
1855 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list
)),
1856 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
1859 /* On VMS, establish our condition handler to possibly turn a condition into
1860 the corresponding exception if the subprogram has a foreign convention or
1863 To ensure proper execution of local finalizations on condition instances,
1864 we must turn a condition into the corresponding exception even if there
1865 is no applicable Ada handler, and need at least one condition handler per
1866 possible call chain involving GNAT code. OTOH, establishing the handler
1867 has a cost so we want to minimize the number of subprograms into which
1868 this happens. The foreign or exported condition is expected to satisfy
1869 all the constraints. */
1870 if (TARGET_ABI_OPEN_VMS
1871 && (Has_Foreign_Convention (gnat_node
) || Is_Exported (gnat_node
)))
1872 establish_gnat_vms_condition_handler ();
1874 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
1876 /* Generate the code of the subprogram itself. A return statement will be
1877 present and any Out parameters will be handled there. */
1878 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
1880 gnu_result
= end_stmt_group ();
1882 /* If we populated the parameter attributes cache, we need to make sure
1883 that the cached expressions are evaluated on all possible paths. */
1884 cache
= DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->language
->parm_attr_cache
;
1887 struct parm_attr
*pa
;
1890 start_stmt_group ();
1892 for (i
= 0; VEC_iterate (parm_attr
, cache
, i
, pa
); i
++)
1895 add_stmt (pa
->first
);
1897 add_stmt (pa
->last
);
1899 add_stmt (pa
->length
);
1902 add_stmt (gnu_result
);
1903 gnu_result
= end_stmt_group ();
1906 /* If we made a special return label, we need to make a block that contains
1907 the definition of that label and the copying to the return value. That
1908 block first contains the function, then the label and copy statement. */
1909 if (TREE_VALUE (gnu_return_label_stack
))
1913 start_stmt_group ();
1915 add_stmt (gnu_result
);
1916 add_stmt (build1 (LABEL_EXPR
, void_type_node
,
1917 TREE_VALUE (gnu_return_label_stack
)));
1919 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
1920 if (list_length (gnu_cico_list
) == 1)
1921 gnu_retval
= TREE_VALUE (gnu_cico_list
);
1923 gnu_retval
= gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
1926 if (DECL_P (gnu_retval
) && DECL_BY_REF_P (gnu_retval
))
1927 gnu_retval
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_retval
);
1930 (build_return_expr (DECL_RESULT (gnu_subprog_decl
), gnu_retval
),
1933 gnu_result
= end_stmt_group ();
1936 pop_stack (&gnu_return_label_stack
);
1938 /* Set the end location. */
1940 ((Present (End_Label (Handled_Statement_Sequence (gnat_node
)))
1941 ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node
)))
1942 : Sloc (gnat_node
)),
1943 &DECL_STRUCT_FUNCTION (gnu_subprog_decl
)->function_end_locus
);
1945 end_subprog_body (gnu_result
);
1947 /* Disconnect the trees for parameters that we made variables for from the
1948 GNAT entities since these are unusable after we end the function. */
1949 for (gnat_param
= First_Formal_With_Extras (gnat_subprog_id
);
1950 Present (gnat_param
);
1951 gnat_param
= Next_Formal_With_Extras (gnat_param
))
1952 if (TREE_CODE (get_gnu_tree (gnat_param
)) == VAR_DECL
)
1953 save_gnu_tree (gnat_param
, NULL_TREE
, false);
1955 if (DECL_FUNCTION_STUB (gnu_subprog_decl
))
1956 build_function_stub (gnu_subprog_decl
, gnat_subprog_id
);
1958 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
1961 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
1962 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
1963 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
1964 If GNU_TARGET is non-null, this must be a function call and the result
1965 of the call is to be placed into that object. */
1968 call_to_gnu (Node_Id gnat_node
, tree
*gnu_result_type_p
, tree gnu_target
)
1971 /* The GCC node corresponding to the GNAT subprogram name. This can either
1972 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
1973 or an indirect reference expression (an INDIRECT_REF node) pointing to a
1975 tree gnu_subprog_node
= gnat_to_gnu (Name (gnat_node
));
1976 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
1977 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog_node
);
1978 tree gnu_subprog_addr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
1980 Entity_Id gnat_formal
;
1981 Node_Id gnat_actual
;
1982 tree gnu_actual_list
= NULL_TREE
;
1983 tree gnu_name_list
= NULL_TREE
;
1984 tree gnu_before_list
= NULL_TREE
;
1985 tree gnu_after_list
= NULL_TREE
;
1986 tree gnu_subprog_call
;
1988 switch (Nkind (Name (gnat_node
)))
1991 case N_Operator_Symbol
:
1992 case N_Expanded_Name
:
1993 case N_Attribute_Reference
:
1994 if (Is_Eliminated (Entity (Name (gnat_node
))))
1995 Eliminate_Error_Msg (gnat_node
, Entity (Name (gnat_node
)));
1998 gcc_assert (TREE_CODE (gnu_subprog_type
) == FUNCTION_TYPE
);
2000 /* If we are calling a stubbed function, make this into a raise of
2001 Program_Error. Elaborate all our args first. */
2002 if (TREE_CODE (gnu_subprog_node
) == FUNCTION_DECL
2003 && DECL_STUBBED_P (gnu_subprog_node
))
2005 for (gnat_actual
= First_Actual (gnat_node
);
2006 Present (gnat_actual
);
2007 gnat_actual
= Next_Actual (gnat_actual
))
2008 add_stmt (gnat_to_gnu (gnat_actual
));
2012 = build_call_raise (PE_Stubbed_Subprogram_Called
, gnat_node
,
2013 N_Raise_Program_Error
);
2015 if (Nkind (gnat_node
) == N_Function_Call
&& !gnu_target
)
2017 *gnu_result_type_p
= TREE_TYPE (gnu_subprog_type
);
2018 return build1 (NULL_EXPR
, *gnu_result_type_p
, call_expr
);
2025 /* If we are calling by supplying a pointer to a target, set up that
2026 pointer as the first argument. Use GNU_TARGET if one was passed;
2027 otherwise, make a target by building a variable of the maximum size
2029 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type
))
2031 tree gnu_real_ret_type
2032 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type
)));
2037 = maybe_pad_type (gnu_real_ret_type
,
2038 max_size (TYPE_SIZE (gnu_real_ret_type
), true),
2039 0, Etype (Name (gnat_node
)), "PAD", false,
2042 /* ??? We may be about to create a static temporary if we happen to
2043 be at the global binding level. That's a regression from what
2044 the 3.x back-end would generate in the same situation, but we
2045 don't have a mechanism in Gigi for creating automatic variables
2046 in the elaboration routines. */
2048 = create_var_decl (create_tmp_var_name ("LR"), NULL
, gnu_obj_type
,
2049 NULL
, false, false, false, false, NULL
,
2054 = tree_cons (NULL_TREE
,
2055 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2056 unchecked_convert (gnu_real_ret_type
,
2063 /* The only way we can be making a call via an access type is if Name is an
2064 explicit dereference. In that case, get the list of formal args from the
2065 type the access type is pointing to. Otherwise, get the formals from
2066 entity being called. */
2067 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2068 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
2069 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
2070 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2073 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
2075 /* Create the list of the actual parameters as GCC expects it, namely a chain
2076 of TREE_LIST nodes in which the TREE_VALUE field of each node is a
2077 parameter-expression and the TREE_PURPOSE field is null. Skip Out
2078 parameters not passed by reference and don't need to be copied in. */
2079 for (gnat_actual
= First_Actual (gnat_node
);
2080 Present (gnat_actual
);
2081 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2082 gnat_actual
= Next_Actual (gnat_actual
))
2085 = (present_gnu_tree (gnat_formal
)
2086 ? get_gnu_tree (gnat_formal
) : NULL_TREE
);
2087 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
2088 /* We must suppress conversions that can cause the creation of a
2089 temporary in the Out or In Out case because we need the real
2090 object in this case, either to pass its address if it's passed
2091 by reference or as target of the back copy done after the call
2092 if it uses the copy-in copy-out mechanism. We do it in the In
2093 case too, except for an unchecked conversion because it alone
2094 can cause the actual to be misaligned and the addressability
2095 test is applied to the real object. */
2096 bool suppress_type_conversion
2097 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
2098 && Ekind (gnat_formal
) != E_In_Parameter
)
2099 || (Nkind (gnat_actual
) == N_Type_Conversion
2100 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal
)))));
2101 Node_Id gnat_name
= (suppress_type_conversion
2102 ? Expression (gnat_actual
) : gnat_actual
);
2103 tree gnu_name
= gnat_to_gnu (gnat_name
), gnu_name_type
;
2106 /* If it's possible we may need to use this expression twice, make sure
2107 that any side-effects are handled via SAVE_EXPRs. Likewise if we need
2108 to force side-effects before the call.
2109 ??? This is more conservative than we need since we don't need to do
2110 this for pass-by-ref with no conversion. */
2111 if (Ekind (gnat_formal
) != E_In_Parameter
)
2112 gnu_name
= gnat_stabilize_reference (gnu_name
, true);
2114 /* If we are passing a non-addressable parameter by reference, pass the
2115 address of a copy. In the Out or In Out case, set up to copy back
2116 out after the call. */
2118 && (DECL_BY_REF_P (gnu_formal
)
2119 || (TREE_CODE (gnu_formal
) == PARM_DECL
2120 && (DECL_BY_COMPONENT_PTR_P (gnu_formal
)
2121 || (DECL_BY_DESCRIPTOR_P (gnu_formal
)))))
2122 && (gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
)))
2123 && !addressable_p (gnu_name
, gnu_name_type
))
2125 tree gnu_copy
= gnu_name
, gnu_temp
;
2127 /* If the type is by_reference, a copy is not allowed. */
2128 if (Is_By_Reference_Type (Etype (gnat_formal
)))
2130 ("misaligned actual cannot be passed by reference", gnat_actual
);
2132 /* For users of Starlet we issue a warning because the
2133 interface apparently assumes that by-ref parameters
2134 outlive the procedure invocation. The code still
2135 will not work as intended, but we cannot do much
2136 better since other low-level parts of the back-end
2137 would allocate temporaries at will because of the
2138 misalignment if we did not do so here. */
2139 else if (Is_Valued_Procedure (Entity (Name (gnat_node
))))
2142 ("?possible violation of implicit assumption", gnat_actual
);
2144 ("?made by pragma Import_Valued_Procedure on &", gnat_actual
,
2145 Entity (Name (gnat_node
)));
2146 post_error_ne ("?because of misalignment of &", gnat_actual
,
2150 /* Remove any unpadding from the object and reset the copy. */
2151 if (TREE_CODE (gnu_name
) == COMPONENT_REF
2152 && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name
, 0)))
2154 && (TYPE_IS_PADDING_P
2155 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))))
2156 gnu_name
= gnu_copy
= TREE_OPERAND (gnu_name
, 0);
2158 /* Otherwise convert to the nominal type of the object if it's
2159 a record type. There are several cases in which we need to
2160 make the temporary using this type instead of the actual type
2161 of the object if they are distinct, because the expectations
2162 of the callee would otherwise not be met:
2163 - if it's a justified modular type,
2164 - if the actual type is a packed version of it. */
2165 else if (TREE_CODE (gnu_name_type
) == RECORD_TYPE
2166 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type
)
2167 || larger_record_type_p (gnu_name_type
,
2168 TREE_TYPE (gnu_name
))))
2169 gnu_name
= convert (gnu_name_type
, gnu_name
);
2171 /* Make a SAVE_EXPR to both properly account for potential side
2172 effects and handle the creation of a temporary copy. Special
2173 code in gnat_gimplify_expr ensures that the same temporary is
2174 used as the object and copied back after the call if needed. */
2175 gnu_name
= build1 (SAVE_EXPR
, TREE_TYPE (gnu_name
), gnu_name
);
2176 TREE_SIDE_EFFECTS (gnu_name
) = 1;
2177 TREE_INVARIANT (gnu_name
) = 1;
2179 /* Set up to move the copy back to the original. */
2180 if (Ekind (gnat_formal
) != E_In_Parameter
)
2182 gnu_temp
= build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_copy
,
2184 set_expr_location_from_node (gnu_temp
, gnat_actual
);
2185 append_to_statement_list (gnu_temp
, &gnu_after_list
);
2189 /* Start from the real object and build the actual. */
2190 gnu_actual
= gnu_name
;
2192 /* If this was a procedure call, we may not have removed any padding.
2193 So do it here for the part we will use as an input, if any. */
2194 if (Ekind (gnat_formal
) != E_Out_Parameter
2195 && TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2196 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2197 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
2200 /* Do any needed conversions for the actual and make sure that it is
2201 in range of the formal's type. */
2202 if (suppress_type_conversion
)
2204 /* Put back the conversion we suppressed above in the computation
2205 of the real object. Note that we treat a conversion between
2206 aggregate types as if it is an unchecked conversion here. */
2208 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2210 (Nkind (gnat_actual
)
2211 == N_Unchecked_Type_Conversion
)
2212 && No_Truncation (gnat_actual
));
2214 if (Ekind (gnat_formal
) != E_Out_Parameter
2215 && Do_Range_Check (gnat_actual
))
2216 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
2220 if (Ekind (gnat_formal
) != E_Out_Parameter
2221 && Do_Range_Check (gnat_actual
))
2222 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
2224 /* We may have suppressed a conversion to the Etype of the actual
2225 since the parent is a procedure call. So put it back here.
2226 ??? We use the reverse order compared to the case above because
2227 of an awkward interaction with the check and actually don't put
2228 back the conversion at all if a check is emitted. This is also
2229 done for the conversion to the formal's type just below. */
2230 if (TREE_CODE (gnu_actual
) != SAVE_EXPR
)
2231 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2235 if (TREE_CODE (gnu_actual
) != SAVE_EXPR
)
2236 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2238 /* Unless this is an In parameter, we must remove any justified modular
2239 building from GNU_NAME to get an lvalue. */
2240 if (Ekind (gnat_formal
) != E_In_Parameter
2241 && TREE_CODE (gnu_name
) == CONSTRUCTOR
2242 && TREE_CODE (TREE_TYPE (gnu_name
)) == RECORD_TYPE
2243 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name
)))
2244 gnu_name
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name
))),
2247 /* If we have not saved a GCC object for the formal, it means it is an
2248 Out parameter not passed by reference and that does not need to be
2249 copied in. Otherwise, look at the PARM_DECL to see if it is passed by
2252 && TREE_CODE (gnu_formal
) == PARM_DECL
2253 && DECL_BY_REF_P (gnu_formal
))
2255 if (Ekind (gnat_formal
) != E_In_Parameter
)
2257 /* In Out or Out parameters passed by reference don't use the
2258 copy-in copy-out mechanism so the address of the real object
2259 must be passed to the function. */
2260 gnu_actual
= gnu_name
;
2262 /* If we have a padded type, be sure we've removed padding. */
2263 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2264 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
))
2265 && TREE_CODE (gnu_actual
) != SAVE_EXPR
)
2266 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
2269 /* If we have the constructed subtype of an aliased object
2270 with an unconstrained nominal subtype, the type of the
2271 actual includes the template, although it is formally
2272 constrained. So we need to convert it back to the real
2273 constructed subtype to retrieve the constrained part
2274 and takes its address. */
2275 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2276 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual
))
2277 && TREE_CODE (gnu_actual
) != SAVE_EXPR
2278 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual
))
2279 && Is_Array_Type (Etype (gnat_actual
)))
2280 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2284 /* The symmetry of the paths to the type of an entity is broken here
2285 since arguments don't know that they will be passed by ref. */
2286 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2287 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
, gnu_actual
);
2290 && TREE_CODE (gnu_formal
) == PARM_DECL
2291 && DECL_BY_COMPONENT_PTR_P (gnu_formal
))
2293 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2294 gnu_actual
= maybe_implicit_deref (gnu_actual
);
2295 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
2297 if (TREE_CODE (gnu_formal_type
) == RECORD_TYPE
2298 && TYPE_IS_PADDING_P (gnu_formal_type
))
2300 gnu_formal_type
= TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
2301 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2304 /* Take the address of the object and convert to the proper pointer
2305 type. We'd like to actually compute the address of the beginning
2306 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
2307 possibility that the ARRAY_REF might return a constant and we'd be
2308 getting the wrong address. Neither approach is exactly correct,
2309 but this is the most likely to work in all cases. */
2310 gnu_actual
= convert (gnu_formal_type
,
2311 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2315 && TREE_CODE (gnu_formal
) == PARM_DECL
2316 && DECL_BY_DESCRIPTOR_P (gnu_formal
))
2318 /* If arg is 'Null_Parameter, pass zero descriptor. */
2319 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
2320 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
2321 && TREE_PRIVATE (gnu_actual
))
2322 gnu_actual
= convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
2325 gnu_actual
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
2326 fill_vms_descriptor (gnu_actual
,
2331 tree gnu_actual_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
));
2333 if (Ekind (gnat_formal
) != E_In_Parameter
)
2334 gnu_name_list
= tree_cons (NULL_TREE
, gnu_name
, gnu_name_list
);
2336 if (!gnu_formal
|| TREE_CODE (gnu_formal
) != PARM_DECL
)
2339 /* If this is 'Null_Parameter, pass a zero even though we are
2340 dereferencing it. */
2341 else if (TREE_CODE (gnu_actual
) == INDIRECT_REF
2342 && TREE_PRIVATE (gnu_actual
)
2343 && host_integerp (gnu_actual_size
, 1)
2344 && 0 >= compare_tree_int (gnu_actual_size
,
2347 = unchecked_convert (DECL_ARG_TYPE (gnu_formal
),
2348 convert (gnat_type_for_size
2349 (tree_low_cst (gnu_actual_size
, 1),
2354 gnu_actual
= convert (DECL_ARG_TYPE (gnu_formal
), gnu_actual
);
2357 gnu_actual_list
= tree_cons (NULL_TREE
, gnu_actual
, gnu_actual_list
);
2360 gnu_subprog_call
= build_call_list (TREE_TYPE (gnu_subprog_type
),
2362 nreverse (gnu_actual_list
));
2363 set_expr_location_from_node (gnu_subprog_call
, gnat_node
);
2365 /* If we return by passing a target, the result is the target after the
2366 call. We must not emit the call directly here because this might be
2367 evaluated as part of an expression with conditions to control whether
2368 the call should be emitted or not. */
2369 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type
))
2371 /* Conceptually, what we need is a COMPOUND_EXPR with the call followed
2372 by the target object converted to the proper type. Doing so would
2373 potentially be very inefficient, however, as this expresssion might
2374 end up wrapped into an outer SAVE_EXPR later on, which would incur a
2375 pointless temporary copy of the whole object.
2377 What we do instead is build a COMPOUND_EXPR returning the address of
2378 the target, and then dereference. Wrapping the COMPOUND_EXPR into a
2379 SAVE_EXPR later on then only incurs a pointer copy. */
2381 tree gnu_result_type
2382 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type
)));
2385 (result_type) *[gnu_subprog_call (&gnu_target, ...), &gnu_target] */
2387 tree gnu_target_address
2388 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_target
);
2389 set_expr_location_from_node (gnu_target_address
, gnat_node
);
2392 = build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_target_address
),
2393 gnu_subprog_call
, gnu_target_address
);
2396 = unchecked_convert (gnu_result_type
,
2397 build_unary_op (INDIRECT_REF
, NULL_TREE
,
2401 *gnu_result_type_p
= gnu_result_type
;
2405 /* If it is a function call, the result is the call expression unless
2406 a target is specified, in which case we copy the result into the target
2407 and return the assignment statement. */
2408 else if (Nkind (gnat_node
) == N_Function_Call
)
2410 gnu_result
= gnu_subprog_call
;
2412 /* If the function returns an unconstrained array or by reference,
2413 we have to de-dereference the pointer. */
2414 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
)
2415 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type
))
2416 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
2419 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2420 gnu_target
, gnu_result
);
2422 *gnu_result_type_p
= get_unpadded_type (Etype (gnat_node
));
2427 /* If this is the case where the GNAT tree contains a procedure call
2428 but the Ada procedure has copy in copy out parameters, the special
2429 parameter passing mechanism must be used. */
2430 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
2432 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
2433 in copy out parameters. */
2434 tree scalar_return_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2435 int length
= list_length (scalar_return_list
);
2441 gnu_subprog_call
= save_expr (gnu_subprog_call
);
2442 gnu_name_list
= nreverse (gnu_name_list
);
2444 /* If any of the names had side-effects, ensure they are all
2445 evaluated before the call. */
2446 for (gnu_name
= gnu_name_list
; gnu_name
;
2447 gnu_name
= TREE_CHAIN (gnu_name
))
2448 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name
)))
2449 append_to_statement_list (TREE_VALUE (gnu_name
),
2453 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2454 gnat_formal
= First_Formal_With_Extras (Etype (Name (gnat_node
)));
2456 gnat_formal
= First_Formal_With_Extras (Entity (Name (gnat_node
)));
2458 for (gnat_actual
= First_Actual (gnat_node
);
2459 Present (gnat_actual
);
2460 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2461 gnat_actual
= Next_Actual (gnat_actual
))
2462 /* If we are dealing with a copy in copy out parameter, we must
2463 retrieve its value from the record returned in the call. */
2464 if (!(present_gnu_tree (gnat_formal
)
2465 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2466 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
2467 || (TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2468 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
2469 || (DECL_BY_DESCRIPTOR_P
2470 (get_gnu_tree (gnat_formal
))))))))
2471 && Ekind (gnat_formal
) != E_In_Parameter
)
2473 /* Get the value to assign to this Out or In Out parameter. It is
2474 either the result of the function if there is only a single such
2475 parameter or the appropriate field from the record returned. */
2477 = length
== 1 ? gnu_subprog_call
2478 : build_component_ref (gnu_subprog_call
, NULL_TREE
,
2479 TREE_PURPOSE (scalar_return_list
),
2482 /* If the actual is a conversion, get the inner expression, which
2483 will be the real destination, and convert the result to the
2484 type of the actual parameter. */
2486 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
2488 /* If the result is a padded type, remove the padding. */
2489 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
2490 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
2491 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS
2492 (TREE_TYPE (gnu_result
))),
2495 /* If the actual is a type conversion, the real target object is
2496 denoted by the inner Expression and we need to convert the
2497 result to the associated type.
2498 We also need to convert our gnu assignment target to this type
2499 if the corresponding GNU_NAME was constructed from the GNAT
2500 conversion node and not from the inner Expression. */
2501 if (Nkind (gnat_actual
) == N_Type_Conversion
)
2504 = convert_with_check
2505 (Etype (Expression (gnat_actual
)), gnu_result
,
2506 Do_Overflow_Check (gnat_actual
),
2507 Do_Range_Check (Expression (gnat_actual
)),
2508 Float_Truncate (gnat_actual
));
2510 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal
))))
2511 gnu_actual
= convert (TREE_TYPE (gnu_result
), gnu_actual
);
2514 /* Unchecked conversions as actuals for Out parameters are not
2515 allowed in user code because they are not variables, but do
2516 occur in front-end expansions. The associated GNU_NAME is
2517 always obtained from the inner expression in such cases. */
2518 else if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2519 gnu_result
= unchecked_convert (TREE_TYPE (gnu_actual
),
2521 No_Truncation (gnat_actual
));
2524 if (Do_Range_Check (gnat_actual
))
2525 gnu_result
= emit_range_check (gnu_result
,
2526 Etype (gnat_actual
));
2528 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
2529 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result
)))))
2530 gnu_result
= convert (TREE_TYPE (gnu_actual
), gnu_result
);
2533 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2534 gnu_actual
, gnu_result
);
2535 set_expr_location_from_node (gnu_result
, gnat_actual
);
2536 append_to_statement_list (gnu_result
, &gnu_before_list
);
2537 scalar_return_list
= TREE_CHAIN (scalar_return_list
);
2538 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
2542 append_to_statement_list (gnu_subprog_call
, &gnu_before_list
);
2544 append_to_statement_list (gnu_after_list
, &gnu_before_list
);
2545 return gnu_before_list
;
2548 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2549 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
2552 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node
)
2554 tree gnu_jmpsave_decl
= NULL_TREE
;
2555 tree gnu_jmpbuf_decl
= NULL_TREE
;
2556 /* If just annotating, ignore all EH and cleanups. */
2557 bool gcc_zcx
= (!type_annotate_only
2558 && Present (Exception_Handlers (gnat_node
))
2559 && Exception_Mechanism
== Back_End_Exceptions
);
2561 = (!type_annotate_only
&& Present (Exception_Handlers (gnat_node
))
2562 && Exception_Mechanism
== Setjmp_Longjmp
);
2563 bool at_end
= !type_annotate_only
&& Present (At_End_Proc (gnat_node
));
2564 bool binding_for_block
= (at_end
|| gcc_zcx
|| setjmp_longjmp
);
2565 tree gnu_inner_block
; /* The statement(s) for the block itself. */
2570 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2571 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
2572 add_cleanup, and when we leave the binding, end_stmt_group will create
2573 the TRY_FINALLY_EXPR.
2575 ??? The region level calls down there have been specifically put in place
2576 for a ZCX context and currently the order in which things are emitted
2577 (region/handlers) is different from the SJLJ case. Instead of putting
2578 other calls with different conditions at other places for the SJLJ case,
2579 it seems cleaner to reorder things for the SJLJ case and generalize the
2580 condition to make it not ZCX specific.
2582 If there are any exceptions or cleanup processing involved, we need an
2583 outer statement group (for Setjmp_Longjmp) and binding level. */
2584 if (binding_for_block
)
2586 start_stmt_group ();
2590 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2591 area for address of previous buffer. Do this first since we need to have
2592 the setjmp buf known for any decls in this block. */
2595 gnu_jmpsave_decl
= create_var_decl (get_identifier ("JMPBUF_SAVE"),
2596 NULL_TREE
, jmpbuf_ptr_type
,
2597 build_call_0_expr (get_jmpbuf_decl
),
2598 false, false, false, false, NULL
,
2600 DECL_ARTIFICIAL (gnu_jmpsave_decl
) = 1;
2602 /* The __builtin_setjmp receivers will immediately reinstall it. Now
2603 because of the unstructured form of EH used by setjmp_longjmp, there
2604 might be forward edges going to __builtin_setjmp receivers on which
2605 it is uninitialized, although they will never be actually taken. */
2606 TREE_NO_WARNING (gnu_jmpsave_decl
) = 1;
2607 gnu_jmpbuf_decl
= create_var_decl (get_identifier ("JMP_BUF"),
2608 NULL_TREE
, jmpbuf_type
,
2609 NULL_TREE
, false, false, false, false,
2611 DECL_ARTIFICIAL (gnu_jmpbuf_decl
) = 1;
2613 set_block_jmpbuf_decl (gnu_jmpbuf_decl
);
2615 /* When we exit this block, restore the saved value. */
2616 add_cleanup (build_call_1_expr (set_jmpbuf_decl
, gnu_jmpsave_decl
),
2617 End_Label (gnat_node
));
2620 /* If we are to call a function when exiting this block, add a cleanup
2621 to the binding level we made above. Note that add_cleanup is FIFO
2622 so we must register this cleanup after the EH cleanup just above. */
2624 add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
))),
2625 End_Label (gnat_node
));
2627 /* Now build the tree for the declarations and statements inside this block.
2628 If this is SJLJ, set our jmp_buf as the current buffer. */
2629 start_stmt_group ();
2632 add_stmt (build_call_1_expr (set_jmpbuf_decl
,
2633 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2636 if (Present (First_Real_Statement (gnat_node
)))
2637 process_decls (Statements (gnat_node
), Empty
,
2638 First_Real_Statement (gnat_node
), true, true);
2640 /* Generate code for each statement in the block. */
2641 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
2642 ? First_Real_Statement (gnat_node
)
2643 : First (Statements (gnat_node
)));
2644 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
2645 add_stmt (gnat_to_gnu (gnat_temp
));
2646 gnu_inner_block
= end_stmt_group ();
2648 /* Now generate code for the two exception models, if either is relevant for
2652 tree
*gnu_else_ptr
= 0;
2655 /* Make a binding level for the exception handling declarations and code
2656 and set up gnu_except_ptr_stack for the handlers to use. */
2657 start_stmt_group ();
2660 push_stack (&gnu_except_ptr_stack
, NULL_TREE
,
2661 create_var_decl (get_identifier ("EXCEPT_PTR"),
2663 build_pointer_type (except_type_node
),
2664 build_call_0_expr (get_excptr_decl
), false,
2665 false, false, false, NULL
, gnat_node
));
2667 /* Generate code for each handler. The N_Exception_Handler case does the
2668 real work and returns a COND_EXPR for each handler, which we chain
2670 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
2671 Present (gnat_temp
); gnat_temp
= Next_Non_Pragma (gnat_temp
))
2673 gnu_expr
= gnat_to_gnu (gnat_temp
);
2675 /* If this is the first one, set it as the outer one. Otherwise,
2676 point the "else" part of the previous handler to us. Then point
2677 to our "else" part. */
2679 add_stmt (gnu_expr
);
2681 *gnu_else_ptr
= gnu_expr
;
2683 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
2686 /* If none of the exception handlers did anything, re-raise but do not
2688 gnu_expr
= build_call_1_expr (raise_nodefer_decl
,
2689 TREE_VALUE (gnu_except_ptr_stack
));
2690 set_expr_location_from_node (gnu_expr
, gnat_node
);
2693 *gnu_else_ptr
= gnu_expr
;
2695 add_stmt (gnu_expr
);
2697 /* End the binding level dedicated to the exception handlers and get the
2698 whole statement group. */
2699 pop_stack (&gnu_except_ptr_stack
);
2701 gnu_handler
= end_stmt_group ();
2703 /* If the setjmp returns 1, we restore our incoming longjmp value and
2704 then check the handlers. */
2705 start_stmt_group ();
2706 add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl
,
2709 add_stmt (gnu_handler
);
2710 gnu_handler
= end_stmt_group ();
2712 /* This block is now "if (setjmp) ... <handlers> else <block>". */
2713 gnu_result
= build3 (COND_EXPR
, void_type_node
,
2716 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2718 gnu_handler
, gnu_inner_block
);
2724 /* First make a block containing the handlers. */
2725 start_stmt_group ();
2726 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
2727 Present (gnat_temp
);
2728 gnat_temp
= Next_Non_Pragma (gnat_temp
))
2729 add_stmt (gnat_to_gnu (gnat_temp
));
2730 gnu_handlers
= end_stmt_group ();
2732 /* Now make the TRY_CATCH_EXPR for the block. */
2733 gnu_result
= build2 (TRY_CATCH_EXPR
, void_type_node
,
2734 gnu_inner_block
, gnu_handlers
);
2737 gnu_result
= gnu_inner_block
;
2739 /* Now close our outer block, if we had to make one. */
2740 if (binding_for_block
)
2742 add_stmt (gnu_result
);
2744 gnu_result
= end_stmt_group ();
2750 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2751 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
2752 exception handling. */
2755 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node
)
2757 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
2758 an "if" statement to select the proper exceptions. For "Others", exclude
2759 exceptions where Handled_By_Others is nonzero unless the All_Others flag
2760 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
2761 tree gnu_choice
= integer_zero_node
;
2762 tree gnu_body
= build_stmt_group (Statements (gnat_node
), false);
2765 for (gnat_temp
= First (Exception_Choices (gnat_node
));
2766 gnat_temp
; gnat_temp
= Next (gnat_temp
))
2770 if (Nkind (gnat_temp
) == N_Others_Choice
)
2772 if (All_Others (gnat_temp
))
2773 this_choice
= integer_one_node
;
2777 (EQ_EXPR
, integer_type_node
,
2782 (INDIRECT_REF
, NULL_TREE
,
2783 TREE_VALUE (gnu_except_ptr_stack
)),
2784 get_identifier ("not_handled_by_others"), NULL_TREE
,
2789 else if (Nkind (gnat_temp
) == N_Identifier
2790 || Nkind (gnat_temp
) == N_Expanded_Name
)
2792 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
2795 /* Exception may be a renaming. Recover original exception which is
2796 the one elaborated and registered. */
2797 if (Present (Renamed_Object (gnat_ex_id
)))
2798 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
2800 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
2804 (EQ_EXPR
, integer_type_node
, TREE_VALUE (gnu_except_ptr_stack
),
2805 convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack
)),
2806 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
2808 /* If this is the distinguished exception "Non_Ada_Error" (and we are
2809 in VMS mode), also allow a non-Ada exception (a VMS condition) t
2811 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
2814 = build_component_ref
2815 (build_unary_op (INDIRECT_REF
, NULL_TREE
,
2816 TREE_VALUE (gnu_except_ptr_stack
)),
2817 get_identifier ("lang"), NULL_TREE
, false);
2821 (TRUTH_ORIF_EXPR
, integer_type_node
,
2822 build_binary_op (EQ_EXPR
, integer_type_node
, gnu_comp
,
2823 build_int_cst (TREE_TYPE (gnu_comp
), 'V')),
2830 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
2831 gnu_choice
, this_choice
);
2834 return build3 (COND_EXPR
, void_type_node
, gnu_choice
, gnu_body
, NULL_TREE
);
2837 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2838 to a GCC tree, which is returned. This is the variant for ZCX. */
2841 Exception_Handler_to_gnu_zcx (Node_Id gnat_node
)
2843 tree gnu_etypes_list
= NULL_TREE
;
2846 tree gnu_current_exc_ptr
;
2847 tree gnu_incoming_exc_ptr
;
2850 /* We build a TREE_LIST of nodes representing what exception types this
2851 handler can catch, with special cases for others and all others cases.
2853 Each exception type is actually identified by a pointer to the exception
2854 id, or to a dummy object for "others" and "all others".
2856 Care should be taken to ensure that the control flow impact of "others"
2857 and "all others" is known to GCC. lang_eh_type_covers is doing the trick
2859 for (gnat_temp
= First (Exception_Choices (gnat_node
));
2860 gnat_temp
; gnat_temp
= Next (gnat_temp
))
2862 if (Nkind (gnat_temp
) == N_Others_Choice
)
2865 = All_Others (gnat_temp
) ? all_others_decl
: others_decl
;
2868 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
2870 else if (Nkind (gnat_temp
) == N_Identifier
2871 || Nkind (gnat_temp
) == N_Expanded_Name
)
2873 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
2875 /* Exception may be a renaming. Recover original exception which is
2876 the one elaborated and registered. */
2877 if (Present (Renamed_Object (gnat_ex_id
)))
2878 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
2880 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
2881 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
2883 /* The Non_Ada_Error case for VMS exceptions is handled
2884 by the personality routine. */
2889 /* The GCC interface expects NULL to be passed for catch all handlers, so
2890 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
2891 is integer_zero_node. It would not work, however, because GCC's
2892 notion of "catch all" is stronger than our notion of "others". Until
2893 we correctly use the cleanup interface as well, doing that would
2894 prevent the "all others" handlers from being seen, because nothing
2895 can be caught beyond a catch all from GCC's point of view. */
2896 gnu_etypes_list
= tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
2899 start_stmt_group ();
2902 /* Expand a call to the begin_handler hook at the beginning of the handler,
2903 and arrange for a call to the end_handler hook to occur on every possible
2906 The hooks expect a pointer to the low level occurrence. This is required
2907 for our stack management scheme because a raise inside the handler pushes
2908 a new occurrence on top of the stack, which means that this top does not
2909 necessarily match the occurrence this handler was dealing with.
2911 The EXC_PTR_EXPR object references the exception occurrence being
2912 propagated. Upon handler entry, this is the exception for which the
2913 handler is triggered. This might not be the case upon handler exit,
2914 however, as we might have a new occurrence propagated by the handler's
2915 body, and the end_handler hook called as a cleanup in this context.
2917 We use a local variable to retrieve the incoming value at handler entry
2918 time, and reuse it to feed the end_handler hook's argument at exit. */
2919 gnu_current_exc_ptr
= build0 (EXC_PTR_EXPR
, ptr_type_node
);
2920 gnu_incoming_exc_ptr
= create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
2921 ptr_type_node
, gnu_current_exc_ptr
,
2922 false, false, false, false, NULL
,
2925 add_stmt_with_node (build_call_1_expr (begin_handler_decl
,
2926 gnu_incoming_exc_ptr
),
2928 /* ??? We don't seem to have an End_Label at hand to set the location. */
2929 add_cleanup (build_call_1_expr (end_handler_decl
, gnu_incoming_exc_ptr
),
2931 add_stmt_list (Statements (gnat_node
));
2934 return build2 (CATCH_EXPR
, void_type_node
, gnu_etypes_list
,
2938 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
2941 Compilation_Unit_to_gnu (Node_Id gnat_node
)
2943 /* Make the decl for the elaboration procedure. */
2944 bool body_p
= (Defining_Entity (Unit (gnat_node
)),
2945 Nkind (Unit (gnat_node
)) == N_Package_Body
2946 || Nkind (Unit (gnat_node
)) == N_Subprogram_Body
);
2947 Entity_Id gnat_unit_entity
= Defining_Entity (Unit (gnat_node
));
2948 tree gnu_elab_proc_decl
2949 = create_subprog_decl
2950 (create_concat_name (gnat_unit_entity
,
2951 body_p
? "elabb" : "elabs"),
2952 NULL_TREE
, void_ftype
, NULL_TREE
, false, true, false, NULL
,
2954 struct elab_info
*info
;
2956 push_stack (&gnu_elab_proc_stack
, NULL_TREE
, gnu_elab_proc_decl
);
2958 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl
) = 1;
2959 allocate_struct_function (gnu_elab_proc_decl
, false);
2960 Sloc_to_locus (Sloc (gnat_unit_entity
), &cfun
->function_end_locus
);
2963 /* For a body, first process the spec if there is one. */
2964 if (Nkind (Unit (gnat_node
)) == N_Package_Body
2965 || (Nkind (Unit (gnat_node
)) == N_Subprogram_Body
2966 && !Acts_As_Spec (gnat_node
)))
2968 add_stmt (gnat_to_gnu (Library_Unit (gnat_node
)));
2969 finalize_from_with_types ();
2972 process_inlined_subprograms (gnat_node
);
2974 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
2976 elaborate_all_entities (gnat_node
);
2978 if (Nkind (Unit (gnat_node
)) == N_Subprogram_Declaration
2979 || Nkind (Unit (gnat_node
)) == N_Generic_Package_Declaration
2980 || Nkind (Unit (gnat_node
)) == N_Generic_Subprogram_Declaration
)
2984 process_decls (Declarations (Aux_Decls_Node (gnat_node
)), Empty
, Empty
,
2986 add_stmt (gnat_to_gnu (Unit (gnat_node
)));
2988 /* Process any pragmas and actions following the unit. */
2989 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node
)));
2990 add_stmt_list (Actions (Aux_Decls_Node (gnat_node
)));
2991 finalize_from_with_types ();
2993 /* Save away what we've made so far and record this potential elaboration
2995 info
= (struct elab_info
*) ggc_alloc (sizeof (struct elab_info
));
2996 set_current_block_context (gnu_elab_proc_decl
);
2998 DECL_SAVED_TREE (gnu_elab_proc_decl
) = end_stmt_group ();
2999 info
->next
= elab_info_list
;
3000 info
->elab_proc
= gnu_elab_proc_decl
;
3001 info
->gnat_node
= gnat_node
;
3002 elab_info_list
= info
;
3004 /* Generate elaboration code for this unit, if necessary, and say whether
3006 pop_stack (&gnu_elab_proc_stack
);
3008 /* Invalidate the global renaming pointers. This is necessary because
3009 stabilization of the renamed entities may create SAVE_EXPRs which
3010 have been tied to a specific elaboration routine just above. */
3011 invalidate_global_renaming_pointers ();
3014 /* This function is the driver of the GNAT to GCC tree transformation
3015 process. It is the entry point of the tree transformer. GNAT_NODE is the
3016 root of some GNAT tree. Return the root of the corresponding GCC tree.
3017 If this is an expression, return the GCC equivalent of the expression. If
3018 it is a statement, return the statement. In the case when called for a
3019 statement, it may also add statements to the current statement group, in
3020 which case anything it returns is to be interpreted as occurring after
3021 anything `it already added. */
3024 gnat_to_gnu (Node_Id gnat_node
)
3026 bool went_into_elab_proc
= false;
3027 tree gnu_result
= error_mark_node
; /* Default to no value. */
3028 tree gnu_result_type
= void_type_node
;
3030 tree gnu_lhs
, gnu_rhs
;
3033 /* Save node number for error message and set location information. */
3034 error_gnat_node
= gnat_node
;
3035 Sloc_to_locus (Sloc (gnat_node
), &input_location
);
3037 if (type_annotate_only
3038 && IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
))
3039 return alloc_stmt_list ();
3041 /* If this node is a non-static subexpression and we are only
3042 annotating types, make this into a NULL_EXPR. */
3043 if (type_annotate_only
3044 && IN (Nkind (gnat_node
), N_Subexpr
)
3045 && Nkind (gnat_node
) != N_Identifier
3046 && !Compile_Time_Known_Value (gnat_node
))
3047 return build1 (NULL_EXPR
, get_unpadded_type (Etype (gnat_node
)),
3048 build_call_raise (CE_Range_Check_Failed
, gnat_node
,
3049 N_Raise_Constraint_Error
));
3051 /* If this is a Statement and we are at top level, it must be part of the
3052 elaboration procedure, so mark us as being in that procedure and push our
3055 If we are in the elaboration procedure, check if we are violating a a
3056 No_Elaboration_Code restriction by having a statement there. */
3057 if ((IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
3058 && Nkind (gnat_node
) != N_Null_Statement
)
3059 || Nkind (gnat_node
) == N_Procedure_Call_Statement
3060 || Nkind (gnat_node
) == N_Label
3061 || Nkind (gnat_node
) == N_Implicit_Label_Declaration
3062 || Nkind (gnat_node
) == N_Handled_Sequence_Of_Statements
3063 || ((Nkind (gnat_node
) == N_Raise_Constraint_Error
3064 || Nkind (gnat_node
) == N_Raise_Storage_Error
3065 || Nkind (gnat_node
) == N_Raise_Program_Error
)
3066 && (Ekind (Etype (gnat_node
)) == E_Void
)))
3068 if (!current_function_decl
)
3070 current_function_decl
= TREE_VALUE (gnu_elab_proc_stack
);
3071 start_stmt_group ();
3073 went_into_elab_proc
= true;
3076 /* Don't check for a possible No_Elaboration_Code restriction violation
3077 on N_Handled_Sequence_Of_Statements, as we want to signal an error on
3078 every nested real statement instead. This also avoids triggering
3079 spurious errors on dummy (empty) sequences created by the front-end
3080 for package bodies in some cases. */
3082 if (current_function_decl
== TREE_VALUE (gnu_elab_proc_stack
)
3083 && Nkind (gnat_node
) != N_Handled_Sequence_Of_Statements
)
3084 Check_Elaboration_Code_Allowed (gnat_node
);
3087 switch (Nkind (gnat_node
))
3089 /********************************/
3090 /* Chapter 2: Lexical Elements: */
3091 /********************************/
3094 case N_Expanded_Name
:
3095 case N_Operator_Symbol
:
3096 case N_Defining_Identifier
:
3097 gnu_result
= Identifier_to_gnu (gnat_node
, &gnu_result_type
);
3100 case N_Integer_Literal
:
3104 /* Get the type of the result, looking inside any padding and
3105 justified modular types. Then get the value in that type. */
3106 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3108 if (TREE_CODE (gnu_type
) == RECORD_TYPE
3109 && TYPE_JUSTIFIED_MODULAR_P (gnu_type
))
3110 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
3112 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
3114 /* If the result overflows (meaning it doesn't fit in its base type),
3115 abort. We would like to check that the value is within the range
3116 of the subtype, but that causes problems with subtypes whose usage
3117 will raise Constraint_Error and with biased representation, so
3119 gcc_assert (!TREE_OVERFLOW (gnu_result
));
3123 case N_Character_Literal
:
3124 /* If a Entity is present, it means that this was one of the
3125 literals in a user-defined character type. In that case,
3126 just return the value in the CONST_DECL. Otherwise, use the
3127 character code. In that case, the base type should be an
3128 INTEGER_TYPE, but we won't bother checking for that. */
3129 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3130 if (Present (Entity (gnat_node
)))
3131 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
3134 = build_int_cst_type
3135 (gnu_result_type
, UI_To_CC (Char_Literal_Value (gnat_node
)));
3138 case N_Real_Literal
:
3139 /* If this is of a fixed-point type, the value we want is the
3140 value of the corresponding integer. */
3141 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
3143 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3144 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
3146 gcc_assert (!TREE_OVERFLOW (gnu_result
));
3149 /* We should never see a Vax_Float type literal, since the front end
3150 is supposed to transform these using appropriate conversions */
3151 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
3156 Ureal ur_realval
= Realval (gnat_node
);
3158 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3160 /* If the real value is zero, so is the result. Otherwise,
3161 convert it to a machine number if it isn't already. That
3162 forces BASE to 0 or 2 and simplifies the rest of our logic. */
3163 if (UR_Is_Zero (ur_realval
))
3164 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
3167 if (!Is_Machine_Number (gnat_node
))
3169 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
3170 ur_realval
, Round_Even
, gnat_node
);
3173 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
3175 /* If we have a base of zero, divide by the denominator.
3176 Otherwise, the base must be 2 and we scale the value, which
3177 we know can fit in the mantissa of the type (hence the use
3178 of that type above). */
3179 if (No (Rbase (ur_realval
)))
3181 = build_binary_op (RDIV_EXPR
,
3182 get_base_type (gnu_result_type
),
3184 UI_To_gnu (Denominator (ur_realval
),
3188 REAL_VALUE_TYPE tmp
;
3190 gcc_assert (Rbase (ur_realval
) == 2);
3191 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
3192 - UI_To_Int (Denominator (ur_realval
)));
3193 gnu_result
= build_real (gnu_result_type
, tmp
);
3197 /* Now see if we need to negate the result. Do it this way to
3198 properly handle -0. */
3199 if (UR_Is_Negative (Realval (gnat_node
)))
3201 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
3207 case N_String_Literal
:
3208 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3209 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
3211 String_Id gnat_string
= Strval (gnat_node
);
3212 int length
= String_Length (gnat_string
);
3215 if (length
>= ALLOCA_THRESHOLD
)
3216 string
= xmalloc (length
+ 1); /* in case of large strings */
3218 string
= (char *) alloca (length
+ 1);
3220 /* Build the string with the characters in the literal. Note
3221 that Ada strings are 1-origin. */
3222 for (i
= 0; i
< length
; i
++)
3223 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
3225 /* Put a null at the end of the string in case it's in a context
3226 where GCC will want to treat it as a C string. */
3229 gnu_result
= build_string (length
, string
);
3231 /* Strings in GCC don't normally have types, but we want
3232 this to not be converted to the array type. */
3233 TREE_TYPE (gnu_result
) = gnu_result_type
;
3235 if (length
>= ALLOCA_THRESHOLD
) /* free if heap-allocated */
3240 /* Build a list consisting of each character, then make
3242 String_Id gnat_string
= Strval (gnat_node
);
3243 int length
= String_Length (gnat_string
);
3245 tree gnu_list
= NULL_TREE
;
3246 tree gnu_idx
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
3248 for (i
= 0; i
< length
; i
++)
3251 = tree_cons (gnu_idx
,
3252 build_int_cst (TREE_TYPE (gnu_result_type
),
3253 Get_String_Char (gnat_string
,
3257 gnu_idx
= int_const_binop (PLUS_EXPR
, gnu_idx
, integer_one_node
,
3262 = gnat_build_constructor (gnu_result_type
, nreverse (gnu_list
));
3267 gnu_result
= Pragma_to_gnu (gnat_node
);
3270 /**************************************/
3271 /* Chapter 3: Declarations and Types: */
3272 /**************************************/
3274 case N_Subtype_Declaration
:
3275 case N_Full_Type_Declaration
:
3276 case N_Incomplete_Type_Declaration
:
3277 case N_Private_Type_Declaration
:
3278 case N_Private_Extension_Declaration
:
3279 case N_Task_Type_Declaration
:
3280 process_type (Defining_Entity (gnat_node
));
3281 gnu_result
= alloc_stmt_list ();
3284 case N_Object_Declaration
:
3285 case N_Exception_Declaration
:
3286 gnat_temp
= Defining_Entity (gnat_node
);
3287 gnu_result
= alloc_stmt_list ();
3289 /* If we are just annotating types and this object has an unconstrained
3290 or task type, don't elaborate it. */
3291 if (type_annotate_only
3292 && (((Is_Array_Type (Etype (gnat_temp
))
3293 || Is_Record_Type (Etype (gnat_temp
)))
3294 && !Is_Constrained (Etype (gnat_temp
)))
3295 || Is_Concurrent_Type (Etype (gnat_temp
))))
3298 if (Present (Expression (gnat_node
))
3299 && !(Nkind (gnat_node
) == N_Object_Declaration
3300 && No_Initialization (gnat_node
))
3301 && (!type_annotate_only
3302 || Compile_Time_Known_Value (Expression (gnat_node
))))
3304 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3305 if (Do_Range_Check (Expression (gnat_node
)))
3306 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_temp
));
3308 /* If this object has its elaboration delayed, we must force
3309 evaluation of GNU_EXPR right now and save it for when the object
3311 if (Present (Freeze_Node (gnat_temp
)))
3313 if ((Is_Public (gnat_temp
) || global_bindings_p ())
3314 && !TREE_CONSTANT (gnu_expr
))
3316 = create_var_decl (create_concat_name (gnat_temp
, "init"),
3317 NULL_TREE
, TREE_TYPE (gnu_expr
),
3318 gnu_expr
, false, Is_Public (gnat_temp
),
3319 false, false, NULL
, gnat_temp
);
3321 gnu_expr
= maybe_variable (gnu_expr
);
3323 save_gnu_tree (gnat_node
, gnu_expr
, true);
3327 gnu_expr
= NULL_TREE
;
3329 if (type_annotate_only
&& gnu_expr
&& TREE_CODE (gnu_expr
) == ERROR_MARK
)
3330 gnu_expr
= NULL_TREE
;
3332 if (No (Freeze_Node (gnat_temp
)))
3333 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
3336 case N_Object_Renaming_Declaration
:
3337 gnat_temp
= Defining_Entity (gnat_node
);
3339 /* Don't do anything if this renaming is handled by the front end or if
3340 we are just annotating types and this object has a composite or task
3341 type, don't elaborate it. We return the result in case it has any
3342 SAVE_EXPRs in it that need to be evaluated here. */
3343 if (!Is_Renaming_Of_Object (gnat_temp
)
3344 && ! (type_annotate_only
3345 && (Is_Array_Type (Etype (gnat_temp
))
3346 || Is_Record_Type (Etype (gnat_temp
))
3347 || Is_Concurrent_Type (Etype (gnat_temp
)))))
3349 = gnat_to_gnu_entity (gnat_temp
,
3350 gnat_to_gnu (Renamed_Object (gnat_temp
)), 1);
3352 gnu_result
= alloc_stmt_list ();
3355 case N_Implicit_Label_Declaration
:
3356 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
3357 gnu_result
= alloc_stmt_list ();
3360 case N_Exception_Renaming_Declaration
:
3361 case N_Number_Declaration
:
3362 case N_Package_Renaming_Declaration
:
3363 case N_Subprogram_Renaming_Declaration
:
3364 /* These are fully handled in the front end. */
3365 gnu_result
= alloc_stmt_list ();
3368 /*************************************/
3369 /* Chapter 4: Names and Expressions: */
3370 /*************************************/
3372 case N_Explicit_Dereference
:
3373 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
3374 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3375 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
3378 case N_Indexed_Component
:
3380 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
3384 Node_Id
*gnat_expr_array
;
3386 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
3387 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
3389 /* If we got a padded type, remove it too. */
3390 if (TREE_CODE (TREE_TYPE (gnu_array_object
)) == RECORD_TYPE
3391 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
3393 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
3396 gnu_result
= gnu_array_object
;
3398 /* First compute the number of dimensions of the array, then
3399 fill the expression array, the order depending on whether
3400 this is a Convention_Fortran array or not. */
3401 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
3402 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
3403 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
3404 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
3407 gnat_expr_array
= (Node_Id
*) alloca (ndim
* sizeof (Node_Id
));
3409 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
3410 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
3412 i
--, gnat_temp
= Next (gnat_temp
))
3413 gnat_expr_array
[i
] = gnat_temp
;
3415 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
3417 i
++, gnat_temp
= Next (gnat_temp
))
3418 gnat_expr_array
[i
] = gnat_temp
;
3420 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
3421 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
3423 gcc_assert (TREE_CODE (gnu_type
) == ARRAY_TYPE
);
3424 gnat_temp
= gnat_expr_array
[i
];
3425 gnu_expr
= gnat_to_gnu (gnat_temp
);
3427 if (Do_Range_Check (gnat_temp
))
3430 (gnu_array_object
, gnu_expr
,
3431 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
3432 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
3434 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
3435 gnu_result
, gnu_expr
);
3439 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3445 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
3447 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
3448 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3450 /* Do any implicit dereferences of the prefix and do any needed
3452 gnu_result
= maybe_implicit_deref (gnu_result
);
3453 gnu_result
= maybe_unconstrained_array (gnu_result
);
3454 gnu_type
= TREE_TYPE (gnu_result
);
3455 if (Do_Range_Check (gnat_range_node
))
3457 /* Get the bounds of the slice. */
3459 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
3460 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
3461 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
3462 /* Get the permitted bounds. */
3463 tree gnu_base_index_type
3464 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
));
3465 tree gnu_base_min_expr
= TYPE_MIN_VALUE (gnu_base_index_type
);
3466 tree gnu_base_max_expr
= TYPE_MAX_VALUE (gnu_base_index_type
);
3467 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
3469 /* Check to see that the minimum slice value is in range. */
3470 gnu_expr_l
= emit_index_check (gnu_result
,
3475 /* Check to see that the maximum slice value is in range. */
3476 gnu_expr_h
= emit_index_check (gnu_result
,
3481 /* Derive a good type to convert everything to. */
3482 gnu_expr_type
= get_base_type (TREE_TYPE (gnu_expr_l
));
3484 /* Build a compound expression that does the range checks and
3485 returns the low bound. */
3486 gnu_expr
= build_binary_op (COMPOUND_EXPR
, gnu_expr_type
,
3487 convert (gnu_expr_type
, gnu_expr_h
),
3488 convert (gnu_expr_type
, gnu_expr_l
));
3490 /* Build a conditional expression that does the range check and
3491 returns the low bound if the slice is not empty (max >= min),
3492 and returns the naked low bound otherwise (max < min), unless
3493 it is non-constant and the high bound is; this prevents VRP
3494 from inferring bogus ranges on the unlikely path. */
3495 gnu_expr
= fold_build3 (COND_EXPR
, gnu_expr_type
,
3496 build_binary_op (GE_EXPR
, gnu_expr_type
,
3497 convert (gnu_expr_type
,
3499 convert (gnu_expr_type
,
3502 TREE_CODE (gnu_min_expr
) != INTEGER_CST
3503 && TREE_CODE (gnu_max_expr
) == INTEGER_CST
3504 ? gnu_max_expr
: gnu_min_expr
);
3507 /* Simply return the naked low bound. */
3508 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
3510 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
3511 gnu_result
, gnu_expr
);
3515 case N_Selected_Component
:
3517 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
3518 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
3519 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
3522 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
3523 || IN (Ekind (gnat_pref_type
), Access_Kind
))
3525 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
3526 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
3527 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
3528 gnat_pref_type
= Designated_Type (gnat_pref_type
);
3531 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
3533 /* For discriminant references in tagged types always substitute the
3534 corresponding discriminant as the actual selected component. */
3536 if (Is_Tagged_Type (gnat_pref_type
))
3537 while (Present (Corresponding_Discriminant (gnat_field
)))
3538 gnat_field
= Corresponding_Discriminant (gnat_field
);
3540 /* For discriminant references of untagged types always substitute the
3541 corresponding stored discriminant. */
3543 else if (Present (Corresponding_Discriminant (gnat_field
)))
3544 gnat_field
= Original_Record_Component (gnat_field
);
3546 /* Handle extracting the real or imaginary part of a complex.
3547 The real part is the first field and the imaginary the last. */
3549 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
3550 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
3551 ? REALPART_EXPR
: IMAGPART_EXPR
,
3552 NULL_TREE
, gnu_prefix
);
3555 gnu_field
= gnat_to_gnu_field_decl (gnat_field
);
3557 /* If there are discriminants, the prefix might be
3558 evaluated more than once, which is a problem if it has
3560 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
3561 ? Designated_Type (Etype
3562 (Prefix (gnat_node
)))
3563 : Etype (Prefix (gnat_node
))))
3564 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, false);
3567 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
,
3568 (Nkind (Parent (gnat_node
))
3569 == N_Attribute_Reference
));
3572 gcc_assert (gnu_result
);
3573 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3577 case N_Attribute_Reference
:
3579 /* The attribute designator (like an enumeration value). */
3580 int attribute
= Get_Attribute_Id (Attribute_Name (gnat_node
));
3582 /* The Elab_Spec and Elab_Body attributes are special in that
3583 Prefix is a unit, not an object with a GCC equivalent. Similarly
3584 for Elaborated, since that variable isn't otherwise known. */
3585 if (attribute
== Attr_Elab_Body
|| attribute
== Attr_Elab_Spec
)
3586 return (create_subprog_decl
3587 (create_concat_name (Entity (Prefix (gnat_node
)),
3588 attribute
== Attr_Elab_Body
3589 ? "elabb" : "elabs"),
3590 NULL_TREE
, void_ftype
, NULL_TREE
, false, true, true, NULL
,
3593 gnu_result
= Attribute_to_gnu (gnat_node
, &gnu_result_type
, attribute
);
3598 /* Like 'Access as far as we are concerned. */
3599 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
3600 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
3601 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3605 case N_Extension_Aggregate
:
3609 /* ??? It is wrong to evaluate the type now, but there doesn't
3610 seem to be any other practical way of doing it. */
3612 gcc_assert (!Expansion_Delayed (gnat_node
));
3614 gnu_aggr_type
= gnu_result_type
3615 = get_unpadded_type (Etype (gnat_node
));
3617 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
3618 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
3620 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type
)));
3622 if (Null_Record_Present (gnat_node
))
3623 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL_TREE
);
3625 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
3626 || TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
3628 = assoc_to_constructor (Etype (gnat_node
),
3629 First (Component_Associations (gnat_node
)),
3631 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
3632 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
3634 Component_Type (Etype (gnat_node
)));
3635 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
3638 (COMPLEX_EXPR
, gnu_aggr_type
,
3639 gnat_to_gnu (Expression (First
3640 (Component_Associations (gnat_node
)))),
3641 gnat_to_gnu (Expression
3643 (First (Component_Associations (gnat_node
))))));
3647 gnu_result
= convert (gnu_result_type
, gnu_result
);
3652 gnu_result
= null_pointer_node
;
3653 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3656 case N_Type_Conversion
:
3657 case N_Qualified_Expression
:
3658 /* Get the operand expression. */
3659 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
3660 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3663 = convert_with_check (Etype (gnat_node
), gnu_result
,
3664 Do_Overflow_Check (gnat_node
),
3665 Do_Range_Check (Expression (gnat_node
)),
3666 Nkind (gnat_node
) == N_Type_Conversion
3667 && Float_Truncate (gnat_node
));
3670 case N_Unchecked_Type_Conversion
:
3671 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
3672 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3674 /* If the result is a pointer type, see if we are improperly
3675 converting to a stricter alignment. */
3677 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
3678 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
3680 unsigned int align
= known_alignment (gnu_result
);
3681 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
3682 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
3684 if (align
!= 0 && align
< oalign
&& !TYPE_ALIGN_OK (gnu_obj_type
))
3685 post_error_ne_tree_2
3686 ("?source alignment (^) '< alignment of & (^)",
3687 gnat_node
, Designated_Type (Etype (gnat_node
)),
3688 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
3691 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
,
3692 No_Truncation (gnat_node
));
3698 tree gnu_object
= gnat_to_gnu (Left_Opnd (gnat_node
));
3699 Node_Id gnat_range
= Right_Opnd (gnat_node
);
3703 /* GNAT_RANGE is either an N_Range node or an identifier
3704 denoting a subtype. */
3705 if (Nkind (gnat_range
) == N_Range
)
3707 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
3708 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
3710 else if (Nkind (gnat_range
) == N_Identifier
3711 || Nkind (gnat_range
) == N_Expanded_Name
)
3713 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
3715 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
3716 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
3721 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3723 /* If LOW and HIGH are identical, perform an equality test.
3724 Otherwise, ensure that GNU_OBJECT is only evaluated once
3725 and perform a full range test. */
3726 if (operand_equal_p (gnu_low
, gnu_high
, 0))
3727 gnu_result
= build_binary_op (EQ_EXPR
, gnu_result_type
,
3728 gnu_object
, gnu_low
);
3731 gnu_object
= protect_multiple_eval (gnu_object
);
3733 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
,
3734 build_binary_op (GE_EXPR
, gnu_result_type
,
3735 gnu_object
, gnu_low
),
3736 build_binary_op (LE_EXPR
, gnu_result_type
,
3737 gnu_object
, gnu_high
));
3740 if (Nkind (gnat_node
) == N_Not_In
)
3741 gnu_result
= invert_truthvalue (gnu_result
);
3746 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
3747 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
3748 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3749 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
3751 : (Rounded_Result (gnat_node
)
3752 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
3753 gnu_result_type
, gnu_lhs
, gnu_rhs
);
3756 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
3757 /* These can either be operations on booleans or on modular types.
3758 Fall through for boolean types since that's the way GNU_CODES is
3760 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
3761 Modular_Integer_Kind
))
3764 = (Nkind (gnat_node
) == N_Op_Or
? BIT_IOR_EXPR
3765 : Nkind (gnat_node
) == N_Op_And
? BIT_AND_EXPR
3768 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
3769 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
3770 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3771 gnu_result
= build_binary_op (code
, gnu_result_type
,
3776 /* ... fall through ... */
3778 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
3779 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
3780 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
3781 case N_Op_Mod
: case N_Op_Rem
:
3782 case N_Op_Rotate_Left
:
3783 case N_Op_Rotate_Right
:
3784 case N_Op_Shift_Left
:
3785 case N_Op_Shift_Right
:
3786 case N_Op_Shift_Right_Arithmetic
:
3787 case N_And_Then
: case N_Or_Else
:
3789 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
3790 bool ignore_lhs_overflow
= false;
3793 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
3794 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
3795 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3797 /* If this is a comparison operator, convert any references to
3798 an unconstrained array value into a reference to the
3800 if (TREE_CODE_CLASS (code
) == tcc_comparison
)
3802 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
3803 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
3806 /* If the result type is a private type, its full view may be a
3807 numeric subtype. The representation we need is that of its base
3808 type, given that it is the result of an arithmetic operation. */
3809 else if (Is_Private_Type (Etype (gnat_node
)))
3810 gnu_type
= gnu_result_type
3811 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
3813 /* If this is a shift whose count is not guaranteed to be correct,
3814 we need to adjust the shift count. */
3815 if (IN (Nkind (gnat_node
), N_Op_Shift
)
3816 && !Shift_Count_OK (gnat_node
))
3818 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
3820 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
3822 if (Nkind (gnat_node
) == N_Op_Rotate_Left
3823 || Nkind (gnat_node
) == N_Op_Rotate_Right
)
3824 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
3825 gnu_rhs
, gnu_max_shift
);
3826 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
)
3829 (MIN_EXPR
, gnu_count_type
,
3830 build_binary_op (MINUS_EXPR
,
3833 convert (gnu_count_type
,
3838 /* For right shifts, the type says what kind of shift to do,
3839 so we may need to choose a different type. In this case,
3840 we have to ignore integer overflow lest it propagates all
3841 the way down and causes a CE to be explicitly raised. */
3842 if (Nkind (gnat_node
) == N_Op_Shift_Right
3843 && !TYPE_UNSIGNED (gnu_type
))
3845 gnu_type
= gnat_unsigned_type (gnu_type
);
3846 ignore_lhs_overflow
= true;
3848 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
3849 && TYPE_UNSIGNED (gnu_type
))
3851 gnu_type
= gnat_signed_type (gnu_type
);
3852 ignore_lhs_overflow
= true;
3855 if (gnu_type
!= gnu_result_type
)
3857 tree gnu_old_lhs
= gnu_lhs
;
3858 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
3859 if (TREE_CODE (gnu_lhs
) == INTEGER_CST
&& ignore_lhs_overflow
)
3860 TREE_OVERFLOW (gnu_lhs
) = TREE_OVERFLOW (gnu_old_lhs
);
3861 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
3864 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
3866 /* If this is a logical shift with the shift count not verified,
3867 we must return zero if it is too large. We cannot compensate
3868 above in this case. */
3869 if ((Nkind (gnat_node
) == N_Op_Shift_Left
3870 || Nkind (gnat_node
) == N_Op_Shift_Right
)
3871 && !Shift_Count_OK (gnat_node
))
3875 build_binary_op (GE_EXPR
, integer_type_node
,
3877 convert (TREE_TYPE (gnu_rhs
),
3878 TYPE_SIZE (gnu_type
))),
3879 convert (gnu_type
, integer_zero_node
),
3884 case N_Conditional_Expression
:
3886 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
3887 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
3889 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
3891 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3892 gnu_result
= build_cond_expr (gnu_result_type
,
3893 gnat_truthvalue_conversion (gnu_cond
),
3894 gnu_true
, gnu_false
);
3899 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
3900 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3904 /* This case can apply to a boolean or a modular type.
3905 Fall through for a boolean operand since GNU_CODES is set
3906 up to handle this. */
3907 if (Is_Modular_Integer_Type (Etype (gnat_node
))
3908 || (Ekind (Etype (gnat_node
)) == E_Private_Type
3909 && Is_Modular_Integer_Type (Full_View (Etype (gnat_node
)))))
3911 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
3912 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3913 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
3918 /* ... fall through ... */
3920 case N_Op_Minus
: case N_Op_Abs
:
3921 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
3923 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
3924 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3926 gnu_result_type
= get_unpadded_type (Base_Type
3927 (Full_View (Etype (gnat_node
))));
3929 gnu_result
= build_unary_op (gnu_codes
[Nkind (gnat_node
)],
3930 gnu_result_type
, gnu_expr
);
3937 bool ignore_init_type
= false;
3939 gnat_temp
= Expression (gnat_node
);
3941 /* The Expression operand can either be an N_Identifier or
3942 Expanded_Name, which must represent a type, or a
3943 N_Qualified_Expression, which contains both the object type and an
3944 initial value for the object. */
3945 if (Nkind (gnat_temp
) == N_Identifier
3946 || Nkind (gnat_temp
) == N_Expanded_Name
)
3947 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
3948 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
3950 Entity_Id gnat_desig_type
3951 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
3953 ignore_init_type
= Has_Constrained_Partial_View (gnat_desig_type
);
3954 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
3956 gnu_init
= maybe_unconstrained_array (gnu_init
);
3957 if (Do_Range_Check (Expression (gnat_temp
)))
3958 gnu_init
= emit_range_check (gnu_init
, gnat_desig_type
);
3960 if (Is_Elementary_Type (gnat_desig_type
)
3961 || Is_Constrained (gnat_desig_type
))
3963 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
3964 gnu_init
= convert (gnu_type
, gnu_init
);
3968 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
3969 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
3970 gnu_type
= TREE_TYPE (gnu_init
);
3972 gnu_init
= convert (gnu_type
, gnu_init
);
3978 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3979 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
3980 Procedure_To_Call (gnat_node
),
3981 Storage_Pool (gnat_node
), gnat_node
,
3986 /***************************/
3987 /* Chapter 5: Statements: */
3988 /***************************/
3991 gnu_result
= build1 (LABEL_EXPR
, void_type_node
,
3992 gnat_to_gnu (Identifier (gnat_node
)));
3995 case N_Null_Statement
:
3996 gnu_result
= alloc_stmt_list ();
3999 case N_Assignment_Statement
:
4000 /* Get the LHS and RHS of the statement and convert any reference to an
4001 unconstrained array into a reference to the underlying array.
4002 If we are not to do range checking and the RHS is an N_Function_Call,
4003 pass the LHS to the call function. */
4004 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
4006 /* If the type has a size that overflows, convert this into raise of
4007 Storage_Error: execution shouldn't have gotten here anyway. */
4008 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
4009 && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs
))))
4010 gnu_result
= build_call_raise (SE_Object_Too_Large
, gnat_node
,
4011 N_Raise_Storage_Error
);
4012 else if (Nkind (Expression (gnat_node
)) == N_Function_Call
4013 && !Do_Range_Check (Expression (gnat_node
)))
4014 gnu_result
= call_to_gnu (Expression (gnat_node
),
4015 &gnu_result_type
, gnu_lhs
);
4019 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
4021 /* If range check is needed, emit code to generate it */
4022 if (Do_Range_Check (Expression (gnat_node
)))
4023 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)));
4026 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
4030 case N_If_Statement
:
4032 tree
*gnu_else_ptr
; /* Point to put next "else if" or "else". */
4034 /* Make the outer COND_EXPR. Avoid non-determinism. */
4035 gnu_result
= build3 (COND_EXPR
, void_type_node
,
4036 gnat_to_gnu (Condition (gnat_node
)),
4037 NULL_TREE
, NULL_TREE
);
4038 COND_EXPR_THEN (gnu_result
)
4039 = build_stmt_group (Then_Statements (gnat_node
), false);
4040 TREE_SIDE_EFFECTS (gnu_result
) = 1;
4041 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_result
);
4043 /* Now make a COND_EXPR for each of the "else if" parts. Put each
4044 into the previous "else" part and point to where to put any
4045 outer "else". Also avoid non-determinism. */
4046 if (Present (Elsif_Parts (gnat_node
)))
4047 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
4048 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
4050 gnu_expr
= build3 (COND_EXPR
, void_type_node
,
4051 gnat_to_gnu (Condition (gnat_temp
)),
4052 NULL_TREE
, NULL_TREE
);
4053 COND_EXPR_THEN (gnu_expr
)
4054 = build_stmt_group (Then_Statements (gnat_temp
), false);
4055 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
4056 set_expr_location_from_node (gnu_expr
, gnat_temp
);
4057 *gnu_else_ptr
= gnu_expr
;
4058 gnu_else_ptr
= &COND_EXPR_ELSE (gnu_expr
);
4061 *gnu_else_ptr
= build_stmt_group (Else_Statements (gnat_node
), false);
4065 case N_Case_Statement
:
4066 gnu_result
= Case_Statement_to_gnu (gnat_node
);
4069 case N_Loop_Statement
:
4070 gnu_result
= Loop_Statement_to_gnu (gnat_node
);
4073 case N_Block_Statement
:
4074 start_stmt_group ();
4076 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
4077 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
4079 gnu_result
= end_stmt_group ();
4081 if (Present (Identifier (gnat_node
)))
4082 mark_out_of_scope (Entity (Identifier (gnat_node
)));
4085 case N_Exit_Statement
:
4087 = build2 (EXIT_STMT
, void_type_node
,
4088 (Present (Condition (gnat_node
))
4089 ? gnat_to_gnu (Condition (gnat_node
)) : NULL_TREE
),
4090 (Present (Name (gnat_node
))
4091 ? get_gnu_tree (Entity (Name (gnat_node
)))
4092 : TREE_VALUE (gnu_loop_label_stack
)));
4095 case N_Return_Statement
:
4097 /* The gnu function type of the subprogram currently processed. */
4098 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
4099 /* The return value from the subprogram. */
4100 tree gnu_ret_val
= NULL_TREE
;
4101 /* The place to put the return value. */
4104 /* If we are dealing with a "return;" from an Ada procedure with
4105 parameters passed by copy in copy out, we need to return a record
4106 containing the final values of these parameters. If the list
4107 contains only one entry, return just that entry.
4109 For a full description of the copy in copy out parameter mechanism,
4110 see the part of the gnat_to_gnu_entity routine dealing with the
4111 translation of subprograms.
4113 But if we have a return label defined, convert this into
4114 a branch to that label. */
4116 if (TREE_VALUE (gnu_return_label_stack
))
4118 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
4119 TREE_VALUE (gnu_return_label_stack
));
4123 else if (TYPE_CI_CO_LIST (gnu_subprog_type
))
4125 gnu_lhs
= DECL_RESULT (current_function_decl
);
4126 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type
)) == 1)
4127 gnu_ret_val
= TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type
));
4130 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
4131 TYPE_CI_CO_LIST (gnu_subprog_type
));
4134 /* If the Ada subprogram is a function, we just need to return the
4135 expression. If the subprogram returns an unconstrained
4136 array, we have to allocate a new version of the result and
4137 return it. If we return by reference, return a pointer. */
4139 else if (Present (Expression (gnat_node
)))
4141 /* If the current function returns by target pointer and we
4142 are doing a call, pass that target to the call. */
4143 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type
)
4144 && Nkind (Expression (gnat_node
)) == N_Function_Call
)
4147 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
4148 DECL_ARGUMENTS (current_function_decl
));
4149 gnu_result
= call_to_gnu (Expression (gnat_node
),
4150 &gnu_result_type
, gnu_lhs
);
4154 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
4156 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type
))
4157 /* The original return type was unconstrained so dereference
4158 the TARGET pointer in the actual return value's type. */
4160 = build_unary_op (INDIRECT_REF
, TREE_TYPE (gnu_ret_val
),
4161 DECL_ARGUMENTS (current_function_decl
));
4163 gnu_lhs
= DECL_RESULT (current_function_decl
);
4165 /* Do not remove the padding from GNU_RET_VAL if the inner
4166 type is self-referential since we want to allocate the fixed
4167 size in that case. */
4168 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
4169 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0)))
4171 && (TYPE_IS_PADDING_P
4172 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
4173 && (CONTAINS_PLACEHOLDER_P
4174 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
)))))
4175 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
4177 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type
)
4178 || By_Ref (gnat_node
))
4180 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
4182 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
))
4184 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
4186 = build_allocator (TREE_TYPE (gnu_ret_val
),
4188 TREE_TYPE (gnu_subprog_type
),
4189 Procedure_To_Call (gnat_node
),
4190 Storage_Pool (gnat_node
),
4196 /* If the Ada subprogram is a regular procedure, just return. */
4197 gnu_lhs
= NULL_TREE
;
4199 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type
))
4202 gnu_result
= build_binary_op (MODIFY_EXPR
, NULL_TREE
,
4203 gnu_lhs
, gnu_ret_val
);
4204 add_stmt_with_node (gnu_result
, gnat_node
);
4205 gnu_lhs
= NULL_TREE
;
4208 gnu_result
= build_return_expr (gnu_lhs
, gnu_ret_val
);
4212 case N_Goto_Statement
:
4213 gnu_result
= build1 (GOTO_EXPR
, void_type_node
,
4214 gnat_to_gnu (Name (gnat_node
)));
4217 /****************************/
4218 /* Chapter 6: Subprograms: */
4219 /****************************/
4221 case N_Subprogram_Declaration
:
4222 /* Unless there is a freeze node, declare the subprogram. We consider
4223 this a "definition" even though we're not generating code for
4224 the subprogram because we will be making the corresponding GCC
4227 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
4228 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
4230 gnu_result
= alloc_stmt_list ();
4233 case N_Abstract_Subprogram_Declaration
:
4234 /* This subprogram doesn't exist for code generation purposes, but we
4235 have to elaborate the types of any parameters and result, unless
4236 they are imported types (nothing to generate in this case). */
4238 /* Process the parameter types first. */
4241 = First_Formal_With_Extras
4242 (Defining_Entity (Specification (gnat_node
)));
4243 Present (gnat_temp
);
4244 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
4245 if (Is_Itype (Etype (gnat_temp
))
4246 && !From_With_Type (Etype (gnat_temp
)))
4247 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
4250 /* Then the result type, set to Standard_Void_Type for procedures. */
4253 Entity_Id gnat_temp_type
4254 = Etype (Defining_Entity (Specification (gnat_node
)));
4256 if (Is_Itype (gnat_temp_type
) && !From_With_Type (gnat_temp_type
))
4257 gnat_to_gnu_entity (Etype (gnat_temp_type
), NULL_TREE
, 0);
4260 gnu_result
= alloc_stmt_list ();
4263 case N_Defining_Program_Unit_Name
:
4264 /* For a child unit identifier go up a level to get the
4265 specification. We get this when we try to find the spec of
4266 a child unit package that is the compilation unit being compiled. */
4267 gnu_result
= gnat_to_gnu (Parent (gnat_node
));
4270 case N_Subprogram_Body
:
4271 Subprogram_Body_to_gnu (gnat_node
);
4272 gnu_result
= alloc_stmt_list ();
4275 case N_Function_Call
:
4276 case N_Procedure_Call_Statement
:
4277 gnu_result
= call_to_gnu (gnat_node
, &gnu_result_type
, NULL_TREE
);
4280 /*************************/
4281 /* Chapter 7: Packages: */
4282 /*************************/
4284 case N_Package_Declaration
:
4285 gnu_result
= gnat_to_gnu (Specification (gnat_node
));
4288 case N_Package_Specification
:
4290 start_stmt_group ();
4291 process_decls (Visible_Declarations (gnat_node
),
4292 Private_Declarations (gnat_node
), Empty
, true, true);
4293 gnu_result
= end_stmt_group ();
4296 case N_Package_Body
:
4298 /* If this is the body of a generic package - do nothing */
4299 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
4301 gnu_result
= alloc_stmt_list ();
4305 start_stmt_group ();
4306 process_decls (Declarations (gnat_node
), Empty
, Empty
, true, true);
4308 if (Present (Handled_Statement_Sequence (gnat_node
)))
4309 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node
)));
4311 gnu_result
= end_stmt_group ();
4314 /*********************************/
4315 /* Chapter 8: Visibility Rules: */
4316 /*********************************/
4318 case N_Use_Package_Clause
:
4319 case N_Use_Type_Clause
:
4320 /* Nothing to do here - but these may appear in list of declarations */
4321 gnu_result
= alloc_stmt_list ();
4324 /***********************/
4325 /* Chapter 9: Tasks: */
4326 /***********************/
4328 case N_Protected_Type_Declaration
:
4329 gnu_result
= alloc_stmt_list ();
4332 case N_Single_Task_Declaration
:
4333 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
4334 gnu_result
= alloc_stmt_list ();
4337 /***********************************************************/
4338 /* Chapter 10: Program Structure and Compilation Issues: */
4339 /***********************************************************/
4341 case N_Compilation_Unit
:
4343 /* This is not called for the main unit, which is handled in function
4345 start_stmt_group ();
4348 Compilation_Unit_to_gnu (gnat_node
);
4349 gnu_result
= alloc_stmt_list ();
4352 case N_Subprogram_Body_Stub
:
4353 case N_Package_Body_Stub
:
4354 case N_Protected_Body_Stub
:
4355 case N_Task_Body_Stub
:
4356 /* Simply process whatever unit is being inserted. */
4357 gnu_result
= gnat_to_gnu (Unit (Library_Unit (gnat_node
)));
4361 gnu_result
= gnat_to_gnu (Proper_Body (gnat_node
));
4364 /***************************/
4365 /* Chapter 11: Exceptions: */
4366 /***************************/
4368 case N_Handled_Sequence_Of_Statements
:
4369 /* If there is an At_End procedure attached to this node, and the EH
4370 mechanism is SJLJ, we must have at least a corresponding At_End
4371 handler, unless the No_Exception_Handlers restriction is set. */
4372 gcc_assert (type_annotate_only
4373 || Exception_Mechanism
!= Setjmp_Longjmp
4374 || No (At_End_Proc (gnat_node
))
4375 || Present (Exception_Handlers (gnat_node
))
4376 || No_Exception_Handlers_Set ());
4378 gnu_result
= Handled_Sequence_Of_Statements_to_gnu (gnat_node
);
4381 case N_Exception_Handler
:
4382 if (Exception_Mechanism
== Setjmp_Longjmp
)
4383 gnu_result
= Exception_Handler_to_gnu_sjlj (gnat_node
);
4384 else if (Exception_Mechanism
== Back_End_Exceptions
)
4385 gnu_result
= Exception_Handler_to_gnu_zcx (gnat_node
);
4391 case N_Push_Constraint_Error_Label
:
4392 push_exception_label_stack (&gnu_constraint_error_label_stack
,
4393 Exception_Label (gnat_node
));
4396 case N_Push_Storage_Error_Label
:
4397 push_exception_label_stack (&gnu_storage_error_label_stack
,
4398 Exception_Label (gnat_node
));
4401 case N_Push_Program_Error_Label
:
4402 push_exception_label_stack (&gnu_program_error_label_stack
,
4403 Exception_Label (gnat_node
));
4406 case N_Pop_Constraint_Error_Label
:
4407 gnu_constraint_error_label_stack
4408 = TREE_CHAIN (gnu_constraint_error_label_stack
);
4411 case N_Pop_Storage_Error_Label
:
4412 gnu_storage_error_label_stack
4413 = TREE_CHAIN (gnu_storage_error_label_stack
);
4416 case N_Pop_Program_Error_Label
:
4417 gnu_program_error_label_stack
4418 = TREE_CHAIN (gnu_program_error_label_stack
);
4421 /*******************************/
4422 /* Chapter 12: Generic Units: */
4423 /*******************************/
4425 case N_Generic_Function_Renaming_Declaration
:
4426 case N_Generic_Package_Renaming_Declaration
:
4427 case N_Generic_Procedure_Renaming_Declaration
:
4428 case N_Generic_Package_Declaration
:
4429 case N_Generic_Subprogram_Declaration
:
4430 case N_Package_Instantiation
:
4431 case N_Procedure_Instantiation
:
4432 case N_Function_Instantiation
:
4433 /* These nodes can appear on a declaration list but there is nothing to
4434 to be done with them. */
4435 gnu_result
= alloc_stmt_list ();
4438 /***************************************************/
4439 /* Chapter 13: Representation Clauses and */
4440 /* Implementation-Dependent Features: */
4441 /***************************************************/
4443 case N_Attribute_Definition_Clause
:
4445 gnu_result
= alloc_stmt_list ();
4447 /* The only one we need deal with is for 'Address. For the others, SEM
4448 puts the information elsewhere. We need only deal with 'Address
4449 if the object has a Freeze_Node (which it never will currently). */
4450 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
4451 || No (Freeze_Node (Entity (Name (gnat_node
)))))
4454 /* Get the value to use as the address and save it as the
4455 equivalent for GNAT_TEMP. When the object is frozen,
4456 gnat_to_gnu_entity will do the right thing. */
4457 save_gnu_tree (Entity (Name (gnat_node
)),
4458 gnat_to_gnu (Expression (gnat_node
)), true);
4461 case N_Enumeration_Representation_Clause
:
4462 case N_Record_Representation_Clause
:
4464 /* We do nothing with these. SEM puts the information elsewhere. */
4465 gnu_result
= alloc_stmt_list ();
4468 case N_Code_Statement
:
4469 if (!type_annotate_only
)
4471 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
4472 tree gnu_inputs
= NULL_TREE
, gnu_outputs
= NULL_TREE
;
4473 tree gnu_clobbers
= NULL_TREE
, tail
;
4474 bool allows_mem
, allows_reg
, fake
;
4475 int ninputs
, noutputs
, i
;
4476 const char **oconstraints
;
4477 const char *constraint
;
4480 /* First retrieve the 3 operand lists built by the front-end. */
4481 Setup_Asm_Outputs (gnat_node
);
4482 while (Present (gnat_temp
= Asm_Output_Variable ()))
4484 tree gnu_value
= gnat_to_gnu (gnat_temp
);
4485 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
4486 (Asm_Output_Constraint ()));
4488 gnu_outputs
= tree_cons (gnu_constr
, gnu_value
, gnu_outputs
);
4492 Setup_Asm_Inputs (gnat_node
);
4493 while (Present (gnat_temp
= Asm_Input_Value ()))
4495 tree gnu_value
= gnat_to_gnu (gnat_temp
);
4496 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
4497 (Asm_Input_Constraint ()));
4499 gnu_inputs
= tree_cons (gnu_constr
, gnu_value
, gnu_inputs
);
4503 Clobber_Setup (gnat_node
);
4504 while ((clobber
= Clobber_Get_Next ()))
4506 = tree_cons (NULL_TREE
,
4507 build_string (strlen (clobber
) + 1, clobber
),
4510 /* Then perform some standard checking and processing on the
4511 operands. In particular, mark them addressable if needed. */
4512 gnu_outputs
= nreverse (gnu_outputs
);
4513 noutputs
= list_length (gnu_outputs
);
4514 gnu_inputs
= nreverse (gnu_inputs
);
4515 ninputs
= list_length (gnu_inputs
);
4517 = (const char **) alloca (noutputs
* sizeof (const char *));
4519 for (i
= 0, tail
= gnu_outputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
4521 tree output
= TREE_VALUE (tail
);
4523 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
4524 oconstraints
[i
] = constraint
;
4526 if (parse_output_constraint (&constraint
, i
, ninputs
, noutputs
,
4527 &allows_mem
, &allows_reg
, &fake
))
4529 /* If the operand is going to end up in memory,
4530 mark it addressable. Note that we don't test
4531 allows_mem like in the input case below; this
4532 is modelled on the C front-end. */
4534 && !gnat_mark_addressable (output
))
4535 output
= error_mark_node
;
4538 output
= error_mark_node
;
4540 TREE_VALUE (tail
) = output
;
4543 for (i
= 0, tail
= gnu_inputs
; tail
; ++i
, tail
= TREE_CHAIN (tail
))
4545 tree input
= TREE_VALUE (tail
);
4547 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail
)));
4549 if (parse_input_constraint (&constraint
, i
, ninputs
, noutputs
,
4551 &allows_mem
, &allows_reg
))
4553 /* If the operand is going to end up in memory,
4554 mark it addressable. */
4555 if (!allows_reg
&& allows_mem
4556 && !gnat_mark_addressable (input
))
4557 input
= error_mark_node
;
4560 input
= error_mark_node
;
4562 TREE_VALUE (tail
) = input
;
4565 gnu_result
= build4 (ASM_EXPR
, void_type_node
,
4566 gnu_template
, gnu_outputs
,
4567 gnu_inputs
, gnu_clobbers
);
4568 ASM_VOLATILE_P (gnu_result
) = Is_Asm_Volatile (gnat_node
);
4571 gnu_result
= alloc_stmt_list ();
4575 /***************************************************/
4577 /***************************************************/
4579 case N_Freeze_Entity
:
4580 start_stmt_group ();
4581 process_freeze_entity (gnat_node
);
4582 process_decls (Actions (gnat_node
), Empty
, Empty
, true, true);
4583 gnu_result
= end_stmt_group ();
4586 case N_Itype_Reference
:
4587 if (!present_gnu_tree (Itype (gnat_node
)))
4588 process_type (Itype (gnat_node
));
4590 gnu_result
= alloc_stmt_list ();
4593 case N_Free_Statement
:
4594 if (!type_annotate_only
)
4596 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
4597 tree gnu_ptr_type
= TREE_TYPE (gnu_ptr
);
4599 tree gnu_actual_obj_type
= 0;
4602 unsigned int default_allocator_alignment
4603 = get_target_default_allocator_alignment () * BITS_PER_UNIT
;
4605 /* If this is a thin pointer, we must dereference it to create
4606 a fat pointer, then go back below to a thin pointer. The
4607 reason for this is that we need a fat pointer someplace in
4608 order to properly compute the size. */
4609 if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
4610 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
4611 build_unary_op (INDIRECT_REF
, NULL_TREE
,
4614 /* If this is an unconstrained array, we know the object must
4615 have been allocated with the template in front of the object.
4616 So pass the template address, but get the total size. Do this
4617 by converting to a thin pointer. */
4618 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
4620 = convert (build_pointer_type
4621 (TYPE_OBJECT_RECORD_TYPE
4622 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
4625 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
4627 if (Present (Actual_Designated_Subtype (gnat_node
)))
4630 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node
));
4632 if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
4634 = build_unc_object_type_from_ptr (gnu_ptr_type
,
4635 gnu_actual_obj_type
,
4636 get_identifier ("DEALLOC"));
4639 gnu_actual_obj_type
= gnu_obj_type
;
4641 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_actual_obj_type
);
4642 align
= TYPE_ALIGN (gnu_obj_type
);
4644 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
4645 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
4647 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
4648 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
4649 tree gnu_byte_offset
4650 = convert (sizetype
,
4651 size_diffop (size_zero_node
, gnu_pos
));
4652 gnu_byte_offset
= fold_build1 (NEGATE_EXPR
, sizetype
, gnu_byte_offset
);
4654 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
4655 gnu_ptr
= build_binary_op (POINTER_PLUS_EXPR
, gnu_char_ptr_type
,
4656 gnu_ptr
, gnu_byte_offset
);
4659 /* If the object was allocated from the default storage pool, the
4660 alignement was greater than what the allocator provides, and this
4661 is not a fat or thin pointer, what we have in gnu_ptr here is an
4662 address dynamically adjusted to match the alignment requirement
4663 (see build_allocator). What we need to pass to free is the
4664 initial allocator's return value, which has been stored just in
4665 front of the block we have. */
4667 if (No (Procedure_To_Call (gnat_node
))
4668 && align
> default_allocator_alignment
4669 && ! TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type
))
4672 as * (void **)((void *)GNU_PTR - (void *)sizeof(void *))
4676 = (void *)GNU_PTR - (void *)sizeof (void *)) */
4679 (POINTER_PLUS_EXPR
, ptr_void_type_node
,
4680 convert (ptr_void_type_node
, gnu_ptr
),
4681 size_int (-POINTER_SIZE
/BITS_PER_UNIT
));
4683 /* GNU_PTR (void *) = *(void **)GNU_PTR */
4686 (INDIRECT_REF
, NULL_TREE
,
4687 convert (build_pointer_type (ptr_void_type_node
),
4691 gnu_result
= build_call_alloc_dealloc (gnu_ptr
, gnu_obj_size
, align
,
4692 Procedure_To_Call (gnat_node
),
4693 Storage_Pool (gnat_node
),
4698 case N_Raise_Constraint_Error
:
4699 case N_Raise_Program_Error
:
4700 case N_Raise_Storage_Error
:
4701 if (type_annotate_only
)
4703 gnu_result
= alloc_stmt_list ();
4707 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4709 = build_call_raise (UI_To_Int (Reason (gnat_node
)), gnat_node
,
4712 /* If the type is VOID, this is a statement, so we need to
4713 generate the code for the call. Handle a Condition, if there
4715 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
4717 set_expr_location_from_node (gnu_result
, gnat_node
);
4719 if (Present (Condition (gnat_node
)))
4720 gnu_result
= build3 (COND_EXPR
, void_type_node
,
4721 gnat_to_gnu (Condition (gnat_node
)),
4722 gnu_result
, alloc_stmt_list ());
4725 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
4728 case N_Validate_Unchecked_Conversion
:
4729 /* If the result is a pointer type, see if we are either converting
4730 from a non-pointer or from a pointer to a type with a different
4731 alias set and warn if so. If the result defined in the same unit as
4732 this unchecked conversion, we can allow this because we can know to
4733 make that type have alias set 0. */
4735 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
4736 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
4738 if (POINTER_TYPE_P (gnu_target_type
)
4739 && !In_Same_Source_Unit (Target_Type (gnat_node
), gnat_node
)
4740 && get_alias_set (TREE_TYPE (gnu_target_type
)) != 0
4741 && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node
)))
4742 && (!POINTER_TYPE_P (gnu_source_type
)
4743 || (get_alias_set (TREE_TYPE (gnu_source_type
))
4744 != get_alias_set (TREE_TYPE (gnu_target_type
)))))
4747 ("?possible aliasing problem for type&",
4748 gnat_node
, Target_Type (gnat_node
));
4750 ("\\?use -fno-strict-aliasing switch for references",
4753 ("\\?or use `pragma No_Strict_Aliasing (&);`",
4754 gnat_node
, Target_Type (gnat_node
));
4757 /* The No_Strict_Aliasing flag is not propagated to the back-end for
4758 fat pointers so unconditionally warn in problematic cases. */
4759 else if (TYPE_FAT_POINTER_P (gnu_target_type
))
4762 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type
)));
4764 if (get_alias_set (array_type
) != 0
4765 && (!TYPE_FAT_POINTER_P (gnu_source_type
)
4766 || (get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type
))))
4767 != get_alias_set (array_type
))))
4770 ("?possible aliasing problem for type&",
4771 gnat_node
, Target_Type (gnat_node
));
4773 ("\\?use -fno-strict-aliasing switch for references",
4778 gnu_result
= alloc_stmt_list ();
4781 case N_Raise_Statement
:
4782 case N_Function_Specification
:
4783 case N_Procedure_Specification
:
4785 case N_Component_Association
:
4788 gcc_assert (type_annotate_only
);
4789 gnu_result
= alloc_stmt_list ();
4792 /* If we pushed our level as part of processing the elaboration routine,
4794 if (went_into_elab_proc
)
4796 add_stmt (gnu_result
);
4798 gnu_result
= end_stmt_group ();
4799 current_function_decl
= NULL_TREE
;
4802 /* Set the location information on the result if it is a real expression.
4803 References can be reused for multiple GNAT nodes and they would get
4804 the location information of their last use. Note that we may have
4805 no result if we tried to build a CALL_EXPR node to a procedure with
4806 no side-effects and optimization is enabled. */
4807 if (gnu_result
&& EXPR_P (gnu_result
) && !REFERENCE_CLASS_P (gnu_result
))
4808 set_expr_location_from_node (gnu_result
, gnat_node
);
4810 /* If we're supposed to return something of void_type, it means we have
4811 something we're elaborating for effect, so just return. */
4812 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
4815 /* If the result is a constant that overflows, raise constraint error. */
4816 else if (TREE_CODE (gnu_result
) == INTEGER_CST
4817 && TREE_OVERFLOW (gnu_result
))
4819 post_error ("Constraint_Error will be raised at run-time?", gnat_node
);
4822 = build1 (NULL_EXPR
, gnu_result_type
,
4823 build_call_raise (CE_Overflow_Check_Failed
, gnat_node
,
4824 N_Raise_Constraint_Error
));
4827 /* If our result has side-effects and is of an unconstrained type,
4828 make a SAVE_EXPR so that we can be sure it will only be referenced
4829 once. Note we must do this before any conversions. */
4830 if (TREE_SIDE_EFFECTS (gnu_result
)
4831 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
4832 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))))
4833 gnu_result
= gnat_stabilize_reference (gnu_result
, false);
4835 /* Now convert the result to the proper type. If the type is void or if
4836 we have no result, return error_mark_node to show we have no result.
4837 If the type of the result is correct or if we have a label (which doesn't
4838 have any well-defined type), return our result. Also don't do the
4839 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4840 since those are the cases where the front end may have the type wrong due
4841 to "instantiating" the unconstrained record with discriminant values
4842 or if this is a FIELD_DECL. If this is the Name of an assignment
4843 statement or a parameter of a procedure call, return what we have since
4844 the RHS has to be converted to our type there in that case, unless
4845 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
4846 record types with the same name and GNU_RESULT_TYPE has BLKmode, don't
4847 convert. This will be the case when we are converting from a packable
4848 type to its actual type and we need those conversions to be NOPs in
4849 order for assignments into these types to work properly. Finally,
4850 don't convert integral types that are the operand of an unchecked
4851 conversion since we need to ignore those conversions (for 'Valid).
4852 Otherwise, convert the result to the proper type. */
4854 if (Present (Parent (gnat_node
))
4855 && ((Nkind (Parent (gnat_node
)) == N_Assignment_Statement
4856 && Name (Parent (gnat_node
)) == gnat_node
)
4857 || (Nkind (Parent (gnat_node
)) == N_Procedure_Call_Statement
4858 && Name (Parent (gnat_node
)) != gnat_node
)
4859 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
4860 && !AGGREGATE_TYPE_P (gnu_result_type
)
4861 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
4862 || Nkind (Parent (gnat_node
)) == N_Parameter_Association
)
4863 && !(TYPE_SIZE (gnu_result_type
)
4864 && TYPE_SIZE (TREE_TYPE (gnu_result
))
4865 && (AGGREGATE_TYPE_P (gnu_result_type
)
4866 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
4867 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
4868 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
4870 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
4871 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
4872 && (CONTAINS_PLACEHOLDER_P
4873 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
4874 && !(TREE_CODE (gnu_result_type
) == RECORD_TYPE
4875 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type
))))
4877 /* In this case remove padding only if the inner object type is the
4878 same as gnu_result_type or is of self-referential size (in that later
4879 case it must be an object of unconstrained type with a default
4880 discriminant). We want to avoid copying too much data. */
4881 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4882 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
4883 && (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
)))
4885 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
4886 (TREE_TYPE (gnu_result
)))))))
4887 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4891 else if (TREE_CODE (gnu_result
) == LABEL_DECL
4892 || TREE_CODE (gnu_result
) == FIELD_DECL
4893 || TREE_CODE (gnu_result
) == ERROR_MARK
4894 || (TYPE_SIZE (gnu_result_type
)
4895 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
4896 && TREE_CODE (gnu_result
) != INDIRECT_REF
4897 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
4898 || ((TYPE_NAME (gnu_result_type
)
4899 == TYPE_NAME (TREE_TYPE (gnu_result
)))
4900 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
4901 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4902 && TYPE_MODE (gnu_result_type
) == BLKmode
))
4904 /* Remove any padding record, but do nothing more in this case. */
4905 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4906 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
4907 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4911 else if (gnu_result
== error_mark_node
4912 || gnu_result_type
== void_type_node
)
4913 gnu_result
= error_mark_node
;
4914 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
4915 gnu_result
= convert (gnu_result_type
, gnu_result
);
4917 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4918 while ((TREE_CODE (gnu_result
) == NOP_EXPR
4919 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
4920 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
4921 gnu_result
= TREE_OPERAND (gnu_result
, 0);
4926 /* Subroutine of above to push the exception label stack. GNU_STACK is
4927 a pointer to the stack to update and GNAT_LABEL, if present, is the
4928 label to push onto the stack. */
4931 push_exception_label_stack (tree
*gnu_stack
, Entity_Id gnat_label
)
4933 tree gnu_label
= (Present (gnat_label
)
4934 ? gnat_to_gnu_entity (gnat_label
, NULL_TREE
, 0)
4937 *gnu_stack
= tree_cons (NULL_TREE
, gnu_label
, *gnu_stack
);
4940 /* Record the current code position in GNAT_NODE. */
4943 record_code_position (Node_Id gnat_node
)
4945 tree stmt_stmt
= build1 (STMT_STMT
, void_type_node
, NULL_TREE
);
4947 add_stmt_with_node (stmt_stmt
, gnat_node
);
4948 save_gnu_tree (gnat_node
, stmt_stmt
, true);
4951 /* Insert the code for GNAT_NODE at the position saved for that node. */
4954 insert_code_for (Node_Id gnat_node
)
4956 STMT_STMT_STMT (get_gnu_tree (gnat_node
)) = gnat_to_gnu (gnat_node
);
4957 save_gnu_tree (gnat_node
, NULL_TREE
, true);
4960 /* Start a new statement group chained to the previous group. */
4963 start_stmt_group (void)
4965 struct stmt_group
*group
= stmt_group_free_list
;
4967 /* First see if we can get one from the free list. */
4969 stmt_group_free_list
= group
->previous
;
4971 group
= (struct stmt_group
*) ggc_alloc (sizeof (struct stmt_group
));
4973 group
->previous
= current_stmt_group
;
4974 group
->stmt_list
= group
->block
= group
->cleanups
= NULL_TREE
;
4975 current_stmt_group
= group
;
4978 /* Add GNU_STMT to the current statement group. */
4981 add_stmt (tree gnu_stmt
)
4983 append_to_statement_list (gnu_stmt
, ¤t_stmt_group
->stmt_list
);
4986 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
4989 add_stmt_with_node (tree gnu_stmt
, Node_Id gnat_node
)
4991 if (Present (gnat_node
))
4992 set_expr_location_from_node (gnu_stmt
, gnat_node
);
4993 add_stmt (gnu_stmt
);
4996 /* Add a declaration statement for GNU_DECL to the current statement group.
4997 Get SLOC from Entity_Id. */
5000 add_decl_expr (tree gnu_decl
, Entity_Id gnat_entity
)
5002 tree type
= TREE_TYPE (gnu_decl
);
5003 tree gnu_stmt
, gnu_init
, gnu_lhs
;
5005 /* If this is a variable that Gigi is to ignore, we may have been given
5006 an ERROR_MARK. So test for it. We also might have been given a
5007 reference for a renaming. So only do something for a decl. Also
5008 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
5009 if (!DECL_P (gnu_decl
)
5010 || (TREE_CODE (gnu_decl
) == TYPE_DECL
5011 && TREE_CODE (type
) == UNCONSTRAINED_ARRAY_TYPE
))
5014 gnu_stmt
= build1 (DECL_EXPR
, void_type_node
, gnu_decl
);
5016 /* If we are global, we don't want to actually output the DECL_EXPR for
5017 this decl since we already have evaluated the expressions in the
5018 sizes and positions as globals and doing it again would be wrong. */
5019 if (global_bindings_p ())
5021 /* Mark everything as used to prevent node sharing with subprograms.
5022 Note that walk_tree knows how to handle TYPE_DECL, but neither
5023 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
5024 walk_tree (&gnu_stmt
, mark_visited
, NULL
, NULL
);
5025 if (TREE_CODE (gnu_decl
) == VAR_DECL
5026 || TREE_CODE (gnu_decl
) == CONST_DECL
)
5028 walk_tree (&DECL_SIZE (gnu_decl
), mark_visited
, NULL
, NULL
);
5029 walk_tree (&DECL_SIZE_UNIT (gnu_decl
), mark_visited
, NULL
, NULL
);
5030 walk_tree (&DECL_INITIAL (gnu_decl
), mark_visited
, NULL
, NULL
);
5034 add_stmt_with_node (gnu_stmt
, gnat_entity
);
5036 /* If this is a variable and an initializer is attached to it, it must be
5037 valid for the context. Similar to init_const in create_var_decl_1. */
5038 if (TREE_CODE (gnu_decl
) == VAR_DECL
5039 && (gnu_init
= DECL_INITIAL (gnu_decl
)) != NULL_TREE
5040 && (TYPE_MAIN_VARIANT (type
) != TYPE_MAIN_VARIANT (TREE_TYPE (gnu_init
))
5041 || (TREE_STATIC (gnu_decl
)
5042 && !initializer_constant_valid_p (gnu_init
,
5043 TREE_TYPE (gnu_init
)))))
5045 /* If GNU_DECL has a padded type, convert it to the unpadded
5046 type so the assignment is done properly. */
5047 if (TREE_CODE (type
) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type
))
5048 gnu_lhs
= convert (TREE_TYPE (TYPE_FIELDS (type
)), gnu_decl
);
5052 gnu_stmt
= build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_init
);
5054 DECL_INITIAL (gnu_decl
) = NULL_TREE
;
5055 if (TREE_READONLY (gnu_decl
))
5057 TREE_READONLY (gnu_decl
) = 0;
5058 DECL_READONLY_ONCE_ELAB (gnu_decl
) = 1;
5061 add_stmt_with_node (gnu_stmt
, gnat_entity
);
5065 /* Utility function to mark nodes with TREE_VISITED and types as having their
5066 sized gimplified. Called from walk_tree. We use this to indicate all
5067 variable sizes and positions in global types may not be shared by any
5071 mark_visited (tree
*tp
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
5073 if (TREE_VISITED (*tp
))
5076 /* Don't mark a dummy type as visited because we want to mark its sizes
5077 and fields once it's filled in. */
5078 else if (!TYPE_IS_DUMMY_P (*tp
))
5079 TREE_VISITED (*tp
) = 1;
5082 TYPE_SIZES_GIMPLIFIED (*tp
) = 1;
5087 /* Utility function to unshare expressions wrapped up in a SAVE_EXPR. */
5090 unshare_save_expr (tree
*tp
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5091 void *data ATTRIBUTE_UNUSED
)
5095 if (TREE_CODE (t
) == SAVE_EXPR
)
5096 TREE_OPERAND (t
, 0) = unshare_expr (TREE_OPERAND (t
, 0));
5101 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
5102 set its location to that of GNAT_NODE if present. */
5105 add_cleanup (tree gnu_cleanup
, Node_Id gnat_node
)
5107 if (Present (gnat_node
))
5108 set_expr_location_from_node (gnu_cleanup
, gnat_node
);
5109 append_to_statement_list (gnu_cleanup
, ¤t_stmt_group
->cleanups
);
5112 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
5115 set_block_for_group (tree gnu_block
)
5117 gcc_assert (!current_stmt_group
->block
);
5118 current_stmt_group
->block
= gnu_block
;
5121 /* Return code corresponding to the current code group. It is normally
5122 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
5123 BLOCK or cleanups were set. */
5126 end_stmt_group (void)
5128 struct stmt_group
*group
= current_stmt_group
;
5129 tree gnu_retval
= group
->stmt_list
;
5131 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
5132 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
5133 make a BIND_EXPR. Note that we nest in that because the cleanup may
5134 reference variables in the block. */
5135 if (gnu_retval
== NULL_TREE
)
5136 gnu_retval
= alloc_stmt_list ();
5138 if (group
->cleanups
)
5139 gnu_retval
= build2 (TRY_FINALLY_EXPR
, void_type_node
, gnu_retval
,
5142 if (current_stmt_group
->block
)
5143 gnu_retval
= build3 (BIND_EXPR
, void_type_node
, BLOCK_VARS (group
->block
),
5144 gnu_retval
, group
->block
);
5146 /* Remove this group from the stack and add it to the free list. */
5147 current_stmt_group
= group
->previous
;
5148 group
->previous
= stmt_group_free_list
;
5149 stmt_group_free_list
= group
;
5154 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
5158 add_stmt_list (List_Id gnat_list
)
5162 if (Present (gnat_list
))
5163 for (gnat_node
= First (gnat_list
); Present (gnat_node
);
5164 gnat_node
= Next (gnat_node
))
5165 add_stmt (gnat_to_gnu (gnat_node
));
5168 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
5169 If BINDING_P is true, push and pop a binding level around the list. */
5172 build_stmt_group (List_Id gnat_list
, bool binding_p
)
5174 start_stmt_group ();
5178 add_stmt_list (gnat_list
);
5182 return end_stmt_group ();
5185 /* Push and pop routines for stacks. We keep a free list around so we
5186 don't waste tree nodes. */
5189 push_stack (tree
*gnu_stack_ptr
, tree gnu_purpose
, tree gnu_value
)
5191 tree gnu_node
= gnu_stack_free_list
;
5195 gnu_stack_free_list
= TREE_CHAIN (gnu_node
);
5196 TREE_CHAIN (gnu_node
) = *gnu_stack_ptr
;
5197 TREE_PURPOSE (gnu_node
) = gnu_purpose
;
5198 TREE_VALUE (gnu_node
) = gnu_value
;
5201 gnu_node
= tree_cons (gnu_purpose
, gnu_value
, *gnu_stack_ptr
);
5203 *gnu_stack_ptr
= gnu_node
;
5207 pop_stack (tree
*gnu_stack_ptr
)
5209 tree gnu_node
= *gnu_stack_ptr
;
5211 *gnu_stack_ptr
= TREE_CHAIN (gnu_node
);
5212 TREE_CHAIN (gnu_node
) = gnu_stack_free_list
;
5213 gnu_stack_free_list
= gnu_node
;
5216 /* Generate GIMPLE in place for the expression at *EXPR_P. */
5219 gnat_gimplify_expr (tree
*expr_p
, tree
*pre_p
, tree
*post_p ATTRIBUTE_UNUSED
)
5221 tree expr
= *expr_p
;
5224 if (IS_ADA_STMT (expr
))
5225 return gnat_gimplify_stmt (expr_p
);
5227 switch (TREE_CODE (expr
))
5230 /* If this is for a scalar, just make a VAR_DECL for it. If for
5231 an aggregate, get a null pointer of the appropriate type and
5233 if (AGGREGATE_TYPE_P (TREE_TYPE (expr
)))
5234 *expr_p
= build1 (INDIRECT_REF
, TREE_TYPE (expr
),
5235 convert (build_pointer_type (TREE_TYPE (expr
)),
5236 integer_zero_node
));
5239 *expr_p
= create_tmp_var (TREE_TYPE (expr
), NULL
);
5240 TREE_NO_WARNING (*expr_p
) = 1;
5243 gimplify_and_add (TREE_OPERAND (expr
, 0), pre_p
);
5246 case UNCONSTRAINED_ARRAY_REF
:
5247 /* We should only do this if we are just elaborating for side-effects,
5248 but we can't know that yet. */
5249 *expr_p
= TREE_OPERAND (*expr_p
, 0);
5253 op
= TREE_OPERAND (expr
, 0);
5255 /* If we're taking the address of a constant CONSTRUCTOR, force it to
5256 be put into static memory. We know it's going to be readonly given
5257 the semantics we have and it's required to be static memory in
5258 the case when the reference is in an elaboration procedure. */
5259 if (TREE_CODE (op
) == CONSTRUCTOR
&& TREE_CONSTANT (op
))
5261 tree new_var
= create_tmp_var (TREE_TYPE (op
), "C");
5263 TREE_READONLY (new_var
) = 1;
5264 TREE_STATIC (new_var
) = 1;
5265 TREE_ADDRESSABLE (new_var
) = 1;
5266 DECL_INITIAL (new_var
) = op
;
5268 TREE_OPERAND (expr
, 0) = new_var
;
5269 recompute_tree_invariant_for_addr_expr (expr
);
5273 /* If we are taking the address of a SAVE_EXPR, we are typically
5274 processing a misaligned argument to be passed by reference in a
5275 procedure call. We just mark the operand as addressable + not
5276 readonly here and let the common gimplifier code perform the
5277 temporary creation, initialization, and "instantiation" in place of
5278 the SAVE_EXPR in further operands, in particular in the copy back
5279 code inserted after the call. */
5280 else if (TREE_CODE (op
) == SAVE_EXPR
)
5282 TREE_ADDRESSABLE (op
) = 1;
5283 TREE_READONLY (op
) = 0;
5286 /* We let the gimplifier process &COND_EXPR and expect it to yield the
5287 address of the selected operand when it is addressable. Besides, we
5288 also expect addressable_p to only let COND_EXPRs where both arms are
5289 addressable reach here. */
5290 else if (TREE_CODE (op
) == COND_EXPR
)
5293 /* Otherwise, if we are taking the address of something that is neither
5294 reference, declaration, or constant, make a variable for the operand
5295 here and then take its address. If we don't do it this way, we may
5296 confuse the gimplifier because it needs to know the variable is
5297 addressable at this point. This duplicates code in
5298 internal_get_tmp_var, which is unfortunate. */
5299 else if (TREE_CODE_CLASS (TREE_CODE (op
)) != tcc_reference
5300 && TREE_CODE_CLASS (TREE_CODE (op
)) != tcc_declaration
5301 && TREE_CODE_CLASS (TREE_CODE (op
)) != tcc_constant
)
5303 tree new_var
= create_tmp_var (TREE_TYPE (op
), "A");
5304 tree mod
= build2 (GIMPLE_MODIFY_STMT
, TREE_TYPE (op
), new_var
, op
);
5306 TREE_ADDRESSABLE (new_var
) = 1;
5308 if (EXPR_HAS_LOCATION (op
))
5309 SET_EXPR_LOCUS (mod
, EXPR_LOCUS (op
));
5311 gimplify_and_add (mod
, pre_p
);
5312 TREE_OPERAND (expr
, 0) = new_var
;
5313 recompute_tree_invariant_for_addr_expr (expr
);
5317 /* ... fall through ... */
5320 return GS_UNHANDLED
;
5324 /* Generate GIMPLE in place for the statement at *STMT_P. */
5326 static enum gimplify_status
5327 gnat_gimplify_stmt (tree
*stmt_p
)
5329 tree stmt
= *stmt_p
;
5331 switch (TREE_CODE (stmt
))
5334 *stmt_p
= STMT_STMT_STMT (stmt
);
5339 tree gnu_start_label
= create_artificial_label ();
5340 tree gnu_end_label
= LOOP_STMT_LABEL (stmt
);
5343 /* Set to emit the statements of the loop. */
5344 *stmt_p
= NULL_TREE
;
5346 /* We first emit the start label and then a conditional jump to
5347 the end label if there's a top condition, then the body of the
5348 loop, then a conditional branch to the end label, then the update,
5349 if any, and finally a jump to the start label and the definition
5350 of the end label. */
5351 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
5355 if (LOOP_STMT_TOP_COND (stmt
))
5356 append_to_statement_list (build3 (COND_EXPR
, void_type_node
,
5357 LOOP_STMT_TOP_COND (stmt
),
5364 append_to_statement_list (LOOP_STMT_BODY (stmt
), stmt_p
);
5366 if (LOOP_STMT_BOT_COND (stmt
))
5367 append_to_statement_list (build3 (COND_EXPR
, void_type_node
,
5368 LOOP_STMT_BOT_COND (stmt
),
5375 if (LOOP_STMT_UPDATE (stmt
))
5376 append_to_statement_list (LOOP_STMT_UPDATE (stmt
), stmt_p
);
5378 t
= build1 (GOTO_EXPR
, void_type_node
, gnu_start_label
);
5379 set_expr_location (t
, DECL_SOURCE_LOCATION (gnu_end_label
));
5380 append_to_statement_list (t
, stmt_p
);
5382 append_to_statement_list (build1 (LABEL_EXPR
, void_type_node
,
5389 /* Build a statement to jump to the corresponding end label, then
5390 see if it needs to be conditional. */
5391 *stmt_p
= build1 (GOTO_EXPR
, void_type_node
, EXIT_STMT_LABEL (stmt
));
5392 if (EXIT_STMT_COND (stmt
))
5393 *stmt_p
= build3 (COND_EXPR
, void_type_node
,
5394 EXIT_STMT_COND (stmt
), *stmt_p
, alloc_stmt_list ());
5402 /* Force references to each of the entities in packages withed by GNAT_NODE.
5403 Operate recursively but check that we aren't elaborating something more
5406 This routine is exclusively called in type_annotate mode, to compute DDA
5407 information for types in withed units, for ASIS use. */
5410 elaborate_all_entities (Node_Id gnat_node
)
5412 Entity_Id gnat_with_clause
, gnat_entity
;
5414 /* Process each unit only once. As we trace the context of all relevant
5415 units transitively, including generic bodies, we may encounter the
5416 same generic unit repeatedly. */
5417 if (!present_gnu_tree (gnat_node
))
5418 save_gnu_tree (gnat_node
, integer_zero_node
, true);
5420 /* Save entities in all context units. A body may have an implicit_with
5421 on its own spec, if the context includes a child unit, so don't save
5423 for (gnat_with_clause
= First (Context_Items (gnat_node
));
5424 Present (gnat_with_clause
);
5425 gnat_with_clause
= Next (gnat_with_clause
))
5426 if (Nkind (gnat_with_clause
) == N_With_Clause
5427 && !present_gnu_tree (Library_Unit (gnat_with_clause
))
5428 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
5430 elaborate_all_entities (Library_Unit (gnat_with_clause
));
5432 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
5434 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
5435 Present (gnat_entity
);
5436 gnat_entity
= Next_Entity (gnat_entity
))
5437 if (Is_Public (gnat_entity
)
5438 && Convention (gnat_entity
) != Convention_Intrinsic
5439 && Ekind (gnat_entity
) != E_Package
5440 && Ekind (gnat_entity
) != E_Package_Body
5441 && Ekind (gnat_entity
) != E_Operator
5442 && !(IN (Ekind (gnat_entity
), Type_Kind
)
5443 && !Is_Frozen (gnat_entity
))
5444 && !((Ekind (gnat_entity
) == E_Procedure
5445 || Ekind (gnat_entity
) == E_Function
)
5446 && Is_Intrinsic_Subprogram (gnat_entity
))
5447 && !IN (Ekind (gnat_entity
), Named_Kind
)
5448 && !IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
5449 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5451 else if (Ekind (Entity (Name (gnat_with_clause
))) == E_Generic_Package
)
5454 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause
)));
5456 /* Retrieve compilation unit node of generic body. */
5457 while (Present (gnat_body
)
5458 && Nkind (gnat_body
) != N_Compilation_Unit
)
5459 gnat_body
= Parent (gnat_body
);
5461 /* If body is available, elaborate its context. */
5462 if (Present (gnat_body
))
5463 elaborate_all_entities (gnat_body
);
5467 if (Nkind (Unit (gnat_node
)) == N_Package_Body
)
5468 elaborate_all_entities (Library_Unit (gnat_node
));
5471 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
5474 process_freeze_entity (Node_Id gnat_node
)
5476 Entity_Id gnat_entity
= Entity (gnat_node
);
5480 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
5481 && present_gnu_tree (Declaration_Node (gnat_entity
)))
5482 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
5484 /* If this is a package, need to generate code for the package. */
5485 if (Ekind (gnat_entity
) == E_Package
)
5488 (Parent (Corresponding_Body
5489 (Parent (Declaration_Node (gnat_entity
)))));
5493 /* Check for old definition after the above call. This Freeze_Node
5494 might be for one its Itypes. */
5496 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
5498 /* If this entity has an Address representation clause, GNU_OLD is the
5499 address, so discard it here. */
5500 if (Present (Address_Clause (gnat_entity
)))
5503 /* Don't do anything for class-wide types they are always
5504 transformed into their root type. */
5505 if (Ekind (gnat_entity
) == E_Class_Wide_Type
5506 || (Ekind (gnat_entity
) == E_Class_Wide_Subtype
5507 && Present (Equivalent_Type (gnat_entity
))))
5510 /* Don't do anything for subprograms that may have been elaborated before
5511 their freeze nodes. This can happen, for example because of an inner call
5512 in an instance body, or a previous compilation of a spec for inlining
5515 && ((TREE_CODE (gnu_old
) == FUNCTION_DECL
5516 && (Ekind (gnat_entity
) == E_Function
5517 || Ekind (gnat_entity
) == E_Procedure
))
5519 && TREE_CODE (TREE_TYPE (gnu_old
)) == FUNCTION_TYPE
5520 && Ekind (gnat_entity
) == E_Subprogram_Type
)))
5523 /* If we have a non-dummy type old tree, we have nothing to do, except
5524 aborting if this is the public view of a private type whose full view was
5525 not delayed, as this node was never delayed as it should have been. We
5526 let this happen for concurrent types and their Corresponding_Record_Type,
5527 however, because each might legitimately be elaborated before it's own
5528 freeze node, e.g. while processing the other. */
5530 && !(TREE_CODE (gnu_old
) == TYPE_DECL
5531 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
5533 gcc_assert ((IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
5534 && Present (Full_View (gnat_entity
))
5535 && No (Freeze_Node (Full_View (gnat_entity
))))
5536 || Is_Concurrent_Type (gnat_entity
)
5537 || (IN (Ekind (gnat_entity
), Record_Kind
)
5538 && Is_Concurrent_Record_Type (gnat_entity
)));
5542 /* Reset the saved tree, if any, and elaborate the object or type for real.
5543 If there is a full declaration, elaborate it and copy the type to
5544 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
5545 a class wide type or subtype. */
5548 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
5549 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
5550 && Present (Full_View (gnat_entity
))
5551 && present_gnu_tree (Full_View (gnat_entity
)))
5552 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, false);
5553 if (Present (Class_Wide_Type (gnat_entity
))
5554 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
5555 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, false);
5558 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
5559 && Present (Full_View (gnat_entity
)))
5561 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
5563 /* Propagate back-annotations from full view to partial view. */
5564 if (Unknown_Alignment (gnat_entity
))
5565 Set_Alignment (gnat_entity
, Alignment (Full_View (gnat_entity
)));
5567 if (Unknown_Esize (gnat_entity
))
5568 Set_Esize (gnat_entity
, Esize (Full_View (gnat_entity
)));
5570 if (Unknown_RM_Size (gnat_entity
))
5571 Set_RM_Size (gnat_entity
, RM_Size (Full_View (gnat_entity
)));
5573 /* The above call may have defined this entity (the simplest example
5574 of this is when we have a private enumeral type since the bounds
5575 will have the public view. */
5576 if (!present_gnu_tree (gnat_entity
))
5577 save_gnu_tree (gnat_entity
, gnu_new
, false);
5578 if (Present (Class_Wide_Type (gnat_entity
))
5579 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
5580 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, false);
5583 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
5585 /* If we've made any pointers to the old version of this type, we
5586 have to update them. */
5588 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
5589 TREE_TYPE (gnu_new
));
5592 /* Process the list of inlined subprograms of GNAT_NODE, which is an
5593 N_Compilation_Unit. */
5596 process_inlined_subprograms (Node_Id gnat_node
)
5598 Entity_Id gnat_entity
;
5601 /* If we can inline, generate RTL for all the inlined subprograms.
5602 Define the entity first so we set DECL_EXTERNAL. */
5603 if (optimize
> 0 && !flag_really_no_inline
)
5604 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
5605 Present (gnat_entity
);
5606 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
5608 gnat_body
= Parent (Declaration_Node (gnat_entity
));
5610 if (Nkind (gnat_body
) != N_Subprogram_Body
)
5612 /* ??? This really should always be Present. */
5613 if (No (Corresponding_Body (gnat_body
)))
5617 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
5620 if (Present (gnat_body
))
5622 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
5623 add_stmt (gnat_to_gnu (gnat_body
));
5628 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
5629 We make two passes, one to elaborate anything other than bodies (but
5630 we declare a function if there was no spec). The second pass
5631 elaborates the bodies.
5633 GNAT_END_LIST gives the element in the list past the end. Normally,
5634 this is Empty, but can be First_Real_Statement for a
5635 Handled_Sequence_Of_Statements.
5637 We make a complete pass through both lists if PASS1P is true, then make
5638 the second pass over both lists if PASS2P is true. The lists usually
5639 correspond to the public and private parts of a package. */
5642 process_decls (List_Id gnat_decls
, List_Id gnat_decls2
,
5643 Node_Id gnat_end_list
, bool pass1p
, bool pass2p
)
5645 List_Id gnat_decl_array
[2];
5649 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
5652 for (i
= 0; i
<= 1; i
++)
5653 if (Present (gnat_decl_array
[i
]))
5654 for (gnat_decl
= First (gnat_decl_array
[i
]);
5655 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
5657 /* For package specs, we recurse inside the declarations,
5658 thus taking the two pass approach inside the boundary. */
5659 if (Nkind (gnat_decl
) == N_Package_Declaration
5660 && (Nkind (Specification (gnat_decl
)
5661 == N_Package_Specification
)))
5662 process_decls (Visible_Declarations (Specification (gnat_decl
)),
5663 Private_Declarations (Specification (gnat_decl
)),
5664 Empty
, true, false);
5666 /* Similarly for any declarations in the actions of a
5668 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
5670 process_freeze_entity (gnat_decl
);
5671 process_decls (Actions (gnat_decl
), Empty
, Empty
, true, false);
5674 /* Package bodies with freeze nodes get their elaboration deferred
5675 until the freeze node, but the code must be placed in the right
5676 place, so record the code position now. */
5677 else if (Nkind (gnat_decl
) == N_Package_Body
5678 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
5679 record_code_position (gnat_decl
);
5681 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
5682 && Present (Library_Unit (gnat_decl
))
5683 && Present (Freeze_Node
5686 (Library_Unit (gnat_decl
)))))))
5687 record_code_position
5688 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
5690 /* We defer most subprogram bodies to the second pass. */
5691 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
5693 if (Acts_As_Spec (gnat_decl
))
5695 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
5697 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
5698 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
5699 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
5702 /* For bodies and stubs that act as their own specs, the entity
5703 itself must be elaborated in the first pass, because it may
5704 be used in other declarations. */
5705 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
5707 Node_Id gnat_subprog_id
=
5708 Defining_Entity (Specification (gnat_decl
));
5710 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
5711 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
5712 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
5713 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
5716 /* Concurrent stubs stand for the corresponding subprogram bodies,
5717 which are deferred like other bodies. */
5718 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
5719 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
5722 add_stmt (gnat_to_gnu (gnat_decl
));
5725 /* Here we elaborate everything we deferred above except for package bodies,
5726 which are elaborated at their freeze nodes. Note that we must also
5727 go inside things (package specs and freeze nodes) the first pass did. */
5729 for (i
= 0; i
<= 1; i
++)
5730 if (Present (gnat_decl_array
[i
]))
5731 for (gnat_decl
= First (gnat_decl_array
[i
]);
5732 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
5734 if (Nkind (gnat_decl
) == N_Subprogram_Body
5735 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
5736 || Nkind (gnat_decl
) == N_Task_Body_Stub
5737 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
5738 add_stmt (gnat_to_gnu (gnat_decl
));
5740 else if (Nkind (gnat_decl
) == N_Package_Declaration
5741 && (Nkind (Specification (gnat_decl
)
5742 == N_Package_Specification
)))
5743 process_decls (Visible_Declarations (Specification (gnat_decl
)),
5744 Private_Declarations (Specification (gnat_decl
)),
5745 Empty
, false, true);
5747 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
5748 process_decls (Actions (gnat_decl
), Empty
, Empty
, false, true);
5752 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
5753 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
5754 which we have to check. */
5757 emit_range_check (tree gnu_expr
, Entity_Id gnat_range_type
)
5759 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
5760 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
5761 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
5762 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
5764 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed.
5765 This can for example happen when translating 'Val or 'Value. */
5766 if (gnu_compare_type
== gnu_range_type
)
5769 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
5770 we can't do anything since we might be truncating the bounds. No
5771 check is needed in this case. */
5772 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
5773 && (TYPE_PRECISION (gnu_compare_type
)
5774 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
5777 /* Checked expressions must be evaluated only once. */
5778 gnu_expr
= protect_multiple_eval (gnu_expr
);
5780 /* There's no good type to use here, so we might as well use
5781 integer_type_node. Note that the form of the check is
5782 (not (expr >= lo)) or (not (expr <= hi))
5783 the reason for this slightly convoluted form is that NaN's
5784 are not considered to be in range in the float case. */
5786 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
5788 (build_binary_op (GE_EXPR
, integer_type_node
,
5789 convert (gnu_compare_type
, gnu_expr
),
5790 convert (gnu_compare_type
, gnu_low
))),
5792 (build_binary_op (LE_EXPR
, integer_type_node
,
5793 convert (gnu_compare_type
, gnu_expr
),
5794 convert (gnu_compare_type
,
5796 gnu_expr
, CE_Range_Check_Failed
);
5799 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
5800 which we are about to index, GNU_EXPR is the index expression to be
5801 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
5802 against which GNU_EXPR has to be checked. Note that for index
5803 checking we cannot use the emit_range_check function (although very
5804 similar code needs to be generated in both cases) since for index
5805 checking the array type against which we are checking the indeces
5806 may be unconstrained and consequently we need to retrieve the
5807 actual index bounds from the array object itself
5808 (GNU_ARRAY_OBJECT). The place where we need to do that is in
5809 subprograms having unconstrained array formal parameters */
5812 emit_index_check (tree gnu_array_object
,
5817 tree gnu_expr_check
;
5819 /* Checked expressions must be evaluated only once. */
5820 gnu_expr
= protect_multiple_eval (gnu_expr
);
5822 /* Must do this computation in the base type in case the expression's
5823 type is an unsigned subtypes. */
5824 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
5826 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
5827 the object we are handling. */
5828 gnu_low
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low
, gnu_array_object
);
5829 gnu_high
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high
, gnu_array_object
);
5831 /* There's no good type to use here, so we might as well use
5832 integer_type_node. */
5834 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
5835 build_binary_op (LT_EXPR
, integer_type_node
,
5837 convert (TREE_TYPE (gnu_expr_check
),
5839 build_binary_op (GT_EXPR
, integer_type_node
,
5841 convert (TREE_TYPE (gnu_expr_check
),
5843 gnu_expr
, CE_Index_Check_Failed
);
5846 /* GNU_COND contains the condition corresponding to an access, discriminant or
5847 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
5848 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
5849 REASON is the code that says why the exception was raised. */
5852 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
)
5857 gnu_call
= build_call_raise (reason
, Empty
, N_Raise_Constraint_Error
);
5859 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
5860 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
5861 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
5863 gnu_result
= fold_build3 (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
5864 build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
),
5865 gnu_call
, gnu_expr
),
5868 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
5869 protect it. Otherwise, show GNU_RESULT has no side effects: we
5870 don't need to evaluate it just for the check. */
5871 if (TREE_SIDE_EFFECTS (gnu_expr
))
5873 = build2 (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
, gnu_result
);
5875 TREE_SIDE_EFFECTS (gnu_result
) = 0;
5877 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
5878 we will repeatedly do the test. It would be nice if GCC was able
5879 to optimize this and only do it once. */
5880 return save_expr (gnu_result
);
5883 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
5884 overflow checks if OVERFLOW_P is nonzero and range checks if
5885 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
5886 If TRUNCATE_P is nonzero, do a float to integer conversion with
5887 truncation; otherwise round. */
5890 convert_with_check (Entity_Id gnat_type
, tree gnu_expr
, bool overflowp
,
5891 bool rangep
, bool truncatep
)
5893 tree gnu_type
= get_unpadded_type (gnat_type
);
5894 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
5895 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
5896 tree gnu_base_type
= get_base_type (gnu_type
);
5897 tree gnu_result
= gnu_expr
;
5899 /* If we are not doing any checks, the output is an integral type, and
5900 the input is not a floating type, just do the conversion. This
5901 shortcut is required to avoid problems with packed array types
5902 and simplifies code in all cases anyway. */
5903 if (!rangep
&& !overflowp
&& INTEGRAL_TYPE_P (gnu_base_type
)
5904 && !FLOAT_TYPE_P (gnu_in_type
))
5905 return convert (gnu_type
, gnu_expr
);
5907 /* First convert the expression to its base type. This
5908 will never generate code, but makes the tests below much simpler.
5909 But don't do this if converting from an integer type to an unconstrained
5910 array type since then we need to get the bounds from the original
5912 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
5913 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
5915 /* If overflow checks are requested, we need to be sure the result will
5916 fit in the output base type. But don't do this if the input
5917 is integer and the output floating-point. */
5919 && !(FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
5921 /* Ensure GNU_EXPR only gets evaluated once. */
5922 tree gnu_input
= protect_multiple_eval (gnu_result
);
5923 tree gnu_cond
= integer_zero_node
;
5924 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
5925 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
5926 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
5927 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
5929 /* Convert the lower bounds to signed types, so we're sure we're
5930 comparing them properly. Likewise, convert the upper bounds
5931 to unsigned types. */
5932 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TYPE_UNSIGNED (gnu_in_basetype
))
5933 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
5935 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
5936 && !TYPE_UNSIGNED (gnu_in_basetype
))
5937 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
5939 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
5940 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
5942 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
5943 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
5945 /* Check each bound separately and only if the result bound
5946 is tighter than the bound on the input type. Note that all the
5947 types are base types, so the bounds must be constant. Also,
5948 the comparison is done in the base type of the input, which
5949 always has the proper signedness. First check for input
5950 integer (which means output integer), output float (which means
5951 both float), or mixed, in which case we always compare.
5952 Note that we have to do the comparison which would *fail* in the
5953 case of an error since if it's an FP comparison and one of the
5954 values is a NaN or Inf, the comparison will fail. */
5955 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
5956 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
5957 : (FLOAT_TYPE_P (gnu_base_type
)
5958 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
5959 TREE_REAL_CST (gnu_out_lb
))
5963 (build_binary_op (GE_EXPR
, integer_type_node
,
5964 gnu_input
, convert (gnu_in_basetype
,
5967 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
5968 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
5969 : (FLOAT_TYPE_P (gnu_base_type
)
5970 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
5971 TREE_REAL_CST (gnu_in_lb
))
5974 = build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
, gnu_cond
,
5976 (build_binary_op (LE_EXPR
, integer_type_node
,
5978 convert (gnu_in_basetype
,
5981 if (!integer_zerop (gnu_cond
))
5982 gnu_result
= emit_check (gnu_cond
, gnu_input
,
5983 CE_Overflow_Check_Failed
);
5986 /* Now convert to the result base type. If this is a non-truncating
5987 float-to-integer conversion, round. */
5988 if (INTEGRAL_TYPE_P (gnu_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
5991 REAL_VALUE_TYPE half_minus_pred_half
, pred_half
;
5992 tree gnu_conv
, gnu_zero
, gnu_comp
, gnu_saved_result
, calc_type
;
5993 tree gnu_pred_half
, gnu_add_pred_half
, gnu_subtract_pred_half
;
5994 const struct real_format
*fmt
;
5996 /* The following calculations depend on proper rounding to even
5997 of each arithmetic operation. In order to prevent excess
5998 precision from spoiling this property, use the widest hardware
5999 floating-point type.
6001 FIXME: For maximum efficiency, this should only be done for machines
6002 and types where intermediates may have extra precision. */
6004 calc_type
= longest_float_type_node
;
6005 /* FIXME: Should not have padding in the first place */
6006 if (TREE_CODE (calc_type
) == RECORD_TYPE
6007 && TYPE_IS_PADDING_P (calc_type
))
6008 calc_type
= TREE_TYPE (TYPE_FIELDS (calc_type
));
6010 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
6011 fmt
= REAL_MODE_FORMAT (TYPE_MODE (calc_type
));
6012 real_2expN (&half_minus_pred_half
, -(fmt
->p
) - 1, TYPE_MODE (calc_type
));
6013 REAL_ARITHMETIC (pred_half
, MINUS_EXPR
, dconsthalf
,
6014 half_minus_pred_half
);
6015 gnu_pred_half
= build_real (calc_type
, pred_half
);
6017 /* If the input is strictly negative, subtract this value
6018 and otherwise add it from the input. For 0.5, the result
6019 is exactly between 1.0 and the machine number preceding 1.0
6020 (for calc_type). Since the last bit of 1.0 is even, this 0.5
6021 will round to 1.0, while all other number with an absolute
6022 value less than 0.5 round to 0.0. For larger numbers exactly
6023 halfway between integers, rounding will always be correct as
6024 the true mathematical result will be closer to the higher
6025 integer compared to the lower one. So, this constant works
6026 for all floating-point numbers.
6028 The reason to use the same constant with subtract/add instead
6029 of a positive and negative constant is to allow the comparison
6030 to be scheduled in parallel with retrieval of the constant and
6031 conversion of the input to the calc_type (if necessary).
6034 gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
6035 gnu_saved_result
= save_expr (gnu_result
);
6036 gnu_conv
= convert (calc_type
, gnu_saved_result
);
6037 gnu_comp
= build2 (GE_EXPR
, integer_type_node
,
6038 gnu_saved_result
, gnu_zero
);
6040 = build2 (PLUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
6041 gnu_subtract_pred_half
6042 = build2 (MINUS_EXPR
, calc_type
, gnu_conv
, gnu_pred_half
);
6043 gnu_result
= build3 (COND_EXPR
, calc_type
, gnu_comp
,
6044 gnu_add_pred_half
, gnu_subtract_pred_half
);
6047 if (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
6048 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type
)
6049 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
6050 gnu_result
= unchecked_convert (gnu_base_type
, gnu_result
, false);
6052 gnu_result
= convert (gnu_base_type
, gnu_result
);
6054 /* Finally, do the range check if requested. Note that if the
6055 result type is a modular type, the range check is actually
6056 an overflow check. */
6059 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
6060 && TYPE_MODULAR_P (gnu_base_type
) && overflowp
))
6061 gnu_result
= emit_range_check (gnu_result
, gnat_type
);
6063 return convert (gnu_type
, gnu_result
);
6066 /* Return true if RECORD_TYPE, a record type, is larger than TYPE. */
6069 larger_record_type_p (tree record_type
, tree type
)
6073 /* Padding types are not considered larger on their own. */
6074 if (TYPE_IS_PADDING_P (record_type
))
6077 rsize
= TYPE_SIZE (record_type
);
6078 size
= TYPE_SIZE (type
);
6080 if (!(TREE_CODE (rsize
) == INTEGER_CST
&& TREE_CODE (size
) == INTEGER_CST
))
6083 return tree_int_cst_lt (size
, rsize
) != 0;
6086 /* Return true if GNU_EXPR can be directly addressed. This is the case
6087 unless it is an expression involving computation or if it involves a
6088 reference to a bitfield or to an object not sufficiently aligned for
6089 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
6090 be directly addressed as an object of this type.
6092 *** Notes on addressability issues in the Ada compiler ***
6094 This predicate is necessary in order to bridge the gap between Gigi
6095 and the middle-end about addressability of GENERIC trees. A tree
6096 is said to be addressable if it can be directly addressed, i.e. if
6097 its address can be taken, is a multiple of the type's alignment on
6098 strict-alignment architectures and returns the first storage unit
6099 assigned to the object represented by the tree.
6101 In the C family of languages, everything is in practice addressable
6102 at the language level, except for bit-fields. This means that these
6103 compilers will take the address of any tree that doesn't represent
6104 a bit-field reference and expect the result to be the first storage
6105 unit assigned to the object. Even in cases where this will result
6106 in unaligned accesses at run time, nothing is supposed to be done
6107 and the program is considered as erroneous instead (see PR c/18287).
6109 The implicit assumptions made in the middle-end are in keeping with
6110 the C viewpoint described above:
6111 - the address of a bit-field reference is supposed to be never
6112 taken; the compiler (generally) will stop on such a construct,
6113 - any other tree is addressable if it is formally addressable,
6114 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
6116 In Ada, the viewpoint is the opposite one: nothing is addressable
6117 at the language level unless explicitly declared so. This means
6118 that the compiler will both make sure that the trees representing
6119 references to addressable ("aliased" in Ada parlance) objects are
6120 addressable and make no real attempts at ensuring that the trees
6121 representing references to non-addressable objects are addressable.
6123 In the first case, Ada is effectively equivalent to C and handing
6124 down the direct result of applying ADDR_EXPR to these trees to the
6125 middle-end works flawlessly. In the second case, Ada cannot afford
6126 to consider the program as erroneous if the address of trees that
6127 are not addressable is requested for technical reasons, unlike C;
6128 as a consequence, the Ada compiler must arrange for either making
6129 sure that this address is not requested in the middle-end or for
6130 compensating by inserting temporaries if it is requested in Gigi.
6132 The first goal can be achieved because the middle-end should not
6133 request the address of non-addressable trees on its own; the only
6134 exception is for the invocation of low-level block operations like
6135 memcpy, for which the addressability requirements are lower since
6136 the type's alignment can be disregarded. In practice, this means
6137 that Gigi must make sure that such operations cannot be applied to
6138 non-BLKmode bit-fields.
6140 The second goal is achieved by means of the addressable_p predicate
6141 and by inserting SAVE_EXPRs around trees deemed non-addressable.
6142 They will be turned during gimplification into proper temporaries
6143 whose address will be used in lieu of that of the original tree. */
6146 addressable_p (tree gnu_expr
, tree gnu_type
)
6148 /* The size of the real type of the object must not be smaller than
6149 that of the expected type, otherwise an indirect access in the
6150 latter type would be larger than the object. Only records need
6151 to be considered in practice. */
6153 && TREE_CODE (gnu_type
) == RECORD_TYPE
6154 && larger_record_type_p (gnu_type
, TREE_TYPE (gnu_expr
)))
6157 switch (TREE_CODE (gnu_expr
))
6163 /* All DECLs are addressable: if they are in a register, we can force
6167 case UNCONSTRAINED_ARRAY_REF
:
6178 /* We accept &COND_EXPR as soon as both operands are addressable and
6179 expect the outcome to be the address of the selected operand. */
6180 return (addressable_p (TREE_OPERAND (gnu_expr
, 1), NULL_TREE
)
6181 && addressable_p (TREE_OPERAND (gnu_expr
, 2), NULL_TREE
));
6184 return (!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
6185 && (!STRICT_ALIGNMENT
6186 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
6187 the field is sufficiently aligned, in case it is subject
6188 to a pragma Component_Alignment. But we don't need to
6189 check the alignment of the containing record, as it is
6190 guaranteed to be not smaller than that of its most
6191 aligned field that is not a bit-field. */
6192 || DECL_ALIGN (TREE_OPERAND (gnu_expr
, 1))
6193 >= TYPE_ALIGN (TREE_TYPE (gnu_expr
)))
6194 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
6196 case ARRAY_REF
: case ARRAY_RANGE_REF
:
6197 case REALPART_EXPR
: case IMAGPART_EXPR
:
6199 return addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
);
6202 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
6203 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
6205 case VIEW_CONVERT_EXPR
:
6207 /* This is addressable if we can avoid a copy. */
6208 tree type
= TREE_TYPE (gnu_expr
);
6209 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
6210 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
6211 && (!STRICT_ALIGNMENT
6212 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
6213 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
6214 || ((TYPE_MODE (type
) == BLKmode
6215 || TYPE_MODE (inner_type
) == BLKmode
)
6216 && (!STRICT_ALIGNMENT
6217 || TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
6218 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
6219 || TYPE_ALIGN_OK (type
)
6220 || TYPE_ALIGN_OK (inner_type
))))
6221 && addressable_p (TREE_OPERAND (gnu_expr
, 0), NULL_TREE
));
6229 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
6230 a separate Freeze node exists, delay the bulk of the processing. Otherwise
6231 make a GCC type for GNAT_ENTITY and set up the correspondence. */
6234 process_type (Entity_Id gnat_entity
)
6237 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
6240 /* If we are to delay elaboration of this type, just do any
6241 elaborations needed for expressions within the declaration and
6242 make a dummy type entry for this node and its Full_View (if
6243 any) in case something points to it. Don't do this if it
6244 has already been done (the only way that can happen is if
6245 the private completion is also delayed). */
6246 if (Present (Freeze_Node (gnat_entity
))
6247 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
6248 && Present (Full_View (gnat_entity
))
6249 && Freeze_Node (Full_View (gnat_entity
))
6250 && !present_gnu_tree (Full_View (gnat_entity
))))
6252 elaborate_entity (gnat_entity
);
6256 tree gnu_decl
= create_type_decl (get_entity_name (gnat_entity
),
6257 make_dummy_type (gnat_entity
),
6258 NULL
, false, false, gnat_entity
);
6260 save_gnu_tree (gnat_entity
, gnu_decl
, false);
6261 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
6262 && Present (Full_View (gnat_entity
)))
6263 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, false);
6269 /* If we saved away a dummy type for this node it means that this
6270 made the type that corresponds to the full type of an incomplete
6271 type. Clear that type for now and then update the type in the
6275 gcc_assert (TREE_CODE (gnu_old
) == TYPE_DECL
6276 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)));
6278 save_gnu_tree (gnat_entity
, NULL_TREE
, false);
6281 /* Now fully elaborate the type. */
6282 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
6283 gcc_assert (TREE_CODE (gnu_new
) == TYPE_DECL
);
6285 /* If we have an old type and we've made pointers to this type,
6286 update those pointers. */
6288 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
6289 TREE_TYPE (gnu_new
));
6291 /* If this is a record type corresponding to a task or protected type
6292 that is a completion of an incomplete type, perform a similar update
6294 /* ??? Including protected types here is a guess. */
6296 if (IN (Ekind (gnat_entity
), Record_Kind
)
6297 && Is_Concurrent_Record_Type (gnat_entity
)
6298 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
6301 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
6303 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
6305 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
6308 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
6309 TREE_TYPE (gnu_new
));
6313 /* GNAT_ENTITY is the type of the resulting constructors,
6314 GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate,
6315 and GNU_TYPE is the GCC type of the corresponding record.
6317 Return a CONSTRUCTOR to build the record. */
6320 assoc_to_constructor (Entity_Id gnat_entity
, Node_Id gnat_assoc
, tree gnu_type
)
6322 tree gnu_list
, gnu_result
;
6324 /* We test for GNU_FIELD being empty in the case where a variant
6325 was the last thing since we don't take things off GNAT_ASSOC in
6326 that case. We check GNAT_ASSOC in case we have a variant, but it
6329 for (gnu_list
= NULL_TREE
; Present (gnat_assoc
);
6330 gnat_assoc
= Next (gnat_assoc
))
6332 Node_Id gnat_field
= First (Choices (gnat_assoc
));
6333 tree gnu_field
= gnat_to_gnu_field_decl (Entity (gnat_field
));
6334 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
6336 /* The expander is supposed to put a single component selector name
6337 in every record component association */
6338 gcc_assert (No (Next (gnat_field
)));
6340 /* Ignore fields that have Corresponding_Discriminants since we'll
6341 be setting that field in the parent. */
6342 if (Present (Corresponding_Discriminant (Entity (gnat_field
)))
6343 && Is_Tagged_Type (Scope (Entity (gnat_field
))))
6346 /* Also ignore discriminants of Unchecked_Unions. */
6347 else if (Is_Unchecked_Union (gnat_entity
)
6348 && Ekind (Entity (gnat_field
)) == E_Discriminant
)
6351 /* Before assigning a value in an aggregate make sure range checks
6352 are done if required. Then convert to the type of the field. */
6353 if (Do_Range_Check (Expression (gnat_assoc
)))
6354 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
));
6356 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
6358 /* Add the field and expression to the list. */
6359 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
6362 gnu_result
= extract_values (gnu_list
, gnu_type
);
6364 #ifdef ENABLE_CHECKING
6368 /* Verify every entry in GNU_LIST was used. */
6369 for (gnu_field
= gnu_list
; gnu_field
; gnu_field
= TREE_CHAIN (gnu_field
))
6370 gcc_assert (TREE_ADDRESSABLE (gnu_field
));
6377 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
6378 is the first element of an array aggregate. It may itself be an
6379 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
6380 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
6381 of the array component. It is needed for range checking. */
6384 pos_to_constructor (Node_Id gnat_expr
, tree gnu_array_type
,
6385 Entity_Id gnat_component_type
)
6387 tree gnu_expr_list
= NULL_TREE
;
6388 tree gnu_index
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type
));
6391 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
6393 /* If the expression is itself an array aggregate then first build the
6394 innermost constructor if it is part of our array (multi-dimensional
6397 if (Nkind (gnat_expr
) == N_Aggregate
6398 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
6399 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
6400 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
6401 TREE_TYPE (gnu_array_type
),
6402 gnat_component_type
);
6405 gnu_expr
= gnat_to_gnu (gnat_expr
);
6407 /* before assigning the element to the array make sure it is
6409 if (Do_Range_Check (gnat_expr
))
6410 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
);
6414 = tree_cons (gnu_index
, convert (TREE_TYPE (gnu_array_type
), gnu_expr
),
6417 gnu_index
= int_const_binop (PLUS_EXPR
, gnu_index
, integer_one_node
, 0);
6420 return gnat_build_constructor (gnu_array_type
, nreverse (gnu_expr_list
));
6423 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
6424 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
6425 of the associations that are from RECORD_TYPE. If we see an internal
6426 record, make a recursive call to fill it in as well. */
6429 extract_values (tree values
, tree record_type
)
6431 tree result
= NULL_TREE
;
6434 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
6438 /* _Parent is an internal field, but may have values in the aggregate,
6439 so check for values first. */
6440 if ((tem
= purpose_member (field
, values
)))
6442 value
= TREE_VALUE (tem
);
6443 TREE_ADDRESSABLE (tem
) = 1;
6446 else if (DECL_INTERNAL_P (field
))
6448 value
= extract_values (values
, TREE_TYPE (field
));
6449 if (TREE_CODE (value
) == CONSTRUCTOR
6450 && VEC_empty (constructor_elt
, CONSTRUCTOR_ELTS (value
)))
6454 /* If we have a record subtype, the names will match, but not the
6455 actual FIELD_DECLs. */
6456 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
6457 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
6459 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
6460 TREE_ADDRESSABLE (tem
) = 1;
6466 result
= tree_cons (field
, value
, result
);
6469 return gnat_build_constructor (record_type
, nreverse (result
));
6472 /* EXP is to be treated as an array or record. Handle the cases when it is
6473 an access object and perform the required dereferences. */
6476 maybe_implicit_deref (tree exp
)
6478 /* If the type is a pointer, dereference it. */
6480 if (POINTER_TYPE_P (TREE_TYPE (exp
)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp
)))
6481 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
6483 /* If we got a padded type, remove it too. */
6484 if (TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
6485 && TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
6486 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
6491 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
6494 protect_multiple_eval (tree exp
)
6496 tree type
= TREE_TYPE (exp
);
6498 /* If this has no side effects, we don't need to do anything. */
6499 if (!TREE_SIDE_EFFECTS (exp
))
6502 /* If it is a conversion, protect what's inside the conversion.
6503 Similarly, if we're indirectly referencing something, we only
6504 actually need to protect the address since the data itself can't
6505 change in these situations. */
6506 else if (TREE_CODE (exp
) == NON_LVALUE_EXPR
6507 || TREE_CODE (exp
) == NOP_EXPR
|| TREE_CODE (exp
) == CONVERT_EXPR
6508 || TREE_CODE (exp
) == VIEW_CONVERT_EXPR
6509 || TREE_CODE (exp
) == INDIRECT_REF
6510 || TREE_CODE (exp
) == UNCONSTRAINED_ARRAY_REF
)
6511 return build1 (TREE_CODE (exp
), type
,
6512 protect_multiple_eval (TREE_OPERAND (exp
, 0)));
6514 /* If EXP is a fat pointer or something that can be placed into a register,
6515 just make a SAVE_EXPR. */
6516 if (TYPE_FAT_POINTER_P (type
) || TYPE_MODE (type
) != BLKmode
)
6517 return save_expr (exp
);
6519 /* Otherwise, dereference, protect the address, and re-reference. */
6522 build_unary_op (INDIRECT_REF
, type
,
6523 save_expr (build_unary_op (ADDR_EXPR
,
6524 build_reference_type (type
),
6528 /* This is equivalent to stabilize_reference in tree.c, but we know how to
6529 handle our own nodes and we take extra arguments. FORCE says whether to
6530 force evaluation of everything. We set SUCCESS to true unless we walk
6531 through something we don't know how to stabilize. */
6534 maybe_stabilize_reference (tree ref
, bool force
, bool *success
)
6536 tree type
= TREE_TYPE (ref
);
6537 enum tree_code code
= TREE_CODE (ref
);
6540 /* Assume we'll success unless proven otherwise. */
6549 /* No action is needed in this case. */
6556 case FIX_TRUNC_EXPR
:
6557 case VIEW_CONVERT_EXPR
:
6559 = build1 (code
, type
,
6560 maybe_stabilize_reference (TREE_OPERAND (ref
, 0), force
,
6565 case UNCONSTRAINED_ARRAY_REF
:
6566 result
= build1 (code
, type
,
6567 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
6572 result
= build3 (COMPONENT_REF
, type
,
6573 maybe_stabilize_reference (TREE_OPERAND (ref
, 0), force
,
6575 TREE_OPERAND (ref
, 1), NULL_TREE
);
6579 result
= build3 (BIT_FIELD_REF
, type
,
6580 maybe_stabilize_reference (TREE_OPERAND (ref
, 0), force
,
6582 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
6584 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 2),
6589 case ARRAY_RANGE_REF
:
6590 result
= build4 (code
, type
,
6591 maybe_stabilize_reference (TREE_OPERAND (ref
, 0), force
,
6593 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
6595 NULL_TREE
, NULL_TREE
);
6599 result
= gnat_stabilize_reference_1 (ref
, force
);
6603 /* This generates better code than the scheme in protect_multiple_eval
6604 because large objects will be returned via invisible reference in
6605 most ABIs so the temporary will directly be filled by the callee. */
6606 result
= gnat_stabilize_reference_1 (ref
, force
);
6610 /* Constructors with 1 element are used extensively to formally
6611 convert objects to special wrapping types. */
6612 if (TREE_CODE (type
) == RECORD_TYPE
6613 && VEC_length (constructor_elt
, CONSTRUCTOR_ELTS (ref
)) == 1)
6616 = VEC_index (constructor_elt
, CONSTRUCTOR_ELTS (ref
), 0)->index
;
6618 = VEC_index (constructor_elt
, CONSTRUCTOR_ELTS (ref
), 0)->value
;
6620 = build_constructor_single (type
, index
,
6621 gnat_stabilize_reference_1 (value
,
6632 ref
= error_mark_node
;
6634 /* ... Fallthru to failure ... */
6636 /* If arg isn't a kind of lvalue we recognize, make no change.
6637 Caller should recognize the error for an invalid lvalue. */
6643 TREE_READONLY (result
) = TREE_READONLY (ref
);
6645 /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
6646 expression may not be sustained across some paths, such as the way via
6647 build1 for INDIRECT_REF. We re-populate those flags here for the general
6648 case, which is consistent with the GCC version of this routine.
6650 Special care should be taken regarding TREE_SIDE_EFFECTS, because some
6651 paths introduce side effects where there was none initially (e.g. calls
6652 to save_expr), and we also want to keep track of that. */
6654 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
6655 TREE_SIDE_EFFECTS (result
) |= TREE_SIDE_EFFECTS (ref
);
6660 /* Wrapper around maybe_stabilize_reference, for common uses without
6661 lvalue restrictions and without need to examine the success
6665 gnat_stabilize_reference (tree ref
, bool force
)
6668 return maybe_stabilize_reference (ref
, force
, &dummy
);
6671 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
6672 arg to force a SAVE_EXPR for everything. */
6675 gnat_stabilize_reference_1 (tree e
, bool force
)
6677 enum tree_code code
= TREE_CODE (e
);
6678 tree type
= TREE_TYPE (e
);
6681 /* We cannot ignore const expressions because it might be a reference
6682 to a const array but whose index contains side-effects. But we can
6683 ignore things that are actual constant or that already have been
6684 handled by this function. */
6686 if (TREE_CONSTANT (e
) || code
== SAVE_EXPR
)
6689 switch (TREE_CODE_CLASS (code
))
6691 case tcc_exceptional
:
6693 case tcc_declaration
:
6694 case tcc_comparison
:
6696 case tcc_expression
:
6699 /* If this is a COMPONENT_REF of a fat pointer, save the entire
6700 fat pointer. This may be more efficient, but will also allow
6701 us to more easily find the match for the PLACEHOLDER_EXPR. */
6702 if (code
== COMPONENT_REF
6703 && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e
, 0))))
6704 result
= build3 (COMPONENT_REF
, type
,
6705 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
6707 TREE_OPERAND (e
, 1), TREE_OPERAND (e
, 2));
6708 else if (TREE_SIDE_EFFECTS (e
) || force
)
6709 return save_expr (e
);
6715 /* Constants need no processing. In fact, we should never reach
6720 /* Recursively stabilize each operand. */
6721 result
= build2 (code
, type
,
6722 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0), force
),
6723 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 1),
6728 /* Recursively stabilize each operand. */
6729 result
= build1 (code
, type
,
6730 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
6738 TREE_READONLY (result
) = TREE_READONLY (e
);
6740 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (e
);
6741 TREE_SIDE_EFFECTS (result
) |= TREE_SIDE_EFFECTS (e
);
6745 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code
6746 location and false if it doesn't. In the former case, set the Gigi global
6747 variable REF_FILENAME to the simple debug file name as given by sinput. */
6750 Sloc_to_locus (Source_Ptr Sloc
, location_t
*locus
)
6752 if (Sloc
== No_Location
)
6755 if (Sloc
<= Standard_Location
)
6757 *locus
= BUILTINS_LOCATION
;
6762 Source_File_Index file
= Get_Source_File_Index (Sloc
);
6763 Logical_Line_Number line
= Get_Logical_Line_Number (Sloc
);
6764 Column_Number column
= Get_Column_Number (Sloc
);
6765 struct line_map
*map
= &line_table
->maps
[file
- 1];
6767 /* Translate the location according to the line-map.h formula. */
6768 *locus
= map
->start_location
6769 + ((line
- map
->to_line
) << map
->column_bits
)
6770 + (column
& ((1 << map
->column_bits
) - 1));
6774 = IDENTIFIER_POINTER
6776 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc
)))));;
6781 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
6782 don't do anything if it doesn't correspond to a source location. */
6785 set_expr_location_from_node (tree node
, Node_Id gnat_node
)
6789 if (!Sloc_to_locus (Sloc (gnat_node
), &locus
))
6792 set_expr_location (node
, locus
);
6795 /* Post an error message. MSG is the error message, properly annotated.
6796 NODE is the node at which to post the error and the node to use for the
6797 "&" substitution. */
6800 post_error (const char *msg
, Node_Id node
)
6802 String_Template temp
;
6805 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
6806 fp
.Array
= msg
, fp
.Bounds
= &temp
;
6808 Error_Msg_N (fp
, node
);
6811 /* Similar, but NODE is the node at which to post the error and ENT
6812 is the node to use for the "&" substitution. */
6815 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
6817 String_Template temp
;
6820 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
6821 fp
.Array
= msg
, fp
.Bounds
= &temp
;
6823 Error_Msg_NE (fp
, node
, ent
);
6826 /* Similar, but NODE is the node at which to post the error, ENT is the node
6827 to use for the "&" substitution, and N is the number to use for the ^. */
6830 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int n
)
6832 String_Template temp
;
6835 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
6836 fp
.Array
= msg
, fp
.Bounds
= &temp
;
6837 Error_Msg_Uint_1
= UI_From_Int (n
);
6840 Error_Msg_NE (fp
, node
, ent
);
6843 /* Similar to post_error_ne_num, but T is a GCC tree representing the
6844 number to write. If the tree represents a constant that fits within
6845 a host integer, the text inside curly brackets in MSG will be output
6846 (presumably including a '^'). Otherwise that text will not be output
6847 and the text inside square brackets will be output instead. */
6850 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
6852 char *newmsg
= alloca (strlen (msg
) + 1);
6853 String_Template temp
= {1, 0};
6855 char start_yes
, end_yes
, start_no
, end_no
;
6859 fp
.Array
= newmsg
, fp
.Bounds
= &temp
;
6861 if (host_integerp (t
, 1)
6862 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
6865 (t
, (((unsigned HOST_WIDE_INT
) 1 << (HOST_BITS_PER_INT
- 1)) - 1)) < 0
6869 Error_Msg_Uint_1
= UI_From_Int (tree_low_cst (t
, 1));
6870 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
6873 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
6875 for (p
= msg
, q
= newmsg
; *p
; p
++)
6877 if (*p
== start_yes
)
6878 for (p
++; *p
!= end_yes
; p
++)
6880 else if (*p
== start_no
)
6881 for (p
++; *p
!= end_no
; p
++)
6889 temp
.High_Bound
= strlen (newmsg
);
6891 Error_Msg_NE (fp
, node
, ent
);
6894 /* Similar to post_error_ne_tree, except that NUM is a second
6895 integer to write in the message. */
6898 post_error_ne_tree_2 (const char *msg
,
6904 Error_Msg_Uint_2
= UI_From_Int (num
);
6905 post_error_ne_tree (msg
, node
, ent
, t
);
6908 /* Initialize the table that maps GNAT codes to GCC codes for simple
6909 binary and unary operations. */
6912 init_code_table (void)
6914 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
6915 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
6917 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
6918 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
6919 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
6920 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
6921 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
6922 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
6923 gnu_codes
[N_Op_Le
] = LE_EXPR
;
6924 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
6925 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
6926 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
6927 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
6928 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
6929 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
6930 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
6931 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
6932 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
6933 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
6934 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
6935 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
6936 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
6937 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
6938 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
6941 /* Return a label to branch to for the exception type in KIND or NULL_TREE
6945 get_exception_label (char kind
)
6947 if (kind
== N_Raise_Constraint_Error
)
6948 return TREE_VALUE (gnu_constraint_error_label_stack
);
6949 else if (kind
== N_Raise_Storage_Error
)
6950 return TREE_VALUE (gnu_storage_error_label_stack
);
6951 else if (kind
== N_Raise_Program_Error
)
6952 return TREE_VALUE (gnu_program_error_label_stack
);
6957 #include "gt-ada-trans.h"