Mark ChangeLog
[official-gcc.git] / gcc / ada / trans.c
blob47ea6df3f6a87ed66d186647cb7d80e38804bc62
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2005, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
21 * *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
24 * *
25 ****************************************************************************/
27 #include "config.h"
28 #include "system.h"
29 #include "coretypes.h"
30 #include "tm.h"
31 #include "tree.h"
32 #include "real.h"
33 #include "flags.h"
34 #include "toplev.h"
35 #include "rtl.h"
36 #include "expr.h"
37 #include "ggc.h"
38 #include "function.h"
39 #include "except.h"
40 #include "debug.h"
41 #include "output.h"
42 #include "tree-gimple.h"
43 #include "ada.h"
44 #include "types.h"
45 #include "atree.h"
46 #include "elists.h"
47 #include "namet.h"
48 #include "nlists.h"
49 #include "snames.h"
50 #include "stringt.h"
51 #include "uintp.h"
52 #include "urealp.h"
53 #include "fe.h"
54 #include "sinfo.h"
55 #include "einfo.h"
56 #include "ada-tree.h"
57 #include "gigi.h"
59 int max_gnat_nodes;
60 int number_names;
61 struct Node *Nodes_Ptr;
62 Node_Id *Next_Node_Ptr;
63 Node_Id *Prev_Node_Ptr;
64 struct Elist_Header *Elists_Ptr;
65 struct Elmt_Item *Elmts_Ptr;
66 struct String_Entry *Strings_Ptr;
67 Char_Code *String_Chars_Ptr;
68 struct List_Header *List_Headers_Ptr;
70 /* Current filename without path. */
71 const char *ref_filename;
73 /* If true, then gigi is being called on an analyzed but unexpanded
74 tree, and the only purpose of the call is to properly annotate
75 types with representation information. */
76 bool type_annotate_only;
78 /* A structure used to gather together information about a statement group.
79 We use this to gather related statements, for example the "then" part
80 of a IF. In the case where it represents a lexical scope, we may also
81 have a BLOCK node corresponding to it and/or cleanups. */
83 struct stmt_group GTY((chain_next ("%h.previous"))) {
84 struct stmt_group *previous; /* Previous code group. */
85 tree stmt_list; /* List of statements for this code group. */
86 tree block; /* BLOCK for this code group, if any. */
87 tree cleanups; /* Cleanups for this code group, if any. */
90 static GTY(()) struct stmt_group *current_stmt_group;
92 /* List of unused struct stmt_group nodes. */
93 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
95 /* A structure used to record information on elaboration procedures
96 we've made and need to process.
98 ??? gnat_node should be Node_Id, but gengtype gets confused. */
100 struct elab_info GTY((chain_next ("%h.next"))) {
101 struct elab_info *next; /* Pointer to next in chain. */
102 tree elab_proc; /* Elaboration procedure. */
103 int gnat_node; /* The N_Compilation_Unit. */
106 static GTY(()) struct elab_info *elab_info_list;
108 /* Free list of TREE_LIST nodes used for stacks. */
109 static GTY((deletable)) tree gnu_stack_free_list;
111 /* List of TREE_LIST nodes representing a stack of exception pointer
112 variables. TREE_VALUE is the VAR_DECL that stores the address of
113 the raised exception. Nonzero means we are in an exception
114 handler. Not used in the zero-cost case. */
115 static GTY(()) tree gnu_except_ptr_stack;
117 /* List of TREE_LIST nodes used to store the current elaboration procedure
118 decl. TREE_VALUE is the decl. */
119 static GTY(()) tree gnu_elab_proc_stack;
121 /* Variable that stores a list of labels to be used as a goto target instead of
122 a return in some functions. See processing for N_Subprogram_Body. */
123 static GTY(()) tree gnu_return_label_stack;
125 /* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes.
126 TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */
127 static GTY(()) tree gnu_loop_label_stack;
129 /* List of TREE_LIST nodes representing labels for switch statements.
130 TREE_VALUE of each entry is the label at the end of the switch. */
131 static GTY(()) tree gnu_switch_label_stack;
133 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
134 static enum tree_code gnu_codes[Number_Node_Kinds];
136 /* Current node being treated, in case abort called. */
137 Node_Id error_gnat_node;
139 static void Compilation_Unit_to_gnu (Node_Id);
140 static void record_code_position (Node_Id);
141 static void insert_code_for (Node_Id);
142 static void start_stmt_group (void);
143 static void add_cleanup (tree);
144 static tree mark_visited (tree *, int *, void *);
145 static tree mark_unvisited (tree *, int *, void *);
146 static tree end_stmt_group (void);
147 static void add_stmt_list (List_Id);
148 static tree build_stmt_group (List_Id, bool);
149 static void push_stack (tree *, tree, tree);
150 static void pop_stack (tree *);
151 static enum gimplify_status gnat_gimplify_stmt (tree *);
152 static void elaborate_all_entities (Node_Id);
153 static void process_freeze_entity (Node_Id);
154 static void process_inlined_subprograms (Node_Id);
155 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
156 static tree emit_range_check (tree, Node_Id);
157 static tree emit_index_check (tree, tree, tree, tree);
158 static tree emit_check (tree, tree, int);
159 static tree convert_with_check (Entity_Id, tree, bool, bool, bool);
160 static bool addressable_p (tree);
161 static tree assoc_to_constructor (Node_Id, tree);
162 static tree extract_values (tree, tree);
163 static tree pos_to_constructor (Node_Id, tree, Entity_Id);
164 static tree maybe_implicit_deref (tree);
165 static tree gnat_stabilize_reference_1 (tree, bool);
166 static void annotate_with_node (tree, Node_Id);
169 /* This is the main program of the back-end. It sets up all the table
170 structures and then generates code. */
172 void
173 gigi (Node_Id gnat_root, int max_gnat_node, int number_name,
174 struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr,
175 struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr,
176 struct String_Entry *strings_ptr, Char_Code *string_chars_ptr,
177 struct List_Header *list_headers_ptr, Int number_units ATTRIBUTE_UNUSED,
178 char *file_info_ptr ATTRIBUTE_UNUSED, Entity_Id standard_integer,
179 Entity_Id standard_long_long_float, Entity_Id standard_exception_type,
180 Int gigi_operating_mode)
182 tree gnu_standard_long_long_float;
183 tree gnu_standard_exception_type;
184 struct elab_info *info;
186 max_gnat_nodes = max_gnat_node;
187 number_names = number_name;
188 Nodes_Ptr = nodes_ptr;
189 Next_Node_Ptr = next_node_ptr;
190 Prev_Node_Ptr = prev_node_ptr;
191 Elists_Ptr = elists_ptr;
192 Elmts_Ptr = elmts_ptr;
193 Strings_Ptr = strings_ptr;
194 String_Chars_Ptr = string_chars_ptr;
195 List_Headers_Ptr = list_headers_ptr;
197 type_annotate_only = (gigi_operating_mode == 1);
199 init_gnat_to_gnu ();
200 gnat_compute_largest_alignment ();
201 init_dummy_type ();
203 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
204 errors. */
205 if (type_annotate_only)
207 TYPE_SIZE (void_type_node) = bitsize_zero_node;
208 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
211 /* Save the type we made for integer as the type for Standard.Integer.
212 Then make the rest of the standard types. Note that some of these
213 may be subtypes. */
214 save_gnu_tree (Base_Type (standard_integer), TYPE_NAME (integer_type_node),
215 false);
217 gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
219 gnu_standard_long_long_float
220 = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0);
221 gnu_standard_exception_type
222 = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0);
224 init_gigi_decls (gnu_standard_long_long_float, gnu_standard_exception_type);
226 /* Process any Pragma Ident for the main unit. */
227 #ifdef ASM_OUTPUT_IDENT
228 if (Present (Ident_String (Main_Unit)))
229 ASM_OUTPUT_IDENT
230 (asm_out_file,
231 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
232 #endif
234 /* If we are using the GCC exception mechanism, let GCC know. */
235 if (Exception_Mechanism == GCC_ZCX)
236 gnat_init_gcc_eh ();
238 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
239 Compilation_Unit_to_gnu (gnat_root);
241 /* Now see if we have any elaboration procedures to deal with. */
242 for (info = elab_info_list; info; info = info->next)
244 tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
245 tree gnu_stmts;
247 /* Mark everything we have as not visited. */
248 walk_tree_without_duplicates (&gnu_body, mark_unvisited, NULL);
250 /* Set the current function to be the elaboration procedure and gimplify
251 what we have. */
252 current_function_decl = info->elab_proc;
253 gimplify_body (&gnu_body, info->elab_proc, true);
255 /* We should have a BIND_EXPR, but it may or may not have any statements
256 in it. If it doesn't have any, we have nothing to do. */
257 gnu_stmts = gnu_body;
258 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
259 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
261 /* If there are no statements, there is no elaboration code. */
262 if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts))
263 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
264 else
266 /* Otherwise, compile the function. Note that we'll be gimplifying
267 it twice, but that's fine for the nodes we use. */
268 begin_subprog_body (info->elab_proc);
269 end_subprog_body (gnu_body);
274 /* Perform initializations for this module. */
276 void
277 gnat_init_stmt_group ()
279 /* Initialize ourselves. */
280 init_code_table ();
281 start_stmt_group ();
283 /* Enable GNAT stack checking method if needed */
284 if (!Stack_Check_Probes_On_Target)
285 set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode, "_gnat_stack_check"));
287 gcc_assert (Exception_Mechanism != Front_End_ZCX);
290 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
291 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
292 where we should place the result type. */
294 static tree
295 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
297 tree gnu_result_type;
298 tree gnu_result;
299 Node_Id gnat_temp, gnat_temp_type;
301 /* If the Etype of this node does not equal the Etype of the Entity,
302 something is wrong with the entity map, probably in generic
303 instantiation. However, this does not apply to types. Since we sometime
304 have strange Ekind's, just do this test for objects. Also, if the Etype of
305 the Entity is private, the Etype of the N_Identifier is allowed to be the
306 full type and also we consider a packed array type to be the same as the
307 original type. Similarly, a class-wide type is equivalent to a subtype of
308 itself. Finally, if the types are Itypes, one may be a copy of the other,
309 which is also legal. */
310 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
311 ? gnat_node : Entity (gnat_node));
312 gnat_temp_type = Etype (gnat_temp);
314 gcc_assert (Etype (gnat_node) == gnat_temp_type
315 || (Is_Packed (gnat_temp_type)
316 && Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
317 || (Is_Class_Wide_Type (Etype (gnat_node)))
318 || (IN (Ekind (gnat_temp_type), Private_Kind)
319 && Present (Full_View (gnat_temp_type))
320 && ((Etype (gnat_node) == Full_View (gnat_temp_type))
321 || (Is_Packed (Full_View (gnat_temp_type))
322 && (Etype (gnat_node)
323 == Packed_Array_Type (Full_View
324 (gnat_temp_type))))))
325 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
326 || !(Ekind (gnat_temp) == E_Variable
327 || Ekind (gnat_temp) == E_Component
328 || Ekind (gnat_temp) == E_Constant
329 || Ekind (gnat_temp) == E_Loop_Parameter
330 || IN (Ekind (gnat_temp), Formal_Kind)));
332 /* If this is a reference to a deferred constant whose partial view is an
333 unconstrained private type, the proper type is on the full view of the
334 constant, not on the full view of the type, which may be unconstrained.
336 This may be a reference to a type, for example in the prefix of the
337 attribute Position, generated for dispatching code (see Make_DT in
338 exp_disp,adb). In that case we need the type itself, not is parent,
339 in particular if it is a derived type */
340 if (Is_Private_Type (gnat_temp_type)
341 && Has_Unknown_Discriminants (gnat_temp_type)
342 && Present (Full_View (gnat_temp))
343 && !Is_Type (gnat_temp))
345 gnat_temp = Full_View (gnat_temp);
346 gnat_temp_type = Etype (gnat_temp);
347 gnu_result_type = get_unpadded_type (gnat_temp_type);
349 else
351 /* Expand the type of this identitier first, in case it is an enumeral
352 literal, which only get made when the type is expanded. There is no
353 order-of-elaboration issue here. We want to use the Actual_Subtype if
354 it has already been elaborated, otherwise the Etype. Avoid using
355 Actual_Subtype for packed arrays to simplify things. */
356 if ((Ekind (gnat_temp) == E_Constant
357 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp))
358 && !(Is_Array_Type (Etype (gnat_temp))
359 && Present (Packed_Array_Type (Etype (gnat_temp))))
360 && Present (Actual_Subtype (gnat_temp))
361 && present_gnu_tree (Actual_Subtype (gnat_temp)))
362 gnat_temp_type = Actual_Subtype (gnat_temp);
363 else
364 gnat_temp_type = Etype (gnat_node);
366 gnu_result_type = get_unpadded_type (gnat_temp_type);
369 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
371 /* If we are in an exception handler, force this variable into memory to
372 ensure optimization does not remove stores that appear redundant but are
373 actually needed in case an exception occurs.
375 ??? Note that we need not do this if the variable is declared within the
376 handler, only if it is referenced in the handler and declared in an
377 enclosing block, but we have no way of testing that right now.
379 ??? Also, for now all we can do is make it volatile. But we only
380 do this for SJLJ. */
381 if (TREE_VALUE (gnu_except_ptr_stack)
382 && TREE_CODE (gnu_result) == VAR_DECL)
383 TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1;
385 /* Some objects (such as parameters passed by reference, globals of
386 variable size, and renamed objects) actually represent the address
387 of the object. In that case, we must do the dereference. Likewise,
388 deal with parameters to foreign convention subprograms. Call fold
389 here since GNU_RESULT may be a CONST_DECL. */
390 if (DECL_P (gnu_result)
391 && (DECL_BY_REF_P (gnu_result)
392 || (TREE_CODE (gnu_result) == PARM_DECL
393 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
395 bool ro = DECL_POINTS_TO_READONLY_P (gnu_result);
396 tree initial;
398 if (TREE_CODE (gnu_result) == PARM_DECL
399 && DECL_BY_COMPONENT_PTR_P (gnu_result))
400 gnu_result
401 = build_unary_op (INDIRECT_REF, NULL_TREE,
402 convert (build_pointer_type (gnu_result_type),
403 gnu_result));
405 /* If the object is constant, we try to do the dereference directly
406 through the DECL_INITIAL. This is actually required in order to get
407 correct aliasing information for renamed objects that are components
408 of non-aliased aggregates, because the type of the renamed object and
409 that of the aggregate don't alias.
411 Note that we expect the initial value to have been stabilized.
412 If it contains e.g. a variable reference, we certainly don't want
413 to re-evaluate the variable each time the renaming is used.
415 Stabilization is currently not performed at the global level but
416 create_var_decl avoids setting DECL_INITIAL if the value is not
417 constant then, and we get to the pointer dereference below.
419 ??? Couldn't the aliasing issue show up again in this case ?
420 There is no obvious reason why not. */
421 else if (TREE_READONLY (gnu_result)
422 && DECL_INITIAL (gnu_result)
423 /* Strip possible conversion to reference type. */
424 && ((initial = TREE_CODE (DECL_INITIAL (gnu_result))
425 == NOP_EXPR
426 ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0)
427 : DECL_INITIAL (gnu_result), 1))
428 && TREE_CODE (initial) == ADDR_EXPR
429 && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF
430 || (TREE_CODE (TREE_OPERAND (initial, 0))
431 == COMPONENT_REF)))
432 gnu_result = TREE_OPERAND (initial, 0);
433 else
434 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
435 fold (gnu_result));
437 TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
440 /* The GNAT tree has the type of a function as the type of its result. Also
441 use the type of the result if the Etype is a subtype which is nominally
442 unconstrained. But remove any padding from the resulting type. */
443 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE
444 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type))
446 gnu_result_type = TREE_TYPE (gnu_result);
447 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
448 && TYPE_IS_PADDING_P (gnu_result_type))
449 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
452 /* We always want to return the underlying INTEGER_CST for an enumeration
453 literal to avoid the need to call fold in lots of places. But don't do
454 this is the parent will be taking the address of this object. */
455 if (TREE_CODE (gnu_result) == CONST_DECL)
457 gnat_temp = Parent (gnat_node);
458 if (!DECL_CONST_CORRESPONDING_VAR (gnu_result)
459 || (Nkind (gnat_temp) != N_Reference
460 && !(Nkind (gnat_temp) == N_Attribute_Reference
461 && ((Get_Attribute_Id (Attribute_Name (gnat_temp))
462 == Attr_Address)
463 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
464 == Attr_Access)
465 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
466 == Attr_Unchecked_Access)
467 || (Get_Attribute_Id (Attribute_Name (gnat_temp))
468 == Attr_Unrestricted_Access)))))
469 gnu_result = DECL_INITIAL (gnu_result);
472 *gnu_result_type_p = gnu_result_type;
473 return gnu_result;
476 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
477 any statements we generate. */
479 static tree
480 Pragma_to_gnu (Node_Id gnat_node)
482 Node_Id gnat_temp;
483 tree gnu_result = alloc_stmt_list ();
485 /* Check for (and ignore) unrecognized pragma and do nothing if we are just
486 annotating types. */
487 if (type_annotate_only || !Is_Pragma_Name (Chars (gnat_node)))
488 return gnu_result;
490 switch (Get_Pragma_Id (Chars (gnat_node)))
492 case Pragma_Inspection_Point:
493 /* Do nothing at top level: all such variables are already viewable. */
494 if (global_bindings_p ())
495 break;
497 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
498 Present (gnat_temp);
499 gnat_temp = Next (gnat_temp))
501 tree gnu_expr = gnat_to_gnu (Expression (gnat_temp));
503 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF)
504 gnu_expr = TREE_OPERAND (gnu_expr, 0);
506 gnu_expr = build1 (USE_STMT, void_type_node, gnu_expr);
507 annotate_with_node (gnu_expr, gnat_node);
508 append_to_statement_list (gnu_expr, &gnu_result);
510 break;
512 case Pragma_Optimize:
513 switch (Chars (Expression
514 (First (Pragma_Argument_Associations (gnat_node)))))
516 case Name_Time: case Name_Space:
517 if (optimize == 0)
518 post_error ("insufficient -O value?", gnat_node);
519 break;
521 case Name_Off:
522 if (optimize != 0)
523 post_error ("must specify -O0?", gnat_node);
524 break;
526 default:
527 gcc_unreachable ();
529 break;
531 case Pragma_Reviewable:
532 if (write_symbols == NO_DEBUG)
533 post_error ("must specify -g?", gnat_node);
534 break;
537 return gnu_result;
539 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Attribute,
540 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
541 where we should place the result type. ATTRIBUTE is the attribute ID. */
543 static tree
544 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
546 tree gnu_result = error_mark_node;
547 tree gnu_result_type;
548 tree gnu_expr;
549 bool prefix_unused = false;
550 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
551 tree gnu_type = TREE_TYPE (gnu_prefix);
553 /* If the input is a NULL_EXPR, make a new one. */
554 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
556 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
557 return build1 (NULL_EXPR, *gnu_result_type_p,
558 TREE_OPERAND (gnu_prefix, 0));
561 switch (attribute)
563 case Attr_Pos:
564 case Attr_Val:
565 /* These are just conversions until since representation clauses for
566 enumerations are handled in the front end. */
568 bool checkp = Do_Range_Check (First (Expressions (gnat_node)));
570 gnu_result = gnat_to_gnu (First (Expressions (gnat_node)));
571 gnu_result_type = get_unpadded_type (Etype (gnat_node));
572 gnu_result = convert_with_check (Etype (gnat_node), gnu_result,
573 checkp, checkp, true);
575 break;
577 case Attr_Pred:
578 case Attr_Succ:
579 /* These just add or subject the constant 1. Representation clauses for
580 enumerations are handled in the front-end. */
581 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
582 gnu_result_type = get_unpadded_type (Etype (gnat_node));
584 if (Do_Range_Check (First (Expressions (gnat_node))))
586 gnu_expr = protect_multiple_eval (gnu_expr);
587 gnu_expr
588 = emit_check
589 (build_binary_op (EQ_EXPR, integer_type_node,
590 gnu_expr,
591 attribute == Attr_Pred
592 ? TYPE_MIN_VALUE (gnu_result_type)
593 : TYPE_MAX_VALUE (gnu_result_type)),
594 gnu_expr, CE_Range_Check_Failed);
597 gnu_result
598 = build_binary_op (attribute == Attr_Pred
599 ? MINUS_EXPR : PLUS_EXPR,
600 gnu_result_type, gnu_expr,
601 convert (gnu_result_type, integer_one_node));
602 break;
604 case Attr_Address:
605 case Attr_Unrestricted_Access:
606 /* Conversions don't change something's address but can cause us to miss
607 the COMPONENT_REF case below, so strip them off. */
608 gnu_prefix = remove_conversions (gnu_prefix,
609 !Must_Be_Byte_Aligned (gnat_node));
611 /* If we are taking 'Address of an unconstrained object, this is the
612 pointer to the underlying array. */
613 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
615 /* ... fall through ... */
617 case Attr_Access:
618 case Attr_Unchecked_Access:
619 case Attr_Code_Address:
620 gnu_result_type = get_unpadded_type (Etype (gnat_node));
621 gnu_result
622 = build_unary_op (((attribute == Attr_Address
623 || attribute == Attr_Unrestricted_Access)
624 && !Must_Be_Byte_Aligned (gnat_node))
625 ? ATTR_ADDR_EXPR : ADDR_EXPR,
626 gnu_result_type, gnu_prefix);
628 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
629 don't try to build a trampoline. */
630 if (attribute == Attr_Code_Address)
632 for (gnu_expr = gnu_result;
633 TREE_CODE (gnu_expr) == NOP_EXPR
634 || TREE_CODE (gnu_expr) == CONVERT_EXPR;
635 gnu_expr = TREE_OPERAND (gnu_expr, 0))
636 TREE_CONSTANT (gnu_expr) = 1;
638 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
639 TREE_STATIC (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
641 break;
643 case Attr_Pool_Address:
645 tree gnu_obj_type;
646 tree gnu_ptr = gnu_prefix;
648 gnu_result_type = get_unpadded_type (Etype (gnat_node));
650 /* If this is an unconstrained array, we know the object must have been
651 allocated with the template in front of the object. So compute the
652 template address.*/
653 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
654 gnu_ptr
655 = convert (build_pointer_type
656 (TYPE_OBJECT_RECORD_TYPE
657 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
658 gnu_ptr);
660 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
661 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
662 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
664 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
665 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
666 tree gnu_byte_offset
667 = convert (gnu_char_ptr_type,
668 size_diffop (size_zero_node, gnu_pos));
670 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
671 gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
672 gnu_ptr, gnu_byte_offset);
675 gnu_result = convert (gnu_result_type, gnu_ptr);
677 break;
679 case Attr_Size:
680 case Attr_Object_Size:
681 case Attr_Value_Size:
682 case Attr_Max_Size_In_Storage_Elements:
683 gnu_expr = gnu_prefix;
685 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
686 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
687 while (TREE_CODE (gnu_expr) == NOP_EXPR)
688 gnu_expr = TREE_OPERAND (gnu_expr, 0)
691 gnu_prefix = remove_conversions (gnu_prefix, true);
692 prefix_unused = true;
693 gnu_type = TREE_TYPE (gnu_prefix);
695 /* Replace an unconstrained array type with the type of the underlying
696 array. We can't do this with a call to maybe_unconstrained_array
697 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements,
698 use the record type that will be used to allocate the object and its
699 template. */
700 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
702 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
703 if (attribute != Attr_Max_Size_In_Storage_Elements)
704 gnu_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
707 /* If we're looking for the size of a field, return the field size.
708 Otherwise, if the prefix is an object, or if 'Object_Size or
709 'Max_Size_In_Storage_Elements has been specified, the result is the
710 GCC size of the type. Otherwise, the result is the RM_Size of the
711 type. */
712 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
713 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
714 else if (TREE_CODE (gnu_prefix) != TYPE_DECL
715 || attribute == Attr_Object_Size
716 || attribute == Attr_Max_Size_In_Storage_Elements)
718 /* If this is a padded type, the GCC size isn't relevant to the
719 programmer. Normally, what we want is the RM_Size, which was set
720 from the specified size, but if it was not set, we want the size
721 of the relevant field. Using the MAX of those two produces the
722 right result in all case. Don't use the size of the field if it's
723 a self-referential type, since that's never what's wanted. */
724 if (TREE_CODE (gnu_type) == RECORD_TYPE
725 && TYPE_IS_PADDING_P (gnu_type)
726 && TREE_CODE (gnu_expr) == COMPONENT_REF)
728 gnu_result = rm_size (gnu_type);
729 if (!(CONTAINS_PLACEHOLDER_P
730 (DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
731 gnu_result
732 = size_binop (MAX_EXPR, gnu_result,
733 DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
735 else
736 gnu_result = TYPE_SIZE (gnu_type);
738 else
739 gnu_result = rm_size (gnu_type);
741 gcc_assert (gnu_result);
743 /* Deal with a self-referential size by returning the maximum size for a
744 type and by qualifying the size with the object for 'Size of an
745 object. */
746 if (CONTAINS_PLACEHOLDER_P (gnu_result))
748 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
749 gnu_result = substitute_placeholder_in_expr (gnu_result,
750 gnu_expr);
751 else
752 gnu_result = max_size (gnu_result, true);
755 /* If the type contains a template, subtract its size. */
756 if (TREE_CODE (gnu_type) == RECORD_TYPE
757 && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
758 gnu_result = size_binop (MINUS_EXPR, gnu_result,
759 DECL_SIZE (TYPE_FIELDS (gnu_type)));
761 gnu_result_type = get_unpadded_type (Etype (gnat_node));
763 /* Always perform division using unsigned arithmetic as the size cannot
764 be negative, but may be an overflowed positive value. This provides
765 correct results for sizes up to 512 MB.
767 ??? Size should be calculated in storage elements directly. */
769 if (attribute == Attr_Max_Size_In_Storage_Elements)
770 gnu_result = convert (sizetype,
771 fold (build2 (CEIL_DIV_EXPR, bitsizetype,
772 gnu_result, bitsize_unit_node)));
773 break;
775 case Attr_Alignment:
776 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
777 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
778 == RECORD_TYPE)
779 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
780 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
782 gnu_type = TREE_TYPE (gnu_prefix);
783 gnu_result_type = get_unpadded_type (Etype (gnat_node));
784 prefix_unused = true;
786 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
787 gnu_result = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)));
788 else
789 gnu_result = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
790 break;
792 case Attr_First:
793 case Attr_Last:
794 case Attr_Range_Length:
795 prefix_unused = true;
797 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE)
799 gnu_result_type = get_unpadded_type (Etype (gnat_node));
801 if (attribute == Attr_First)
802 gnu_result = TYPE_MIN_VALUE (gnu_type);
803 else if (attribute == Attr_Last)
804 gnu_result = TYPE_MAX_VALUE (gnu_type);
805 else
806 gnu_result
807 = build_binary_op
808 (MAX_EXPR, get_base_type (gnu_result_type),
809 build_binary_op
810 (PLUS_EXPR, get_base_type (gnu_result_type),
811 build_binary_op (MINUS_EXPR,
812 get_base_type (gnu_result_type),
813 convert (gnu_result_type,
814 TYPE_MAX_VALUE (gnu_type)),
815 convert (gnu_result_type,
816 TYPE_MIN_VALUE (gnu_type))),
817 convert (gnu_result_type, integer_one_node)),
818 convert (gnu_result_type, integer_zero_node));
820 break;
823 /* ... fall through ... */
825 case Attr_Length:
827 int Dimension = (Present (Expressions (gnat_node))
828 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
829 : 1);
831 /* Make sure any implicit dereference gets done. */
832 gnu_prefix = maybe_implicit_deref (gnu_prefix);
833 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
834 gnu_type = TREE_TYPE (gnu_prefix);
835 prefix_unused = true;
836 gnu_result_type = get_unpadded_type (Etype (gnat_node));
838 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
840 int ndim;
841 tree gnu_type_temp;
843 for (ndim = 1, gnu_type_temp = gnu_type;
844 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
845 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
846 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
849 Dimension = ndim + 1 - Dimension;
852 for (; Dimension > 1; Dimension--)
853 gnu_type = TREE_TYPE (gnu_type);
855 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
856 if (attribute == Attr_First)
857 gnu_result
858 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
859 else if (attribute == Attr_Last)
860 gnu_result
861 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
862 else
863 /* 'Length or 'Range_Length. */
865 tree gnu_compute_type
866 = gnat_signed_or_unsigned_type (0,
867 get_base_type (gnu_result_type));
869 gnu_result
870 = build_binary_op
871 (MAX_EXPR, gnu_compute_type,
872 build_binary_op
873 (PLUS_EXPR, gnu_compute_type,
874 build_binary_op
875 (MINUS_EXPR, gnu_compute_type,
876 convert (gnu_compute_type,
877 TYPE_MAX_VALUE
878 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
879 convert (gnu_compute_type,
880 TYPE_MIN_VALUE
881 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
882 convert (gnu_compute_type, integer_one_node)),
883 convert (gnu_compute_type, integer_zero_node));
886 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
887 handling. Note that these attributes could not have been used on
888 an unconstrained array type. */
889 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result,
890 gnu_prefix);
891 break;
894 case Attr_Bit_Position:
895 case Attr_Position:
896 case Attr_First_Bit:
897 case Attr_Last_Bit:
898 case Attr_Bit:
900 HOST_WIDE_INT bitsize;
901 HOST_WIDE_INT bitpos;
902 tree gnu_offset;
903 tree gnu_field_bitpos;
904 tree gnu_field_offset;
905 tree gnu_inner;
906 enum machine_mode mode;
907 int unsignedp, volatilep;
909 gnu_result_type = get_unpadded_type (Etype (gnat_node));
910 gnu_prefix = remove_conversions (gnu_prefix, true);
911 prefix_unused = true;
913 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
914 the result is 0. Don't allow 'Bit on a bare component, though. */
915 if (attribute == Attr_Bit
916 && TREE_CODE (gnu_prefix) != COMPONENT_REF
917 && TREE_CODE (gnu_prefix) != FIELD_DECL)
919 gnu_result = integer_zero_node;
920 break;
923 else
924 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
925 || (attribute == Attr_Bit_Position
926 && TREE_CODE (gnu_prefix) == FIELD_DECL));
928 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
929 &mode, &unsignedp, &volatilep, false);
931 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
933 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
934 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
936 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
937 TREE_CODE (gnu_inner) == COMPONENT_REF
938 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
939 gnu_inner = TREE_OPERAND (gnu_inner, 0))
941 gnu_field_bitpos
942 = size_binop (PLUS_EXPR, gnu_field_bitpos,
943 bit_position (TREE_OPERAND (gnu_inner, 1)));
944 gnu_field_offset
945 = size_binop (PLUS_EXPR, gnu_field_offset,
946 byte_position (TREE_OPERAND (gnu_inner, 1)));
949 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
951 gnu_field_bitpos = bit_position (gnu_prefix);
952 gnu_field_offset = byte_position (gnu_prefix);
954 else
956 gnu_field_bitpos = bitsize_zero_node;
957 gnu_field_offset = size_zero_node;
960 switch (attribute)
962 case Attr_Position:
963 gnu_result = gnu_field_offset;
964 break;
966 case Attr_First_Bit:
967 case Attr_Bit:
968 gnu_result = size_int (bitpos % BITS_PER_UNIT);
969 break;
971 case Attr_Last_Bit:
972 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT);
973 gnu_result = size_binop (PLUS_EXPR, gnu_result,
974 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
975 gnu_result = size_binop (MINUS_EXPR, gnu_result,
976 bitsize_one_node);
977 break;
979 case Attr_Bit_Position:
980 gnu_result = gnu_field_bitpos;
981 break;
984 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
985 we are handling. */
986 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
987 break;
990 case Attr_Min:
991 case Attr_Max:
993 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
994 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
996 gnu_result_type = get_unpadded_type (Etype (gnat_node));
997 gnu_result = build_binary_op (attribute == Attr_Min
998 ? MIN_EXPR : MAX_EXPR,
999 gnu_result_type, gnu_lhs, gnu_rhs);
1001 break;
1003 case Attr_Passed_By_Reference:
1004 gnu_result = size_int (default_pass_by_ref (gnu_type)
1005 || must_pass_by_ref (gnu_type));
1006 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1007 break;
1009 case Attr_Component_Size:
1010 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1011 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1012 == RECORD_TYPE)
1013 && (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1014 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1016 gnu_prefix = maybe_implicit_deref (gnu_prefix);
1017 gnu_type = TREE_TYPE (gnu_prefix);
1019 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1020 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
1022 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
1023 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
1024 gnu_type = TREE_TYPE (gnu_type);
1026 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
1028 /* Note this size cannot be self-referential. */
1029 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
1030 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1031 prefix_unused = true;
1032 break;
1034 case Attr_Null_Parameter:
1035 /* This is just a zero cast to the pointer type for
1036 our prefix and dereferenced. */
1037 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1038 gnu_result
1039 = build_unary_op (INDIRECT_REF, NULL_TREE,
1040 convert (build_pointer_type (gnu_result_type),
1041 integer_zero_node));
1042 TREE_PRIVATE (gnu_result) = 1;
1043 break;
1045 case Attr_Mechanism_Code:
1047 int code;
1048 Entity_Id gnat_obj = Entity (Prefix (gnat_node));
1050 prefix_unused = true;
1051 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1052 if (Present (Expressions (gnat_node)))
1054 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
1056 for (gnat_obj = First_Formal (gnat_obj); i > 1;
1057 i--, gnat_obj = Next_Formal (gnat_obj))
1061 code = Mechanism (gnat_obj);
1062 if (code == Default)
1063 code = ((present_gnu_tree (gnat_obj)
1064 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
1065 || ((TREE_CODE (get_gnu_tree (gnat_obj))
1066 == PARM_DECL)
1067 && (DECL_BY_COMPONENT_PTR_P
1068 (get_gnu_tree (gnat_obj))))))
1069 ? By_Reference : By_Copy);
1070 gnu_result = convert (gnu_result_type, size_int (- code));
1072 break;
1074 default:
1075 /* Say we have an unimplemented attribute. Then set the value to be
1076 returned to be a zero and hope that's something we can convert to the
1077 type of this attribute. */
1078 post_error ("unimplemented attribute", gnat_node);
1079 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1080 gnu_result = integer_zero_node;
1081 break;
1084 /* If this is an attribute where the prefix was unused, force a use of it if
1085 it has a side-effect. But don't do it if the prefix is just an entity
1086 name. However, if an access check is needed, we must do it. See second
1087 example in AARM 11.6(5.e). */
1088 if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
1089 && !Is_Entity_Name (Prefix (gnat_node)))
1090 gnu_result = fold (build2 (COMPOUND_EXPR, TREE_TYPE (gnu_result),
1091 gnu_prefix, gnu_result));
1093 *gnu_result_type_p = gnu_result_type;
1094 return gnu_result;
1097 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
1098 to a GCC tree, which is returned. */
1100 static tree
1101 Case_Statement_to_gnu (Node_Id gnat_node)
1103 tree gnu_result;
1104 tree gnu_expr;
1105 Node_Id gnat_when;
1107 gnu_expr = gnat_to_gnu (Expression (gnat_node));
1108 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1110 /* The range of values in a case statement is determined by the rules in
1111 RM 5.4(7-9). In almost all cases, this range is represented by the Etype
1112 of the expression. One exception arises in the case of a simple name that
1113 is parenthesized. This still has the Etype of the name, but since it is
1114 not a name, para 7 does not apply, and we need to go to the base type.
1115 This is the only case where parenthesization affects the dynamic
1116 semantics (i.e. the range of possible values at runtime that is covered
1117 by the others alternative.
1119 Another exception is if the subtype of the expression is non-static. In
1120 that case, we also have to use the base type. */
1121 if (Paren_Count (Expression (gnat_node)) != 0
1122 || !Is_OK_Static_Subtype (Underlying_Type
1123 (Etype (Expression (gnat_node)))))
1124 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
1126 /* We build a SWITCH_EXPR that contains the code with interspersed
1127 CASE_LABEL_EXPRs for each label. */
1129 push_stack (&gnu_switch_label_stack, NULL_TREE, create_artificial_label ());
1130 start_stmt_group ();
1131 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
1132 Present (gnat_when);
1133 gnat_when = Next_Non_Pragma (gnat_when))
1135 Node_Id gnat_choice;
1137 /* First compile all the different case choices for the current WHEN
1138 alternative. */
1139 for (gnat_choice = First (Discrete_Choices (gnat_when));
1140 Present (gnat_choice); gnat_choice = Next (gnat_choice))
1142 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
1144 switch (Nkind (gnat_choice))
1146 case N_Range:
1147 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
1148 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
1149 break;
1151 case N_Subtype_Indication:
1152 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
1153 (Constraint (gnat_choice))));
1154 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
1155 (Constraint (gnat_choice))));
1156 break;
1158 case N_Identifier:
1159 case N_Expanded_Name:
1160 /* This represents either a subtype range or a static value of
1161 some kind; Ekind says which. If a static value, fall through
1162 to the next case. */
1163 if (IN (Ekind (Entity (gnat_choice)), Type_Kind))
1165 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
1167 gnu_low = fold (TYPE_MIN_VALUE (gnu_type));
1168 gnu_high = fold (TYPE_MAX_VALUE (gnu_type));
1169 break;
1172 /* ... fall through ... */
1174 case N_Character_Literal:
1175 case N_Integer_Literal:
1176 gnu_low = gnat_to_gnu (gnat_choice);
1177 break;
1179 case N_Others_Choice:
1180 break;
1182 default:
1183 gcc_unreachable ();
1186 add_stmt_with_node (build3 (CASE_LABEL_EXPR, void_type_node,
1187 gnu_low, gnu_high,
1188 create_artificial_label ()),
1189 gnat_choice);
1192 /* Push a binding level here in case variables are declared since we want
1193 them to be local to this set of statements instead of the block
1194 containing the Case statement. */
1195 add_stmt (build_stmt_group (Statements (gnat_when), true));
1196 add_stmt (build1 (GOTO_EXPR, void_type_node,
1197 TREE_VALUE (gnu_switch_label_stack)));
1200 /* Now emit a definition of the label all the cases branched to. */
1201 add_stmt (build1 (LABEL_EXPR, void_type_node,
1202 TREE_VALUE (gnu_switch_label_stack)));
1203 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr,
1204 end_stmt_group (), NULL_TREE);
1205 pop_stack (&gnu_switch_label_stack);
1207 return gnu_result;
1210 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
1211 to a GCC tree, which is returned. */
1213 static tree
1214 Loop_Statement_to_gnu (Node_Id gnat_node)
1216 /* ??? It would be nice to use "build" here, but there's no build5. */
1217 tree gnu_loop_stmt = build_nt (LOOP_STMT, NULL_TREE, NULL_TREE,
1218 NULL_TREE, NULL_TREE, NULL_TREE);
1219 tree gnu_loop_var = NULL_TREE;
1220 Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
1221 tree gnu_cond_expr = NULL_TREE;
1222 tree gnu_result;
1224 TREE_TYPE (gnu_loop_stmt) = void_type_node;
1225 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
1226 LOOP_STMT_LABEL (gnu_loop_stmt) = create_artificial_label ();
1227 annotate_with_node (gnu_loop_stmt, gnat_node);
1229 /* Save the end label of this LOOP_STMT in a stack so that the corresponding
1230 N_Exit_Statement can find it. */
1231 push_stack (&gnu_loop_label_stack, NULL_TREE,
1232 LOOP_STMT_LABEL (gnu_loop_stmt));
1234 /* Set the condition that under which the loop should continue.
1235 For "LOOP .... END LOOP;" the condition is always true. */
1236 if (No (gnat_iter_scheme))
1238 /* The case "WHILE condition LOOP ..... END LOOP;" */
1239 else if (Present (Condition (gnat_iter_scheme)))
1240 LOOP_STMT_TOP_COND (gnu_loop_stmt)
1241 = gnat_to_gnu (Condition (gnat_iter_scheme));
1242 else
1244 /* We have an iteration scheme. */
1245 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
1246 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
1247 Entity_Id gnat_type = Etype (gnat_loop_var);
1248 tree gnu_type = get_unpadded_type (gnat_type);
1249 tree gnu_low = TYPE_MIN_VALUE (gnu_type);
1250 tree gnu_high = TYPE_MAX_VALUE (gnu_type);
1251 bool reversep = Reverse_Present (gnat_loop_spec);
1252 tree gnu_first = reversep ? gnu_high : gnu_low;
1253 tree gnu_last = reversep ? gnu_low : gnu_high;
1254 enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR;
1255 tree gnu_base_type = get_base_type (gnu_type);
1256 tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type)
1257 : TYPE_MAX_VALUE (gnu_base_type));
1259 /* We know the loop variable will not overflow if GNU_LAST is a constant
1260 and is not equal to GNU_LIMIT. If it might overflow, we have to move
1261 the limit test to the end of the loop. In that case, we have to test
1262 for an empty loop outside the loop. */
1263 if (TREE_CODE (gnu_last) != INTEGER_CST
1264 || TREE_CODE (gnu_limit) != INTEGER_CST
1265 || tree_int_cst_equal (gnu_last, gnu_limit))
1267 gnu_cond_expr
1268 = build3 (COND_EXPR, void_type_node,
1269 build_binary_op (LE_EXPR, integer_type_node,
1270 gnu_low, gnu_high),
1271 NULL_TREE, alloc_stmt_list ());
1272 annotate_with_node (gnu_cond_expr, gnat_loop_spec);
1275 /* Open a new nesting level that will surround the loop to declare the
1276 loop index variable. */
1277 start_stmt_group ();
1278 gnat_pushlevel ();
1280 /* Declare the loop index and set it to its initial value. */
1281 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
1282 if (DECL_BY_REF_P (gnu_loop_var))
1283 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
1285 /* The loop variable might be a padded type, so use `convert' to get a
1286 reference to the inner variable if so. */
1287 gnu_loop_var = convert (get_base_type (gnu_type), gnu_loop_var);
1289 /* Set either the top or bottom exit condition as appropriate depending
1290 on whether or not we know an overflow cannot occur. */
1291 if (gnu_cond_expr)
1292 LOOP_STMT_BOT_COND (gnu_loop_stmt)
1293 = build_binary_op (NE_EXPR, integer_type_node,
1294 gnu_loop_var, gnu_last);
1295 else
1296 LOOP_STMT_TOP_COND (gnu_loop_stmt)
1297 = build_binary_op (end_code, integer_type_node,
1298 gnu_loop_var, gnu_last);
1300 LOOP_STMT_UPDATE (gnu_loop_stmt)
1301 = build_binary_op (reversep ? PREDECREMENT_EXPR
1302 : PREINCREMENT_EXPR,
1303 TREE_TYPE (gnu_loop_var),
1304 gnu_loop_var,
1305 convert (TREE_TYPE (gnu_loop_var),
1306 integer_one_node));
1307 annotate_with_node (LOOP_STMT_UPDATE (gnu_loop_stmt),
1308 gnat_iter_scheme);
1311 /* If the loop was named, have the name point to this loop. In this case,
1312 the association is not a ..._DECL node, but the end label from this
1313 LOOP_STMT. */
1314 if (Present (Identifier (gnat_node)))
1315 save_gnu_tree (Entity (Identifier (gnat_node)),
1316 LOOP_STMT_LABEL (gnu_loop_stmt), true);
1318 /* Make the loop body into its own block, so any allocated storage will be
1319 released every iteration. This is needed for stack allocation. */
1320 LOOP_STMT_BODY (gnu_loop_stmt)
1321 = build_stmt_group (Statements (gnat_node), true);
1323 /* If we declared a variable, then we are in a statement group for that
1324 declaration. Add the LOOP_STMT to it and make that the "loop". */
1325 if (gnu_loop_var)
1327 add_stmt (gnu_loop_stmt);
1328 gnat_poplevel ();
1329 gnu_loop_stmt = end_stmt_group ();
1332 /* If we have an outer COND_EXPR, that's our result and this loop is its
1333 "true" statement. Otherwise, the result is the LOOP_STMT. */
1334 if (gnu_cond_expr)
1336 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
1337 gnu_result = gnu_cond_expr;
1338 recalculate_side_effects (gnu_cond_expr);
1340 else
1341 gnu_result = gnu_loop_stmt;
1343 pop_stack (&gnu_loop_label_stack);
1345 return gnu_result;
1348 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
1349 don't return anything. */
1351 static void
1352 Subprogram_Body_to_gnu (Node_Id gnat_node)
1354 /* Save debug output mode in case it is reset. */
1355 enum debug_info_type save_write_symbols = write_symbols;
1356 const struct gcc_debug_hooks *const save_debug_hooks = debug_hooks;
1357 /* Definining identifier of a parameter to the subprogram. */
1358 Entity_Id gnat_param;
1359 /* The defining identifier for the subprogram body. Note that if a
1360 specification has appeared before for this body, then the identifier
1361 occurring in that specification will also be a defining identifier and all
1362 the calls to this subprogram will point to that specification. */
1363 Entity_Id gnat_subprog_id
1364 = (Present (Corresponding_Spec (gnat_node))
1365 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
1366 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
1367 tree gnu_subprog_decl;
1368 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
1369 tree gnu_subprog_type;
1370 tree gnu_cico_list;
1371 tree gnu_result;
1373 /* If this is a generic object or if it has been eliminated,
1374 ignore it. */
1375 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
1376 || Ekind (gnat_subprog_id) == E_Generic_Function
1377 || Is_Eliminated (gnat_subprog_id))
1378 return;
1380 /* If debug information is suppressed for the subprogram, turn debug
1381 mode off for the duration of processing. */
1382 if (!Needs_Debug_Info (gnat_subprog_id))
1384 write_symbols = NO_DEBUG;
1385 debug_hooks = &do_nothing_debug_hooks;
1388 /* If this subprogram acts as its own spec, define it. Otherwise, just get
1389 the already-elaborated tree node. However, if this subprogram had its
1390 elaboration deferred, we will already have made a tree node for it. So
1391 treat it as not being defined in that case. Such a subprogram cannot
1392 have an address clause or a freeze node, so this test is safe, though it
1393 does disable some otherwise-useful error checking. */
1394 gnu_subprog_decl
1395 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
1396 Acts_As_Spec (gnat_node)
1397 && !present_gnu_tree (gnat_subprog_id));
1399 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
1401 /* Set the line number in the decl to correspond to that of the body so that
1402 the line number notes are written
1403 correctly. */
1404 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (gnu_subprog_decl));
1406 begin_subprog_body (gnu_subprog_decl);
1407 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1409 /* If there are OUT parameters, we need to ensure that the return statement
1410 properly copies them out. We do this by making a new block and converting
1411 any inner return into a goto to a label at the end of the block. */
1412 push_stack (&gnu_return_label_stack, NULL_TREE,
1413 gnu_cico_list ? create_artificial_label () : NULL_TREE);
1415 /* Get a tree corresponding to the code for the subprogram. */
1416 start_stmt_group ();
1417 gnat_pushlevel ();
1419 /* See if there are any parameters for which we don't yet have GCC entities.
1420 These must be for OUT parameters for which we will be making VAR_DECL
1421 nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty
1422 entry as well. We can match up the entries because TYPE_CI_CO_LIST is in
1423 the order of the parameters. */
1424 for (gnat_param = First_Formal (gnat_subprog_id);
1425 Present (gnat_param);
1426 gnat_param = Next_Formal_With_Extras (gnat_param))
1427 if (!present_gnu_tree (gnat_param))
1429 /* Skip any entries that have been already filled in; they must
1430 correspond to IN OUT parameters. */
1431 for (; gnu_cico_list && TREE_VALUE (gnu_cico_list);
1432 gnu_cico_list = TREE_CHAIN (gnu_cico_list))
1435 /* Do any needed references for padded types. */
1436 TREE_VALUE (gnu_cico_list)
1437 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
1438 gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
1441 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
1443 /* Generate the code of the subprogram itself. A return statement will be
1444 present and any OUT parameters will be handled there. */
1445 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
1446 gnat_poplevel ();
1447 gnu_result = end_stmt_group ();
1449 /* If we made a special return label, we need to make a block that contains
1450 the definition of that label and the copying to the return value. That
1451 block first contains the function, then the label and copy statement. */
1452 if (TREE_VALUE (gnu_return_label_stack))
1454 tree gnu_retval;
1456 start_stmt_group ();
1457 gnat_pushlevel ();
1458 add_stmt (gnu_result);
1459 add_stmt (build1 (LABEL_EXPR, void_type_node,
1460 TREE_VALUE (gnu_return_label_stack)));
1462 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1463 if (list_length (gnu_cico_list) == 1)
1464 gnu_retval = TREE_VALUE (gnu_cico_list);
1465 else
1466 gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
1467 gnu_cico_list);
1469 if (DECL_P (gnu_retval) && DECL_BY_REF_P (gnu_retval))
1470 gnu_retval = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_retval);
1472 add_stmt_with_node
1473 (build_return_expr (DECL_RESULT (current_function_decl), gnu_retval),
1474 gnat_node);
1475 gnat_poplevel ();
1476 gnu_result = end_stmt_group ();
1479 pop_stack (&gnu_return_label_stack);
1481 /* Initialize the information node for the function and set the
1482 end location. */
1483 allocate_struct_function (current_function_decl);
1484 Sloc_to_locus
1485 ((Present (End_Label (Handled_Statement_Sequence (gnat_node)))
1486 ? Sloc (End_Label (Handled_Statement_Sequence (gnat_node)))
1487 : Sloc (gnat_node)),
1488 &cfun->function_end_locus);
1490 end_subprog_body (gnu_result);
1492 /* Disconnect the trees for parameters that we made variables for from the
1493 GNAT entities since these are unusable after we end the function. */
1494 for (gnat_param = First_Formal (gnat_subprog_id);
1495 Present (gnat_param);
1496 gnat_param = Next_Formal_With_Extras (gnat_param))
1497 if (TREE_CODE (get_gnu_tree (gnat_param)) == VAR_DECL)
1498 save_gnu_tree (gnat_param, NULL_TREE, false);
1500 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
1501 write_symbols = save_write_symbols;
1502 debug_hooks = save_debug_hooks;
1505 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
1506 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
1507 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
1508 If GNU_TARGET is non-null, this must be a function call and the result
1509 of the call is to be placed into that object. */
1511 static tree
1512 call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
1514 tree gnu_result;
1515 /* The GCC node corresponding to the GNAT subprogram name. This can either
1516 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
1517 or an indirect reference expression (an INDIRECT_REF node) pointing to a
1518 subprogram. */
1519 tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node));
1520 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
1521 tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node);
1522 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE,
1523 gnu_subprog_node);
1524 Entity_Id gnat_formal;
1525 Node_Id gnat_actual;
1526 tree gnu_actual_list = NULL_TREE;
1527 tree gnu_name_list = NULL_TREE;
1528 tree gnu_before_list = NULL_TREE;
1529 tree gnu_after_list = NULL_TREE;
1530 tree gnu_subprog_call;
1532 switch (Nkind (Name (gnat_node)))
1534 case N_Identifier:
1535 case N_Operator_Symbol:
1536 case N_Expanded_Name:
1537 case N_Attribute_Reference:
1538 if (Is_Eliminated (Entity (Name (gnat_node))))
1539 Eliminate_Error_Msg (gnat_node, Entity (Name (gnat_node)));
1542 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
1544 /* If we are calling a stubbed function, make this into a raise of
1545 Program_Error. Elaborate all our args first. */
1546 if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
1547 && DECL_STUBBED_P (gnu_subprog_node))
1549 for (gnat_actual = First_Actual (gnat_node);
1550 Present (gnat_actual);
1551 gnat_actual = Next_Actual (gnat_actual))
1552 add_stmt (gnat_to_gnu (gnat_actual));
1554 if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
1556 *gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
1557 return build1 (NULL_EXPR, *gnu_result_type_p,
1558 build_call_raise (PE_Stubbed_Subprogram_Called));
1560 else
1561 return build_call_raise (PE_Stubbed_Subprogram_Called);
1564 /* If we are calling by supplying a pointer to a target, set up that
1565 pointer as the first argument. Use GNU_TARGET if one was passed;
1566 otherwise, make a target by building a variable of the maximum size
1567 of the type. */
1568 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
1570 tree gnu_real_ret_type
1571 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
1573 if (!gnu_target)
1575 tree gnu_obj_type
1576 = maybe_pad_type (gnu_real_ret_type,
1577 max_size (TYPE_SIZE (gnu_real_ret_type), true),
1578 0, Etype (Name (gnat_node)), "PAD", false,
1579 false, false);
1581 gnu_target = create_tmp_var_raw (gnu_obj_type, "LR");
1582 gnat_pushdecl (gnu_target, gnat_node);
1585 gnu_actual_list
1586 = tree_cons (NULL_TREE,
1587 build_unary_op (ADDR_EXPR, NULL_TREE,
1588 unchecked_convert (gnu_real_ret_type,
1589 gnu_target,
1590 false)),
1591 NULL_TREE);
1595 /* The only way we can be making a call via an access type is if Name is an
1596 explicit dereference. In that case, get the list of formal args from the
1597 type the access type is pointing to. Otherwise, get the formals from
1598 entity being called. */
1599 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
1600 gnat_formal = First_Formal (Etype (Name (gnat_node)));
1601 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
1602 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
1603 gnat_formal = 0;
1604 else
1605 gnat_formal = First_Formal (Entity (Name (gnat_node)));
1607 /* Create the list of the actual parameters as GCC expects it, namely a chain
1608 of TREE_LIST nodes in which the TREE_VALUE field of each node is a
1609 parameter-expression and the TREE_PURPOSE field is null. Skip OUT
1610 parameters not passed by reference and don't need to be copied in. */
1611 for (gnat_actual = First_Actual (gnat_node);
1612 Present (gnat_actual);
1613 gnat_formal = Next_Formal_With_Extras (gnat_formal),
1614 gnat_actual = Next_Actual (gnat_actual))
1616 tree gnu_formal
1617 = (present_gnu_tree (gnat_formal)
1618 ? get_gnu_tree (gnat_formal) : NULL_TREE);
1619 /* We treat a conversion between aggregate types as if it is an
1620 unchecked conversion. */
1621 bool unchecked_convert_p
1622 = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
1623 || (Nkind (gnat_actual) == N_Type_Conversion
1624 && Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))));
1625 Node_Id gnat_name = (unchecked_convert_p
1626 ? Expression (gnat_actual) : gnat_actual);
1627 tree gnu_name = gnat_to_gnu (gnat_name);
1628 tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
1629 tree gnu_actual;
1630 tree gnu_formal_type;
1632 /* If it's possible we may need to use this expression twice, make sure
1633 than any side-effects are handled via SAVE_EXPRs. Likewise if we need
1634 to force side-effects before the call.
1636 ??? This is more conservative than we need since we don't need to do
1637 this for pass-by-ref with no conversion. If we are passing a
1638 non-addressable Out or In Out parameter by reference, pass the address
1639 of a copy and set up to copy back out after the call. */
1640 if (Ekind (gnat_formal) != E_In_Parameter)
1642 gnu_name = gnat_stabilize_reference (gnu_name, true);
1643 if (!addressable_p (gnu_name)
1644 && gnu_formal
1645 && (DECL_BY_REF_P (gnu_formal)
1646 || (TREE_CODE (gnu_formal) == PARM_DECL
1647 && (DECL_BY_COMPONENT_PTR_P (gnu_formal)
1648 || (DECL_BY_DESCRIPTOR_P (gnu_formal))))))
1650 tree gnu_copy = gnu_name;
1651 tree gnu_temp;
1653 /* Remove any unpadding on the actual and make a copy. But if
1654 the actual is a justified modular type, first convert
1655 to it. */
1656 if (TREE_CODE (gnu_name) == COMPONENT_REF
1657 && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
1658 == RECORD_TYPE)
1659 && (TYPE_IS_PADDING_P
1660 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
1661 gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
1662 else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
1663 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)))
1664 gnu_name = convert (gnu_name_type, gnu_name);
1666 gnu_actual = save_expr (gnu_name);
1668 /* Since we're going to take the address of the SAVE_EXPR, we
1669 don't want it to be marked as unchanging. So set
1670 TREE_ADDRESSABLE. */
1671 gnu_temp = skip_simple_arithmetic (gnu_actual);
1672 if (TREE_CODE (gnu_temp) == SAVE_EXPR)
1674 TREE_ADDRESSABLE (gnu_temp) = 1;
1675 TREE_READONLY (gnu_temp) = 0;
1678 /* Set up to move the copy back to the original. */
1679 gnu_temp = build_binary_op (MODIFY_EXPR, NULL_TREE,
1680 gnu_copy, gnu_actual);
1681 annotate_with_node (gnu_temp, gnat_actual);
1682 append_to_statement_list (gnu_temp, &gnu_after_list);
1684 /* Account for next statement just below. */
1685 gnu_name = gnu_actual;
1689 /* If this was a procedure call, we may not have removed any padding.
1690 So do it here for the part we will use as an input, if any. */
1691 gnu_actual = gnu_name;
1692 if (Ekind (gnat_formal) != E_Out_Parameter
1693 && TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
1694 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
1695 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
1696 gnu_actual);
1698 /* Unless this is an In parameter, we must remove any LJM building
1699 from GNU_NAME. */
1700 if (Ekind (gnat_formal) != E_In_Parameter
1701 && TREE_CODE (gnu_name) == CONSTRUCTOR
1702 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE
1703 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name)))
1704 gnu_name = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))),
1705 gnu_name);
1707 if (Ekind (gnat_formal) != E_Out_Parameter
1708 && !unchecked_convert_p
1709 && Do_Range_Check (gnat_actual))
1710 gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
1712 /* Do any needed conversions. We need only check for unchecked
1713 conversion since normal conversions will be handled by just
1714 converting to the formal type. */
1715 if (unchecked_convert_p)
1717 gnu_actual
1718 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
1719 gnu_actual,
1720 (Nkind (gnat_actual)
1721 == N_Unchecked_Type_Conversion)
1722 && No_Truncation (gnat_actual));
1724 /* One we've done the unchecked conversion, we still must ensure that
1725 the object is in range of the formal's type. */
1726 if (Ekind (gnat_formal) != E_Out_Parameter
1727 && Do_Range_Check (gnat_actual))
1728 gnu_actual = emit_range_check (gnu_actual,
1729 Etype (gnat_formal));
1731 else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
1732 /* We may have suppressed a conversion to the Etype of the actual since
1733 the parent is a procedure call. So add the conversion here. */
1734 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
1735 gnu_actual);
1737 /* If we have not saved a GCC object for the formal, it means it is an
1738 OUT parameter not passed by reference and that does not need to be
1739 copied in. Otherwise, look at the PARM_DECL to see if it is passed by
1740 reference. */
1741 if (gnu_formal
1742 && TREE_CODE (gnu_formal) == PARM_DECL && DECL_BY_REF_P (gnu_formal))
1744 if (Ekind (gnat_formal) != E_In_Parameter)
1746 gnu_actual = gnu_name;
1748 /* If we have a padded type, be sure we've removed padding. */
1749 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
1750 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
1751 && TREE_CODE (gnu_actual) != SAVE_EXPR)
1752 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
1753 gnu_actual);
1755 /* If we have the constructed subtype of an aliased object
1756 with an unconstrained nominal subtype, the type of the
1757 actual includes the template, although it is formally
1758 constrained. So we need to convert it back to the real
1759 constructed subtype to retrieve the constrained part
1760 and takes its address. */
1761 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
1762 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
1763 && TREE_CODE (gnu_actual) != SAVE_EXPR
1764 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
1765 && Is_Array_Type (Etype (gnat_actual)))
1766 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
1767 gnu_actual);
1770 /* Otherwise, if we have a non-addressable COMPONENT_REF of a
1771 variable-size type see if it's doing a unpadding operation. If
1772 so, remove that operation since we have no way of allocating the
1773 required temporary. */
1774 if (TREE_CODE (gnu_actual) == COMPONENT_REF
1775 && !TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
1776 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0)))
1777 == RECORD_TYPE)
1778 && TYPE_IS_PADDING_P (TREE_TYPE
1779 (TREE_OPERAND (gnu_actual, 0)))
1780 && !addressable_p (gnu_actual))
1781 gnu_actual = TREE_OPERAND (gnu_actual, 0);
1783 /* The symmetry of the paths to the type of an entity is broken here
1784 since arguments don't know that they will be passed by ref. */
1785 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
1786 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
1788 else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
1789 && DECL_BY_COMPONENT_PTR_P (gnu_formal))
1791 gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal));
1792 gnu_actual = maybe_implicit_deref (gnu_actual);
1793 gnu_actual = maybe_unconstrained_array (gnu_actual);
1795 if (TREE_CODE (gnu_formal_type) == RECORD_TYPE
1796 && TYPE_IS_PADDING_P (gnu_formal_type))
1798 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
1799 gnu_actual = convert (gnu_formal_type, gnu_actual);
1802 /* Take the address of the object and convert to the proper pointer
1803 type. We'd like to actually compute the address of the beginning
1804 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
1805 possibility that the ARRAY_REF might return a constant and we'd be
1806 getting the wrong address. Neither approach is exactly correct,
1807 but this is the most likely to work in all cases. */
1808 gnu_actual = convert (gnu_formal_type,
1809 build_unary_op (ADDR_EXPR, NULL_TREE,
1810 gnu_actual));
1812 else if (gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL
1813 && DECL_BY_DESCRIPTOR_P (gnu_formal))
1815 /* If arg is 'Null_Parameter, pass zero descriptor. */
1816 if ((TREE_CODE (gnu_actual) == INDIRECT_REF
1817 || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF)
1818 && TREE_PRIVATE (gnu_actual))
1819 gnu_actual = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
1820 integer_zero_node);
1821 else
1822 gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
1823 fill_vms_descriptor (gnu_actual,
1824 gnat_formal));
1826 else
1828 tree gnu_actual_size = TYPE_SIZE (TREE_TYPE (gnu_actual));
1830 if (Ekind (gnat_formal) != E_In_Parameter)
1831 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
1833 if (!gnu_formal || TREE_CODE (gnu_formal) != PARM_DECL)
1834 continue;
1836 /* If this is 'Null_Parameter, pass a zero even though we are
1837 dereferencing it. */
1838 else if (TREE_CODE (gnu_actual) == INDIRECT_REF
1839 && TREE_PRIVATE (gnu_actual)
1840 && host_integerp (gnu_actual_size, 1)
1841 && 0 >= compare_tree_int (gnu_actual_size,
1842 BITS_PER_WORD))
1843 gnu_actual
1844 = unchecked_convert (DECL_ARG_TYPE (gnu_formal),
1845 convert (gnat_type_for_size
1846 (tree_low_cst (gnu_actual_size, 1),
1848 integer_zero_node),
1849 false);
1850 else
1851 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
1854 gnu_actual_list = tree_cons (NULL_TREE, gnu_actual, gnu_actual_list);
1857 gnu_subprog_call = build3 (CALL_EXPR, TREE_TYPE (gnu_subprog_type),
1858 gnu_subprog_addr, nreverse (gnu_actual_list),
1859 NULL_TREE);
1861 /* If we return by passing a target, we emit the call and return the target
1862 as our result. */
1863 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
1865 add_stmt_with_node (gnu_subprog_call, gnat_node);
1866 *gnu_result_type_p
1867 = TREE_TYPE (TREE_VALUE (TYPE_ARG_TYPES (gnu_subprog_type)));
1868 return unchecked_convert (*gnu_result_type_p, gnu_target, false);
1871 /* If it is a function call, the result is the call expression unless
1872 a target is specified, in which case we copy the result into the target
1873 and return the assignment statement. */
1874 else if (Nkind (gnat_node) == N_Function_Call)
1876 gnu_result = gnu_subprog_call;
1878 /* If the function returns an unconstrained array or by reference,
1879 we have to de-dereference the pointer. */
1880 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)
1881 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type))
1882 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1884 if (gnu_target)
1885 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
1886 gnu_target, gnu_result);
1887 else
1888 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
1890 return gnu_result;
1893 /* If this is the case where the GNAT tree contains a procedure call
1894 but the Ada procedure has copy in copy out parameters, the special
1895 parameter passing mechanism must be used. */
1896 else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE)
1898 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
1899 in copy out parameters. */
1900 tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type);
1901 int length = list_length (scalar_return_list);
1903 if (length > 1)
1905 tree gnu_name;
1907 gnu_subprog_call = save_expr (gnu_subprog_call);
1908 gnu_name_list = nreverse (gnu_name_list);
1910 /* If any of the names had side-effects, ensure they are all
1911 evaluated before the call. */
1912 for (gnu_name = gnu_name_list; gnu_name;
1913 gnu_name = TREE_CHAIN (gnu_name))
1914 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name)))
1915 append_to_statement_list (TREE_VALUE (gnu_name),
1916 &gnu_before_list);
1919 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
1920 gnat_formal = First_Formal (Etype (Name (gnat_node)));
1921 else
1922 gnat_formal = First_Formal (Entity (Name (gnat_node)));
1924 for (gnat_actual = First_Actual (gnat_node);
1925 Present (gnat_actual);
1926 gnat_formal = Next_Formal_With_Extras (gnat_formal),
1927 gnat_actual = Next_Actual (gnat_actual))
1928 /* If we are dealing with a copy in copy out parameter, we must
1929 retrieve its value from the record returned in the call. */
1930 if (!(present_gnu_tree (gnat_formal)
1931 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
1932 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
1933 || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
1934 && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
1935 || (DECL_BY_DESCRIPTOR_P
1936 (get_gnu_tree (gnat_formal))))))))
1937 && Ekind (gnat_formal) != E_In_Parameter)
1939 /* Get the value to assign to this OUT or IN OUT parameter. It is
1940 either the result of the function if there is only a single such
1941 parameter or the appropriate field from the record returned. */
1942 tree gnu_result
1943 = length == 1 ? gnu_subprog_call
1944 : build_component_ref (gnu_subprog_call, NULL_TREE,
1945 TREE_PURPOSE (scalar_return_list),
1946 false);
1947 bool unchecked_conversion = (Nkind (gnat_actual)
1948 == N_Unchecked_Type_Conversion);
1949 /* If the actual is a conversion, get the inner expression, which
1950 will be the real destination, and convert the result to the
1951 type of the actual parameter. */
1952 tree gnu_actual
1953 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
1955 /* If the result is a padded type, remove the padding. */
1956 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
1957 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
1958 gnu_result = convert (TREE_TYPE (TYPE_FIELDS
1959 (TREE_TYPE (gnu_result))),
1960 gnu_result);
1962 /* If the result is a type conversion, do it. */
1963 if (Nkind (gnat_actual) == N_Type_Conversion)
1964 gnu_result
1965 = convert_with_check
1966 (Etype (Expression (gnat_actual)), gnu_result,
1967 Do_Overflow_Check (gnat_actual),
1968 Do_Range_Check (Expression (gnat_actual)),
1969 Float_Truncate (gnat_actual));
1971 else if (unchecked_conversion)
1972 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
1973 gnu_result,
1974 No_Truncation (gnat_actual));
1975 else
1977 if (Do_Range_Check (gnat_actual))
1978 gnu_result = emit_range_check (gnu_result,
1979 Etype (gnat_actual));
1981 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
1982 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
1983 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
1986 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
1987 gnu_actual, gnu_result);
1988 annotate_with_node (gnu_result, gnat_actual);
1989 append_to_statement_list (gnu_result, &gnu_before_list);
1990 scalar_return_list = TREE_CHAIN (scalar_return_list);
1991 gnu_name_list = TREE_CHAIN (gnu_name_list);
1994 else
1996 annotate_with_node (gnu_subprog_call, gnat_node);
1997 append_to_statement_list (gnu_subprog_call, &gnu_before_list);
2000 append_to_statement_list (gnu_after_list, &gnu_before_list);
2001 return gnu_before_list;
2004 /* Subroutine of gnat_to_gnu to translate gnat_node, an
2005 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
2007 static tree
2008 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
2010 tree gnu_jmpsave_decl = NULL_TREE;
2011 tree gnu_jmpbuf_decl = NULL_TREE;
2012 /* If just annotating, ignore all EH and cleanups. */
2013 bool gcc_zcx = (!type_annotate_only
2014 && Present (Exception_Handlers (gnat_node))
2015 && Exception_Mechanism == GCC_ZCX);
2016 bool setjmp_longjmp
2017 = (!type_annotate_only && Present (Exception_Handlers (gnat_node))
2018 && Exception_Mechanism == Setjmp_Longjmp);
2019 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
2020 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp);
2021 tree gnu_inner_block; /* The statement(s) for the block itself. */
2022 tree gnu_result;
2023 tree gnu_expr;
2024 Node_Id gnat_temp;
2026 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
2027 and we have our own SJLJ mechanism. To call the GCC mechanism, we call
2028 add_cleanup, and when we leave the binding, end_stmt_group will create
2029 the TRY_FINALLY_EXPR.
2031 ??? The region level calls down there have been specifically put in place
2032 for a ZCX context and currently the order in which things are emitted
2033 (region/handlers) is different from the SJLJ case. Instead of putting
2034 other calls with different conditions at other places for the SJLJ case,
2035 it seems cleaner to reorder things for the SJLJ case and generalize the
2036 condition to make it not ZCX specific.
2038 If there are any exceptions or cleanup processing involved, we need an
2039 outer statement group (for Setjmp_Longjmp) and binding level. */
2040 if (binding_for_block)
2042 start_stmt_group ();
2043 gnat_pushlevel ();
2046 /* If we are to call a function when exiting this block add a cleanup
2047 to the binding level we made above. */
2048 if (at_end)
2049 add_cleanup (build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node))));
2051 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save
2052 area for address of previous buffer. Do this first since we need to have
2053 the setjmp buf known for any decls in this block. */
2054 if (setjmp_longjmp)
2056 gnu_jmpsave_decl = create_var_decl (get_identifier ("JMPBUF_SAVE"),
2057 NULL_TREE, jmpbuf_ptr_type,
2058 build_call_0_expr (get_jmpbuf_decl),
2059 false, false, false, false, NULL,
2060 gnat_node);
2061 gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
2062 NULL_TREE, jmpbuf_type,
2063 NULL_TREE, false, false, false, false,
2064 NULL, gnat_node);
2066 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
2068 /* When we exit this block, restore the saved value. */
2069 add_cleanup (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
2072 /* Now build the tree for the declarations and statements inside this block.
2073 If this is SJLJ, set our jmp_buf as the current buffer. */
2074 start_stmt_group ();
2076 if (setjmp_longjmp)
2077 add_stmt (build_call_1_expr (set_jmpbuf_decl,
2078 build_unary_op (ADDR_EXPR, NULL_TREE,
2079 gnu_jmpbuf_decl)));
2081 if (Present (First_Real_Statement (gnat_node)))
2082 process_decls (Statements (gnat_node), Empty,
2083 First_Real_Statement (gnat_node), true, true);
2085 /* Generate code for each statement in the block. */
2086 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
2087 ? First_Real_Statement (gnat_node)
2088 : First (Statements (gnat_node)));
2089 Present (gnat_temp); gnat_temp = Next (gnat_temp))
2090 add_stmt (gnat_to_gnu (gnat_temp));
2091 gnu_inner_block = end_stmt_group ();
2093 /* Now generate code for the two exception models, if either is relevant for
2094 this block. */
2095 if (setjmp_longjmp)
2097 tree *gnu_else_ptr = 0;
2098 tree gnu_handler;
2100 /* Make a binding level for the exception handling declarations and code
2101 and set up gnu_except_ptr_stack for the handlers to use. */
2102 start_stmt_group ();
2103 gnat_pushlevel ();
2105 push_stack (&gnu_except_ptr_stack, NULL_TREE,
2106 create_var_decl (get_identifier ("EXCEPT_PTR"),
2107 NULL_TREE,
2108 build_pointer_type (except_type_node),
2109 build_call_0_expr (get_excptr_decl), false,
2110 false, false, false, NULL, gnat_node));
2112 /* Generate code for each handler. The N_Exception_Handler case does the
2113 real work and returns a COND_EXPR for each handler, which we chain
2114 together here. */
2115 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2116 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
2118 gnu_expr = gnat_to_gnu (gnat_temp);
2120 /* If this is the first one, set it as the outer one. Otherwise,
2121 point the "else" part of the previous handler to us. Then point
2122 to our "else" part. */
2123 if (!gnu_else_ptr)
2124 add_stmt (gnu_expr);
2125 else
2126 *gnu_else_ptr = gnu_expr;
2128 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
2131 /* If none of the exception handlers did anything, re-raise but do not
2132 defer abortion. */
2133 gnu_expr = build_call_1_expr (raise_nodefer_decl,
2134 TREE_VALUE (gnu_except_ptr_stack));
2135 annotate_with_node (gnu_expr, gnat_node);
2137 if (gnu_else_ptr)
2138 *gnu_else_ptr = gnu_expr;
2139 else
2140 add_stmt (gnu_expr);
2142 /* End the binding level dedicated to the exception handlers and get the
2143 whole statement group. */
2144 pop_stack (&gnu_except_ptr_stack);
2145 gnat_poplevel ();
2146 gnu_handler = end_stmt_group ();
2148 /* If the setjmp returns 1, we restore our incoming longjmp value and
2149 then check the handlers. */
2150 start_stmt_group ();
2151 add_stmt_with_node (build_call_1_expr (set_jmpbuf_decl,
2152 gnu_jmpsave_decl),
2153 gnat_node);
2154 add_stmt (gnu_handler);
2155 gnu_handler = end_stmt_group ();
2157 /* This block is now "if (setjmp) ... <handlers> else <block>". */
2158 gnu_result = build3 (COND_EXPR, void_type_node,
2159 (build_call_1_expr
2160 (setjmp_decl,
2161 build_unary_op (ADDR_EXPR, NULL_TREE,
2162 gnu_jmpbuf_decl))),
2163 gnu_handler, gnu_inner_block);
2165 else if (gcc_zcx)
2167 tree gnu_handlers;
2169 /* First make a block containing the handlers. */
2170 start_stmt_group ();
2171 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
2172 Present (gnat_temp);
2173 gnat_temp = Next_Non_Pragma (gnat_temp))
2174 add_stmt (gnat_to_gnu (gnat_temp));
2175 gnu_handlers = end_stmt_group ();
2177 /* Now make the TRY_CATCH_EXPR for the block. */
2178 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
2179 gnu_inner_block, gnu_handlers);
2181 else
2182 gnu_result = gnu_inner_block;
2184 /* Now close our outer block, if we had to make one. */
2185 if (binding_for_block)
2187 add_stmt (gnu_result);
2188 gnat_poplevel ();
2189 gnu_result = end_stmt_group ();
2192 return gnu_result;
2195 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2196 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp
2197 exception handling. */
2199 static tree
2200 Exception_Handler_to_gnu_sjlj (Node_Id gnat_node)
2202 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
2203 an "if" statement to select the proper exceptions. For "Others", exclude
2204 exceptions where Handled_By_Others is nonzero unless the All_Others flag
2205 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
2206 tree gnu_choice = integer_zero_node;
2207 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
2208 Node_Id gnat_temp;
2210 for (gnat_temp = First (Exception_Choices (gnat_node));
2211 gnat_temp; gnat_temp = Next (gnat_temp))
2213 tree this_choice;
2215 if (Nkind (gnat_temp) == N_Others_Choice)
2217 if (All_Others (gnat_temp))
2218 this_choice = integer_one_node;
2219 else
2220 this_choice
2221 = build_binary_op
2222 (EQ_EXPR, integer_type_node,
2223 convert
2224 (integer_type_node,
2225 build_component_ref
2226 (build_unary_op
2227 (INDIRECT_REF, NULL_TREE,
2228 TREE_VALUE (gnu_except_ptr_stack)),
2229 get_identifier ("not_handled_by_others"), NULL_TREE,
2230 false)),
2231 integer_zero_node);
2234 else if (Nkind (gnat_temp) == N_Identifier
2235 || Nkind (gnat_temp) == N_Expanded_Name)
2237 Entity_Id gnat_ex_id = Entity (gnat_temp);
2238 tree gnu_expr;
2240 /* Exception may be a renaming. Recover original exception which is
2241 the one elaborated and registered. */
2242 if (Present (Renamed_Object (gnat_ex_id)))
2243 gnat_ex_id = Renamed_Object (gnat_ex_id);
2245 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2247 this_choice
2248 = build_binary_op
2249 (EQ_EXPR, integer_type_node, TREE_VALUE (gnu_except_ptr_stack),
2250 convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
2251 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
2253 /* If this is the distinguished exception "Non_Ada_Error" (and we are
2254 in VMS mode), also allow a non-Ada exception (a VMS condition) t
2255 match. */
2256 if (Is_Non_Ada_Error (Entity (gnat_temp)))
2258 tree gnu_comp
2259 = build_component_ref
2260 (build_unary_op (INDIRECT_REF, NULL_TREE,
2261 TREE_VALUE (gnu_except_ptr_stack)),
2262 get_identifier ("lang"), NULL_TREE, false);
2264 this_choice
2265 = build_binary_op
2266 (TRUTH_ORIF_EXPR, integer_type_node,
2267 build_binary_op (EQ_EXPR, integer_type_node, gnu_comp,
2268 build_int_cst (TREE_TYPE (gnu_comp), 'V')),
2269 this_choice);
2272 else
2273 gcc_unreachable ();
2275 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
2276 gnu_choice, this_choice);
2279 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
2282 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
2283 to a GCC tree, which is returned. This is the variant for ZCX. */
2285 static tree
2286 Exception_Handler_to_gnu_zcx (Node_Id gnat_node)
2288 tree gnu_etypes_list = NULL_TREE;
2289 tree gnu_expr;
2290 tree gnu_etype;
2291 tree gnu_current_exc_ptr;
2292 tree gnu_incoming_exc_ptr;
2293 Node_Id gnat_temp;
2295 /* We build a TREE_LIST of nodes representing what exception types this
2296 handler can catch, with special cases for others and all others cases.
2298 Each exception type is actually identified by a pointer to the exception
2299 id, or to a dummy object for "others" and "all others".
2301 Care should be taken to ensure that the control flow impact of "others"
2302 and "all others" is known to GCC. lang_eh_type_covers is doing the trick
2303 currently. */
2304 for (gnat_temp = First (Exception_Choices (gnat_node));
2305 gnat_temp; gnat_temp = Next (gnat_temp))
2307 if (Nkind (gnat_temp) == N_Others_Choice)
2309 tree gnu_expr
2310 = All_Others (gnat_temp) ? all_others_decl : others_decl;
2312 gnu_etype
2313 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2315 else if (Nkind (gnat_temp) == N_Identifier
2316 || Nkind (gnat_temp) == N_Expanded_Name)
2318 Entity_Id gnat_ex_id = Entity (gnat_temp);
2320 /* Exception may be a renaming. Recover original exception which is
2321 the one elaborated and registered. */
2322 if (Present (Renamed_Object (gnat_ex_id)))
2323 gnat_ex_id = Renamed_Object (gnat_ex_id);
2325 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
2326 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
2328 /* The Non_Ada_Error case for VMS exceptions is handled
2329 by the personality routine. */
2331 else
2332 gcc_unreachable ();
2334 /* The GCC interface expects NULL to be passed for catch all handlers, so
2335 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
2336 is integer_zero_node. It would not work, however, because GCC's
2337 notion of "catch all" is stronger than our notion of "others". Until
2338 we correctly use the cleanup interface as well, doing that would
2339 prevent the "all others" handlers from beeing seen, because nothing
2340 can be caught beyond a catch all from GCC's point of view. */
2341 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
2344 start_stmt_group ();
2345 gnat_pushlevel ();
2347 /* Expand a call to the begin_handler hook at the beginning of the handler,
2348 and arrange for a call to the end_handler hook to occur on every possible
2349 exit path.
2351 The hooks expect a pointer to the low level occurrence. This is required
2352 for our stack management scheme because a raise inside the handler pushes
2353 a new occurrence on top of the stack, which means that this top does not
2354 necessarily match the occurrence this handler was dealing with.
2356 The EXC_PTR_EXPR object references the exception occurrence being
2357 propagated. Upon handler entry, this is the exception for which the
2358 handler is triggered. This might not be the case upon handler exit,
2359 however, as we might have a new occurrence propagated by the handler's
2360 body, and the end_handler hook called as a cleanup in this context.
2362 We use a local variable to retrieve the incoming value at handler entry
2363 time, and reuse it to feed the end_handler hook's argument at exit. */
2364 gnu_current_exc_ptr = build0 (EXC_PTR_EXPR, ptr_type_node);
2365 gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
2366 ptr_type_node, gnu_current_exc_ptr,
2367 false, false, false, false, NULL,
2368 gnat_node);
2370 add_stmt_with_node (build_call_1_expr (begin_handler_decl,
2371 gnu_incoming_exc_ptr),
2372 gnat_node);
2373 add_cleanup (build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr));
2374 add_stmt_list (Statements (gnat_node));
2375 gnat_poplevel ();
2377 return build2 (CATCH_EXPR, void_type_node, gnu_etypes_list,
2378 end_stmt_group ());
2381 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
2383 static void
2384 Compilation_Unit_to_gnu (Node_Id gnat_node)
2386 /* Make the decl for the elaboration procedure. */
2387 bool body_p = (Defining_Entity (Unit (gnat_node)),
2388 Nkind (Unit (gnat_node)) == N_Package_Body
2389 || Nkind (Unit (gnat_node)) == N_Subprogram_Body);
2390 Entity_Id gnat_unit_entity = Defining_Entity (Unit (gnat_node));
2391 tree gnu_elab_proc_decl
2392 = create_subprog_decl
2393 (create_concat_name (gnat_unit_entity,
2394 body_p ? "elabb" : "elabs"),
2395 NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL,
2396 gnat_unit_entity);
2397 struct elab_info *info;
2399 push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl);
2401 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
2402 allocate_struct_function (gnu_elab_proc_decl);
2403 Sloc_to_locus (Sloc (gnat_unit_entity), &cfun->function_end_locus);
2404 cfun = 0;
2406 /* For a body, first process the spec if there is one. */
2407 if (Nkind (Unit (gnat_node)) == N_Package_Body
2408 || (Nkind (Unit (gnat_node)) == N_Subprogram_Body
2409 && !Acts_As_Spec (gnat_node)))
2410 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
2412 process_inlined_subprograms (gnat_node);
2414 if (type_annotate_only)
2416 elaborate_all_entities (gnat_node);
2418 if (Nkind (Unit (gnat_node)) == N_Subprogram_Declaration
2419 || Nkind (Unit (gnat_node)) == N_Generic_Package_Declaration
2420 || Nkind (Unit (gnat_node)) == N_Generic_Subprogram_Declaration)
2421 return;
2424 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
2425 true, true);
2426 add_stmt (gnat_to_gnu (Unit (gnat_node)));
2428 /* Process any pragmas and actions following the unit. */
2429 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
2430 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
2432 /* Save away what we've made so far and record this potential elaboration
2433 procedure. */
2434 info = (struct elab_info *) ggc_alloc (sizeof (struct elab_info));
2435 set_current_block_context (gnu_elab_proc_decl);
2436 gnat_poplevel ();
2437 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
2438 info->next = elab_info_list;
2439 info->elab_proc = gnu_elab_proc_decl;
2440 info->gnat_node = gnat_node;
2441 elab_info_list = info;
2443 /* Generate elaboration code for this unit, if necessary, and say whether
2444 we did or not. */
2445 pop_stack (&gnu_elab_proc_stack);
2448 /* This function is the driver of the GNAT to GCC tree transformation
2449 process. It is the entry point of the tree transformer. GNAT_NODE is the
2450 root of some GNAT tree. Return the root of the corresponding GCC tree.
2451 If this is an expression, return the GCC equivalent of the expression. If
2452 it is a statement, return the statement. In the case when called for a
2453 statement, it may also add statements to the current statement group, in
2454 which case anything it returns is to be interpreted as occuring after
2455 anything `it already added. */
2457 tree
2458 gnat_to_gnu (Node_Id gnat_node)
2460 bool went_into_elab_proc = false;
2461 tree gnu_result = error_mark_node; /* Default to no value. */
2462 tree gnu_result_type = void_type_node;
2463 tree gnu_expr;
2464 tree gnu_lhs, gnu_rhs;
2465 Node_Id gnat_temp;
2467 /* Save node number for error message and set location information. */
2468 error_gnat_node = gnat_node;
2469 Sloc_to_locus (Sloc (gnat_node), &input_location);
2471 if (type_annotate_only
2472 && IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call))
2473 return alloc_stmt_list ();
2475 /* If this node is a non-static subexpression and we are only
2476 annotating types, make this into a NULL_EXPR. */
2477 if (type_annotate_only
2478 && IN (Nkind (gnat_node), N_Subexpr)
2479 && Nkind (gnat_node) != N_Identifier
2480 && !Compile_Time_Known_Value (gnat_node))
2481 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
2482 build_call_raise (CE_Range_Check_Failed));
2484 /* If this is a Statement and we are at top level, it must be part of
2485 the elaboration procedure, so mark us as being in that procedure
2486 and push our context. */
2487 if (!current_function_decl
2488 && ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
2489 && Nkind (gnat_node) != N_Null_Statement)
2490 || Nkind (gnat_node) == N_Procedure_Call_Statement
2491 || Nkind (gnat_node) == N_Label
2492 || Nkind (gnat_node) == N_Implicit_Label_Declaration
2493 || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
2494 || ((Nkind (gnat_node) == N_Raise_Constraint_Error
2495 || Nkind (gnat_node) == N_Raise_Storage_Error
2496 || Nkind (gnat_node) == N_Raise_Program_Error)
2497 && (Ekind (Etype (gnat_node)) == E_Void))))
2499 current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
2500 start_stmt_group ();
2501 gnat_pushlevel ();
2502 went_into_elab_proc = true;
2505 switch (Nkind (gnat_node))
2507 /********************************/
2508 /* Chapter 2: Lexical Elements: */
2509 /********************************/
2511 case N_Identifier:
2512 case N_Expanded_Name:
2513 case N_Operator_Symbol:
2514 case N_Defining_Identifier:
2515 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
2516 break;
2518 case N_Integer_Literal:
2520 tree gnu_type;
2522 /* Get the type of the result, looking inside any padding and
2523 justified modular types. Then get the value in that type. */
2524 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
2526 if (TREE_CODE (gnu_type) == RECORD_TYPE
2527 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
2528 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
2530 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
2532 /* If the result overflows (meaning it doesn't fit in its base type),
2533 abort. We would like to check that the value is within the range
2534 of the subtype, but that causes problems with subtypes whose usage
2535 will raise Constraint_Error and with biased representation, so
2536 we don't. */
2537 gcc_assert (!TREE_CONSTANT_OVERFLOW (gnu_result));
2539 break;
2541 case N_Character_Literal:
2542 /* If a Entity is present, it means that this was one of the
2543 literals in a user-defined character type. In that case,
2544 just return the value in the CONST_DECL. Otherwise, use the
2545 character code. In that case, the base type should be an
2546 INTEGER_TYPE, but we won't bother checking for that. */
2547 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2548 if (Present (Entity (gnat_node)))
2549 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
2550 else
2551 gnu_result
2552 = force_fit_type
2553 (build_int_cst
2554 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node))),
2555 false, false, false);
2556 break;
2558 case N_Real_Literal:
2559 /* If this is of a fixed-point type, the value we want is the
2560 value of the corresponding integer. */
2561 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind))
2563 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2564 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
2565 gnu_result_type);
2566 gcc_assert (!TREE_CONSTANT_OVERFLOW (gnu_result));
2569 /* We should never see a Vax_Float type literal, since the front end
2570 is supposed to transform these using appropriate conversions */
2571 else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
2572 gcc_unreachable ();
2574 else
2576 Ureal ur_realval = Realval (gnat_node);
2578 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2580 /* If the real value is zero, so is the result. Otherwise,
2581 convert it to a machine number if it isn't already. That
2582 forces BASE to 0 or 2 and simplifies the rest of our logic. */
2583 if (UR_Is_Zero (ur_realval))
2584 gnu_result = convert (gnu_result_type, integer_zero_node);
2585 else
2587 if (!Is_Machine_Number (gnat_node))
2588 ur_realval
2589 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
2590 ur_realval, Round_Even, gnat_node);
2592 gnu_result
2593 = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
2595 /* If we have a base of zero, divide by the denominator.
2596 Otherwise, the base must be 2 and we scale the value, which
2597 we know can fit in the mantissa of the type (hence the use
2598 of that type above). */
2599 if (No (Rbase (ur_realval)))
2600 gnu_result
2601 = build_binary_op (RDIV_EXPR,
2602 get_base_type (gnu_result_type),
2603 gnu_result,
2604 UI_To_gnu (Denominator (ur_realval),
2605 gnu_result_type));
2606 else
2608 REAL_VALUE_TYPE tmp;
2610 gcc_assert (Rbase (ur_realval) == 2);
2611 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
2612 - UI_To_Int (Denominator (ur_realval)));
2613 gnu_result = build_real (gnu_result_type, tmp);
2617 /* Now see if we need to negate the result. Do it this way to
2618 properly handle -0. */
2619 if (UR_Is_Negative (Realval (gnat_node)))
2620 gnu_result
2621 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
2622 gnu_result);
2625 break;
2627 case N_String_Literal:
2628 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2629 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
2631 String_Id gnat_string = Strval (gnat_node);
2632 int length = String_Length (gnat_string);
2633 char *string = (char *) alloca (length + 1);
2634 int i;
2636 /* Build the string with the characters in the literal. Note
2637 that Ada strings are 1-origin. */
2638 for (i = 0; i < length; i++)
2639 string[i] = Get_String_Char (gnat_string, i + 1);
2641 /* Put a null at the end of the string in case it's in a context
2642 where GCC will want to treat it as a C string. */
2643 string[i] = 0;
2645 gnu_result = build_string (length, string);
2647 /* Strings in GCC don't normally have types, but we want
2648 this to not be converted to the array type. */
2649 TREE_TYPE (gnu_result) = gnu_result_type;
2651 else
2653 /* Build a list consisting of each character, then make
2654 the aggregate. */
2655 String_Id gnat_string = Strval (gnat_node);
2656 int length = String_Length (gnat_string);
2657 int i;
2658 tree gnu_list = NULL_TREE;
2659 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
2661 for (i = 0; i < length; i++)
2663 gnu_list
2664 = tree_cons (gnu_idx,
2665 build_int_cst (TREE_TYPE (gnu_result_type),
2666 Get_String_Char (gnat_string,
2667 i + 1)),
2668 gnu_list);
2670 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node,
2674 gnu_result
2675 = gnat_build_constructor (gnu_result_type, nreverse (gnu_list));
2677 break;
2679 case N_Pragma:
2680 gnu_result = Pragma_to_gnu (gnat_node);
2681 break;
2683 /**************************************/
2684 /* Chapter 3: Declarations and Types: */
2685 /**************************************/
2687 case N_Subtype_Declaration:
2688 case N_Full_Type_Declaration:
2689 case N_Incomplete_Type_Declaration:
2690 case N_Private_Type_Declaration:
2691 case N_Private_Extension_Declaration:
2692 case N_Task_Type_Declaration:
2693 process_type (Defining_Entity (gnat_node));
2694 gnu_result = alloc_stmt_list ();
2695 break;
2697 case N_Object_Declaration:
2698 case N_Exception_Declaration:
2699 gnat_temp = Defining_Entity (gnat_node);
2700 gnu_result = alloc_stmt_list ();
2702 /* If we are just annotating types and this object has an unconstrained
2703 or task type, don't elaborate it. */
2704 if (type_annotate_only
2705 && (((Is_Array_Type (Etype (gnat_temp))
2706 || Is_Record_Type (Etype (gnat_temp)))
2707 && !Is_Constrained (Etype (gnat_temp)))
2708 || Is_Concurrent_Type (Etype (gnat_temp))))
2709 break;
2711 if (Present (Expression (gnat_node))
2712 && !(Nkind (gnat_node) == N_Object_Declaration
2713 && No_Initialization (gnat_node))
2714 && (!type_annotate_only
2715 || Compile_Time_Known_Value (Expression (gnat_node))))
2717 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2718 if (Do_Range_Check (Expression (gnat_node)))
2719 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp));
2721 /* If this object has its elaboration delayed, we must force
2722 evaluation of GNU_EXPR right now and save it for when the object
2723 is frozen. */
2724 if (Present (Freeze_Node (gnat_temp)))
2726 if ((Is_Public (gnat_temp) || global_bindings_p ())
2727 && !TREE_CONSTANT (gnu_expr))
2728 gnu_expr
2729 = create_var_decl (create_concat_name (gnat_temp, "init"),
2730 NULL_TREE, TREE_TYPE (gnu_expr),
2731 gnu_expr, false, Is_Public (gnat_temp),
2732 false, false, NULL, gnat_temp);
2733 else
2734 gnu_expr = maybe_variable (gnu_expr);
2736 save_gnu_tree (gnat_node, gnu_expr, true);
2739 else
2740 gnu_expr = NULL_TREE;
2742 if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK)
2743 gnu_expr = NULL_TREE;
2745 if (No (Freeze_Node (gnat_temp)))
2746 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
2747 break;
2749 case N_Object_Renaming_Declaration:
2750 gnat_temp = Defining_Entity (gnat_node);
2752 /* Don't do anything if this renaming is handled by the front end or if
2753 we are just annotating types and this object has a composite or task
2754 type, don't elaborate it. We return the result in case it has any
2755 SAVE_EXPRs in it that need to be evaluated here. */
2756 if (!Is_Renaming_Of_Object (gnat_temp)
2757 && ! (type_annotate_only
2758 && (Is_Array_Type (Etype (gnat_temp))
2759 || Is_Record_Type (Etype (gnat_temp))
2760 || Is_Concurrent_Type (Etype (gnat_temp)))))
2761 gnu_result
2762 = gnat_to_gnu_entity (gnat_temp,
2763 gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
2764 else
2765 gnu_result = alloc_stmt_list ();
2766 break;
2768 case N_Implicit_Label_Declaration:
2769 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
2770 gnu_result = alloc_stmt_list ();
2771 break;
2773 case N_Exception_Renaming_Declaration:
2774 case N_Number_Declaration:
2775 case N_Package_Renaming_Declaration:
2776 case N_Subprogram_Renaming_Declaration:
2777 /* These are fully handled in the front end. */
2778 gnu_result = alloc_stmt_list ();
2779 break;
2781 /*************************************/
2782 /* Chapter 4: Names and Expressions: */
2783 /*************************************/
2785 case N_Explicit_Dereference:
2786 gnu_result = gnat_to_gnu (Prefix (gnat_node));
2787 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2788 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
2789 break;
2791 case N_Indexed_Component:
2793 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
2794 tree gnu_type;
2795 int ndim;
2796 int i;
2797 Node_Id *gnat_expr_array;
2799 gnu_array_object = maybe_implicit_deref (gnu_array_object);
2800 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
2802 /* If we got a padded type, remove it too. */
2803 if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
2804 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
2805 gnu_array_object
2806 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
2807 gnu_array_object);
2809 gnu_result = gnu_array_object;
2811 /* First compute the number of dimensions of the array, then
2812 fill the expression array, the order depending on whether
2813 this is a Convention_Fortran array or not. */
2814 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
2815 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2816 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
2817 ndim++, gnu_type = TREE_TYPE (gnu_type))
2820 gnat_expr_array = (Node_Id *) alloca (ndim * sizeof (Node_Id));
2822 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
2823 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
2824 i >= 0;
2825 i--, gnat_temp = Next (gnat_temp))
2826 gnat_expr_array[i] = gnat_temp;
2827 else
2828 for (i = 0, gnat_temp = First (Expressions (gnat_node));
2829 i < ndim;
2830 i++, gnat_temp = Next (gnat_temp))
2831 gnat_expr_array[i] = gnat_temp;
2833 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
2834 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type))
2836 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2837 gnat_temp = gnat_expr_array[i];
2838 gnu_expr = gnat_to_gnu (gnat_temp);
2840 if (Do_Range_Check (gnat_temp))
2841 gnu_expr
2842 = emit_index_check
2843 (gnu_array_object, gnu_expr,
2844 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
2845 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
2847 gnu_result = build_binary_op (ARRAY_REF, NULL_TREE,
2848 gnu_result, gnu_expr);
2852 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2853 break;
2855 case N_Slice:
2857 tree gnu_type;
2858 Node_Id gnat_range_node = Discrete_Range (gnat_node);
2860 gnu_result = gnat_to_gnu (Prefix (gnat_node));
2861 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2863 /* Do any implicit dereferences of the prefix and do any needed
2864 range check. */
2865 gnu_result = maybe_implicit_deref (gnu_result);
2866 gnu_result = maybe_unconstrained_array (gnu_result);
2867 gnu_type = TREE_TYPE (gnu_result);
2868 if (Do_Range_Check (gnat_range_node))
2870 /* Get the bounds of the slice. */
2871 tree gnu_index_type
2872 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type));
2873 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type);
2874 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type);
2875 tree gnu_expr_l, gnu_expr_h, gnu_expr_type;
2877 /* Check to see that the minimum slice value is in range */
2878 gnu_expr_l
2879 = emit_index_check
2880 (gnu_result, gnu_min_expr,
2881 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
2882 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
2884 /* Check to see that the maximum slice value is in range */
2885 gnu_expr_h
2886 = emit_index_check
2887 (gnu_result, gnu_max_expr,
2888 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))),
2889 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))));
2891 /* Derive a good type to convert everything too */
2892 gnu_expr_type = get_base_type (TREE_TYPE (gnu_expr_l));
2894 /* Build a compound expression that does the range checks */
2895 gnu_expr
2896 = build_binary_op (COMPOUND_EXPR, gnu_expr_type,
2897 convert (gnu_expr_type, gnu_expr_h),
2898 convert (gnu_expr_type, gnu_expr_l));
2900 /* Build a conditional expression that returns the range checks
2901 expression if the slice range is not null (max >= min) or
2902 returns the min if the slice range is null */
2903 gnu_expr
2904 = fold (build3 (COND_EXPR, gnu_expr_type,
2905 build_binary_op (GE_EXPR, gnu_expr_type,
2906 convert (gnu_expr_type,
2907 gnu_max_expr),
2908 convert (gnu_expr_type,
2909 gnu_min_expr)),
2910 gnu_expr, gnu_min_expr));
2912 else
2913 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
2915 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
2916 gnu_result, gnu_expr);
2918 break;
2920 case N_Selected_Component:
2922 tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
2923 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
2924 Entity_Id gnat_pref_type = Etype (Prefix (gnat_node));
2925 tree gnu_field;
2927 while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
2928 || IN (Ekind (gnat_pref_type), Access_Kind))
2930 if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
2931 gnat_pref_type = Underlying_Type (gnat_pref_type);
2932 else if (IN (Ekind (gnat_pref_type), Access_Kind))
2933 gnat_pref_type = Designated_Type (gnat_pref_type);
2936 gnu_prefix = maybe_implicit_deref (gnu_prefix);
2938 /* For discriminant references in tagged types always substitute the
2939 corresponding discriminant as the actual selected component. */
2941 if (Is_Tagged_Type (gnat_pref_type))
2942 while (Present (Corresponding_Discriminant (gnat_field)))
2943 gnat_field = Corresponding_Discriminant (gnat_field);
2945 /* For discriminant references of untagged types always substitute the
2946 corresponding stored discriminant. */
2948 else if (Present (Corresponding_Discriminant (gnat_field)))
2949 gnat_field = Original_Record_Component (gnat_field);
2951 /* Handle extracting the real or imaginary part of a complex.
2952 The real part is the first field and the imaginary the last. */
2954 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
2955 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
2956 ? REALPART_EXPR : IMAGPART_EXPR,
2957 NULL_TREE, gnu_prefix);
2958 else
2960 gnu_field = gnat_to_gnu_field_decl (gnat_field);
2962 /* If there are discriminants, the prefix might be
2963 evaluated more than once, which is a problem if it has
2964 side-effects. */
2965 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node)))
2966 ? Designated_Type (Etype
2967 (Prefix (gnat_node)))
2968 : Etype (Prefix (gnat_node))))
2969 gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
2971 gnu_result
2972 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
2973 (Nkind (Parent (gnat_node))
2974 == N_Attribute_Reference));
2977 gcc_assert (gnu_result);
2978 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2980 break;
2982 case N_Attribute_Reference:
2984 /* The attribute designator (like an enumeration value). */
2985 int attribute = Get_Attribute_Id (Attribute_Name (gnat_node));
2987 /* The Elab_Spec and Elab_Body attributes are special in that
2988 Prefix is a unit, not an object with a GCC equivalent. Similarly
2989 for Elaborated, since that variable isn't otherwise known. */
2990 if (attribute == Attr_Elab_Body || attribute == Attr_Elab_Spec)
2991 return (create_subprog_decl
2992 (create_concat_name (Entity (Prefix (gnat_node)),
2993 attribute == Attr_Elab_Body
2994 ? "elabb" : "elabs"),
2995 NULL_TREE, void_ftype, NULL_TREE, false, true, true, NULL,
2996 gnat_node));
2998 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attribute);
3000 break;
3002 case N_Reference:
3003 /* Like 'Access as far as we are concerned. */
3004 gnu_result = gnat_to_gnu (Prefix (gnat_node));
3005 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
3006 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3007 break;
3009 case N_Aggregate:
3010 case N_Extension_Aggregate:
3012 tree gnu_aggr_type;
3014 /* ??? It is wrong to evaluate the type now, but there doesn't
3015 seem to be any other practical way of doing it. */
3017 gcc_assert (!Expansion_Delayed (gnat_node));
3019 gnu_aggr_type = gnu_result_type
3020 = get_unpadded_type (Etype (gnat_node));
3022 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
3023 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
3024 gnu_aggr_type
3025 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type)));
3027 if (Null_Record_Present (gnat_node))
3028 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE);
3030 else if (TREE_CODE (gnu_aggr_type) == UNION_TYPE
3031 && TYPE_UNCHECKED_UNION_P (gnu_aggr_type))
3033 /* The first element is the discrimant, which we ignore. The
3034 next is the field we're building. Convert the expression
3035 to the type of the field and then to the union type. */
3036 Node_Id gnat_assoc
3037 = Next (First (Component_Associations (gnat_node)));
3038 Entity_Id gnat_field = Entity (First (Choices (gnat_assoc)));
3039 tree gnu_field_type
3040 = TREE_TYPE (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0));
3042 gnu_result = convert (gnu_field_type,
3043 gnat_to_gnu (Expression (gnat_assoc)));
3045 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
3046 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
3047 gnu_result
3048 = assoc_to_constructor (First (Component_Associations (gnat_node)),
3049 gnu_aggr_type);
3050 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
3051 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
3052 gnu_aggr_type,
3053 Component_Type (Etype (gnat_node)));
3054 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
3055 gnu_result
3056 = build_binary_op
3057 (COMPLEX_EXPR, gnu_aggr_type,
3058 gnat_to_gnu (Expression (First
3059 (Component_Associations (gnat_node)))),
3060 gnat_to_gnu (Expression
3061 (Next
3062 (First (Component_Associations (gnat_node))))));
3063 else
3064 gcc_unreachable ();
3066 gnu_result = convert (gnu_result_type, gnu_result);
3068 break;
3070 case N_Null:
3071 gnu_result = null_pointer_node;
3072 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3073 break;
3075 case N_Type_Conversion:
3076 case N_Qualified_Expression:
3077 /* Get the operand expression. */
3078 gnu_result = gnat_to_gnu (Expression (gnat_node));
3079 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3081 gnu_result
3082 = convert_with_check (Etype (gnat_node), gnu_result,
3083 Do_Overflow_Check (gnat_node),
3084 Do_Range_Check (Expression (gnat_node)),
3085 Nkind (gnat_node) == N_Type_Conversion
3086 && Float_Truncate (gnat_node));
3087 break;
3089 case N_Unchecked_Type_Conversion:
3090 gnu_result = gnat_to_gnu (Expression (gnat_node));
3091 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3093 /* If the result is a pointer type, see if we are improperly
3094 converting to a stricter alignment. */
3096 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
3097 && IN (Ekind (Etype (gnat_node)), Access_Kind))
3099 unsigned int align = known_alignment (gnu_result);
3100 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
3101 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
3103 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
3104 post_error_ne_tree_2
3105 ("?source alignment (^) < alignment of & (^)",
3106 gnat_node, Designated_Type (Etype (gnat_node)),
3107 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
3110 gnu_result = unchecked_convert (gnu_result_type, gnu_result,
3111 No_Truncation (gnat_node));
3112 break;
3114 case N_In:
3115 case N_Not_In:
3117 tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node));
3118 Node_Id gnat_range = Right_Opnd (gnat_node);
3119 tree gnu_low;
3120 tree gnu_high;
3122 /* GNAT_RANGE is either an N_Range node or an identifier
3123 denoting a subtype. */
3124 if (Nkind (gnat_range) == N_Range)
3126 gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
3127 gnu_high = gnat_to_gnu (High_Bound (gnat_range));
3129 else if (Nkind (gnat_range) == N_Identifier
3130 || Nkind (gnat_range) == N_Expanded_Name)
3132 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
3134 gnu_low = TYPE_MIN_VALUE (gnu_range_type);
3135 gnu_high = TYPE_MAX_VALUE (gnu_range_type);
3137 else
3138 gcc_unreachable ();
3140 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3142 /* If LOW and HIGH are identical, perform an equality test.
3143 Otherwise, ensure that GNU_OBJECT is only evaluated once
3144 and perform a full range test. */
3145 if (operand_equal_p (gnu_low, gnu_high, 0))
3146 gnu_result = build_binary_op (EQ_EXPR, gnu_result_type,
3147 gnu_object, gnu_low);
3148 else
3150 gnu_object = protect_multiple_eval (gnu_object);
3151 gnu_result
3152 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type,
3153 build_binary_op (GE_EXPR, gnu_result_type,
3154 gnu_object, gnu_low),
3155 build_binary_op (LE_EXPR, gnu_result_type,
3156 gnu_object, gnu_high));
3159 if (Nkind (gnat_node) == N_Not_In)
3160 gnu_result = invert_truthvalue (gnu_result);
3162 break;
3164 case N_Op_Divide:
3165 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3166 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3167 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3168 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
3169 ? RDIV_EXPR
3170 : (Rounded_Result (gnat_node)
3171 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
3172 gnu_result_type, gnu_lhs, gnu_rhs);
3173 break;
3175 case N_Op_Or: case N_Op_And: case N_Op_Xor:
3176 /* These can either be operations on booleans or on modular types.
3177 Fall through for boolean types since that's the way GNU_CODES is
3178 set up. */
3179 if (IN (Ekind (Underlying_Type (Etype (gnat_node))),
3180 Modular_Integer_Kind))
3182 enum tree_code code
3183 = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR
3184 : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR
3185 : BIT_XOR_EXPR);
3187 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3188 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3189 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3190 gnu_result = build_binary_op (code, gnu_result_type,
3191 gnu_lhs, gnu_rhs);
3192 break;
3195 /* ... fall through ... */
3197 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt:
3198 case N_Op_Le: case N_Op_Gt: case N_Op_Ge:
3199 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply:
3200 case N_Op_Mod: case N_Op_Rem:
3201 case N_Op_Rotate_Left:
3202 case N_Op_Rotate_Right:
3203 case N_Op_Shift_Left:
3204 case N_Op_Shift_Right:
3205 case N_Op_Shift_Right_Arithmetic:
3206 case N_And_Then: case N_Or_Else:
3208 enum tree_code code = gnu_codes[Nkind (gnat_node)];
3209 tree gnu_type;
3211 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
3212 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
3213 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
3215 /* If this is a comparison operator, convert any references to
3216 an unconstrained array value into a reference to the
3217 actual array. */
3218 if (TREE_CODE_CLASS (code) == tcc_comparison)
3220 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
3221 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
3224 /* If the result type is a private type, its full view may be a
3225 numeric subtype. The representation we need is that of its base
3226 type, given that it is the result of an arithmetic operation. */
3227 else if (Is_Private_Type (Etype (gnat_node)))
3228 gnu_type = gnu_result_type
3229 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
3231 /* If this is a shift whose count is not guaranteed to be correct,
3232 we need to adjust the shift count. */
3233 if (IN (Nkind (gnat_node), N_Op_Shift)
3234 && !Shift_Count_OK (gnat_node))
3236 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs));
3237 tree gnu_max_shift
3238 = convert (gnu_count_type, TYPE_SIZE (gnu_type));
3240 if (Nkind (gnat_node) == N_Op_Rotate_Left
3241 || Nkind (gnat_node) == N_Op_Rotate_Right)
3242 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type,
3243 gnu_rhs, gnu_max_shift);
3244 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic)
3245 gnu_rhs
3246 = build_binary_op
3247 (MIN_EXPR, gnu_count_type,
3248 build_binary_op (MINUS_EXPR,
3249 gnu_count_type,
3250 gnu_max_shift,
3251 convert (gnu_count_type,
3252 integer_one_node)),
3253 gnu_rhs);
3256 /* For right shifts, the type says what kind of shift to do,
3257 so we may need to choose a different type. */
3258 if (Nkind (gnat_node) == N_Op_Shift_Right
3259 && !TYPE_UNSIGNED (gnu_type))
3260 gnu_type = gnat_unsigned_type (gnu_type);
3261 else if (Nkind (gnat_node) == N_Op_Shift_Right_Arithmetic
3262 && TYPE_UNSIGNED (gnu_type))
3263 gnu_type = gnat_signed_type (gnu_type);
3265 if (gnu_type != gnu_result_type)
3267 gnu_lhs = convert (gnu_type, gnu_lhs);
3268 gnu_rhs = convert (gnu_type, gnu_rhs);
3271 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
3273 /* If this is a logical shift with the shift count not verified,
3274 we must return zero if it is too large. We cannot compensate
3275 above in this case. */
3276 if ((Nkind (gnat_node) == N_Op_Shift_Left
3277 || Nkind (gnat_node) == N_Op_Shift_Right)
3278 && !Shift_Count_OK (gnat_node))
3279 gnu_result
3280 = build_cond_expr
3281 (gnu_type,
3282 build_binary_op (GE_EXPR, integer_type_node,
3283 gnu_rhs,
3284 convert (TREE_TYPE (gnu_rhs),
3285 TYPE_SIZE (gnu_type))),
3286 convert (gnu_type, integer_zero_node),
3287 gnu_result);
3289 break;
3291 case N_Conditional_Expression:
3293 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
3294 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
3295 tree gnu_false
3296 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
3298 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3299 gnu_result = build_cond_expr (gnu_result_type,
3300 gnat_truthvalue_conversion (gnu_cond),
3301 gnu_true, gnu_false);
3303 break;
3305 case N_Op_Plus:
3306 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
3307 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3308 break;
3310 case N_Op_Not:
3311 /* This case can apply to a boolean or a modular type.
3312 Fall through for a boolean operand since GNU_CODES is set
3313 up to handle this. */
3314 if (IN (Ekind (Etype (gnat_node)), Modular_Integer_Kind))
3316 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3317 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3318 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
3319 gnu_expr);
3320 break;
3323 /* ... fall through ... */
3325 case N_Op_Minus: case N_Op_Abs:
3326 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
3328 if (Ekind (Etype (gnat_node)) != E_Private_Type)
3329 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3330 else
3331 gnu_result_type = get_unpadded_type (Base_Type
3332 (Full_View (Etype (gnat_node))));
3334 gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
3335 gnu_result_type, gnu_expr);
3336 break;
3338 case N_Allocator:
3340 tree gnu_init = 0;
3341 tree gnu_type;
3343 gnat_temp = Expression (gnat_node);
3345 /* The Expression operand can either be an N_Identifier or
3346 Expanded_Name, which must represent a type, or a
3347 N_Qualified_Expression, which contains both the object type and an
3348 initial value for the object. */
3349 if (Nkind (gnat_temp) == N_Identifier
3350 || Nkind (gnat_temp) == N_Expanded_Name)
3351 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
3352 else if (Nkind (gnat_temp) == N_Qualified_Expression)
3354 Entity_Id gnat_desig_type
3355 = Designated_Type (Underlying_Type (Etype (gnat_node)));
3357 gnu_init = gnat_to_gnu (Expression (gnat_temp));
3359 gnu_init = maybe_unconstrained_array (gnu_init);
3360 if (Do_Range_Check (Expression (gnat_temp)))
3361 gnu_init = emit_range_check (gnu_init, gnat_desig_type);
3363 if (Is_Elementary_Type (gnat_desig_type)
3364 || Is_Constrained (gnat_desig_type))
3366 gnu_type = gnat_to_gnu_type (gnat_desig_type);
3367 gnu_init = convert (gnu_type, gnu_init);
3369 else
3371 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
3372 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
3373 gnu_type = TREE_TYPE (gnu_init);
3375 gnu_init = convert (gnu_type, gnu_init);
3378 else
3379 gcc_unreachable ();
3381 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3382 return build_allocator (gnu_type, gnu_init, gnu_result_type,
3383 Procedure_To_Call (gnat_node),
3384 Storage_Pool (gnat_node), gnat_node);
3386 break;
3388 /***************************/
3389 /* Chapter 5: Statements: */
3390 /***************************/
3392 case N_Label:
3393 gnu_result = build1 (LABEL_EXPR, void_type_node,
3394 gnat_to_gnu (Identifier (gnat_node)));
3395 break;
3397 case N_Null_Statement:
3398 gnu_result = alloc_stmt_list ();
3399 break;
3401 case N_Assignment_Statement:
3402 /* Get the LHS and RHS of the statement and convert any reference to an
3403 unconstrained array into a reference to the underlying array.
3404 If we are not to do range checking and the RHS is an N_Function_Call,
3405 pass the LHS to the call function. */
3406 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
3408 /* If the type has a size that overflows, convert this into raise of
3409 Storage_Error: execution shouldn't have gotten here anyway. */
3410 if (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs))) == INTEGER_CST
3411 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs))))
3412 gnu_result = build_call_raise (SE_Object_Too_Large);
3413 else if (Nkind (Expression (gnat_node)) == N_Function_Call
3414 && !Do_Range_Check (Expression (gnat_node)))
3415 gnu_result = call_to_gnu (Expression (gnat_node),
3416 &gnu_result_type, gnu_lhs);
3417 else
3419 gnu_rhs
3420 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node)));
3422 /* If range check is needed, emit code to generate it */
3423 if (Do_Range_Check (Expression (gnat_node)))
3424 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)));
3426 gnu_result
3427 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
3429 break;
3431 case N_If_Statement:
3433 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
3435 /* Make the outer COND_EXPR. Avoid non-determinism. */
3436 gnu_result = build3 (COND_EXPR, void_type_node,
3437 gnat_to_gnu (Condition (gnat_node)),
3438 NULL_TREE, NULL_TREE);
3439 COND_EXPR_THEN (gnu_result)
3440 = build_stmt_group (Then_Statements (gnat_node), false);
3441 TREE_SIDE_EFFECTS (gnu_result) = 1;
3442 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
3444 /* Now make a COND_EXPR for each of the "else if" parts. Put each
3445 into the previous "else" part and point to where to put any
3446 outer "else". Also avoid non-determinism. */
3447 if (Present (Elsif_Parts (gnat_node)))
3448 for (gnat_temp = First (Elsif_Parts (gnat_node));
3449 Present (gnat_temp); gnat_temp = Next (gnat_temp))
3451 gnu_expr = build3 (COND_EXPR, void_type_node,
3452 gnat_to_gnu (Condition (gnat_temp)),
3453 NULL_TREE, NULL_TREE);
3454 COND_EXPR_THEN (gnu_expr)
3455 = build_stmt_group (Then_Statements (gnat_temp), false);
3456 TREE_SIDE_EFFECTS (gnu_expr) = 1;
3457 annotate_with_node (gnu_expr, gnat_temp);
3458 *gnu_else_ptr = gnu_expr;
3459 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
3462 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
3464 break;
3466 case N_Case_Statement:
3467 gnu_result = Case_Statement_to_gnu (gnat_node);
3468 break;
3470 case N_Loop_Statement:
3471 gnu_result = Loop_Statement_to_gnu (gnat_node);
3472 break;
3474 case N_Block_Statement:
3475 start_stmt_group ();
3476 gnat_pushlevel ();
3477 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3478 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3479 gnat_poplevel ();
3480 gnu_result = end_stmt_group ();
3482 if (Present (Identifier (gnat_node)))
3483 mark_out_of_scope (Entity (Identifier (gnat_node)));
3484 break;
3486 case N_Exit_Statement:
3487 gnu_result
3488 = build2 (EXIT_STMT, void_type_node,
3489 (Present (Condition (gnat_node))
3490 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
3491 (Present (Name (gnat_node))
3492 ? get_gnu_tree (Entity (Name (gnat_node)))
3493 : TREE_VALUE (gnu_loop_label_stack)));
3494 break;
3496 case N_Return_Statement:
3498 /* The gnu function type of the subprogram currently processed. */
3499 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
3500 /* The return value from the subprogram. */
3501 tree gnu_ret_val = NULL_TREE;
3502 /* The place to put the return value. */
3503 tree gnu_lhs;
3505 /* If we are dealing with a "return;" from an Ada procedure with
3506 parameters passed by copy in copy out, we need to return a record
3507 containing the final values of these parameters. If the list
3508 contains only one entry, return just that entry.
3510 For a full description of the copy in copy out parameter mechanism,
3511 see the part of the gnat_to_gnu_entity routine dealing with the
3512 translation of subprograms.
3514 But if we have a return label defined, convert this into
3515 a branch to that label. */
3517 if (TREE_VALUE (gnu_return_label_stack))
3519 gnu_result = build1 (GOTO_EXPR, void_type_node,
3520 TREE_VALUE (gnu_return_label_stack));
3521 break;
3524 else if (TYPE_CI_CO_LIST (gnu_subprog_type))
3526 gnu_lhs = DECL_RESULT (current_function_decl);
3527 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1)
3528 gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type));
3529 else
3530 gnu_ret_val
3531 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type),
3532 TYPE_CI_CO_LIST (gnu_subprog_type));
3535 /* If the Ada subprogram is a function, we just need to return the
3536 expression. If the subprogram returns an unconstrained
3537 array, we have to allocate a new version of the result and
3538 return it. If we return by reference, return a pointer. */
3540 else if (Present (Expression (gnat_node)))
3542 /* If the current function returns by target pointer and we
3543 are doing a call, pass that target to the call. */
3544 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type)
3545 && Nkind (Expression (gnat_node)) == N_Function_Call)
3547 gnu_lhs
3548 = build_unary_op (INDIRECT_REF, NULL_TREE,
3549 DECL_ARGUMENTS (current_function_decl));
3550 gnu_result = call_to_gnu (Expression (gnat_node),
3551 &gnu_result_type, gnu_lhs);
3553 else
3555 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
3557 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
3558 /* The original return type was unconstrained so dereference
3559 the TARGET pointer in the return value's type. */
3560 gnu_lhs
3561 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
3562 DECL_ARGUMENTS (current_function_decl));
3563 else
3564 gnu_lhs = DECL_RESULT (current_function_decl);
3566 /* Do not remove the padding from GNU_RET_VAL if the inner
3567 type is self-referential since we want to allocate the fixed
3568 size in that case. */
3569 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
3570 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
3571 == RECORD_TYPE)
3572 && (TYPE_IS_PADDING_P
3573 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
3574 && (CONTAINS_PLACEHOLDER_P
3575 (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
3576 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
3578 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
3579 || By_Ref (gnat_node))
3580 gnu_ret_val
3581 = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
3583 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type))
3585 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
3587 /* We have two cases: either the function returns with
3588 depressed stack or not. If not, we allocate on the
3589 secondary stack. If so, we allocate in the stack frame.
3590 if no copy is needed, the front end will set By_Ref,
3591 which we handle in the case above. */
3592 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
3593 gnu_ret_val
3594 = build_allocator (TREE_TYPE (gnu_ret_val),
3595 gnu_ret_val,
3596 TREE_TYPE (gnu_subprog_type),
3597 0, -1, gnat_node);
3598 else
3599 gnu_ret_val
3600 = build_allocator (TREE_TYPE (gnu_ret_val),
3601 gnu_ret_val,
3602 TREE_TYPE (gnu_subprog_type),
3603 Procedure_To_Call (gnat_node),
3604 Storage_Pool (gnat_node),
3605 gnat_node);
3609 else
3610 /* If the Ada subprogram is a regular procedure, just return. */
3611 gnu_lhs = NULL_TREE;
3613 if (TYPE_RETURNS_BY_TARGET_PTR_P (gnu_subprog_type))
3615 if (gnu_ret_val)
3616 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
3617 gnu_lhs, gnu_ret_val);
3618 add_stmt_with_node (gnu_result, gnat_node);
3619 gnu_lhs = NULL_TREE;
3622 gnu_result = build_return_expr (gnu_lhs, gnu_ret_val);
3624 break;
3626 case N_Goto_Statement:
3627 gnu_result = build1 (GOTO_EXPR, void_type_node,
3628 gnat_to_gnu (Name (gnat_node)));
3629 break;
3631 /****************************/
3632 /* Chapter 6: Subprograms: */
3633 /****************************/
3635 case N_Subprogram_Declaration:
3636 /* Unless there is a freeze node, declare the subprogram. We consider
3637 this a "definition" even though we're not generating code for
3638 the subprogram because we will be making the corresponding GCC
3639 node here. */
3641 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
3642 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
3643 NULL_TREE, 1);
3644 gnu_result = alloc_stmt_list ();
3645 break;
3647 case N_Abstract_Subprogram_Declaration:
3648 /* This subprogram doesn't exist for code generation purposes, but we
3649 have to elaborate the types of any parameters, unless they are
3650 imported types (nothing to generate in this case). */
3651 for (gnat_temp
3652 = First_Formal (Defining_Entity (Specification (gnat_node)));
3653 Present (gnat_temp);
3654 gnat_temp = Next_Formal_With_Extras (gnat_temp))
3655 if (Is_Itype (Etype (gnat_temp))
3656 && !From_With_Type (Etype (gnat_temp)))
3657 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
3659 gnu_result = alloc_stmt_list ();
3660 break;
3662 case N_Defining_Program_Unit_Name:
3663 /* For a child unit identifier go up a level to get the
3664 specificaton. We get this when we try to find the spec of
3665 a child unit package that is the compilation unit being compiled. */
3666 gnu_result = gnat_to_gnu (Parent (gnat_node));
3667 break;
3669 case N_Subprogram_Body:
3670 Subprogram_Body_to_gnu (gnat_node);
3671 gnu_result = alloc_stmt_list ();
3672 break;
3674 case N_Function_Call:
3675 case N_Procedure_Call_Statement:
3676 gnu_result = call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE);
3677 break;
3679 /*************************/
3680 /* Chapter 7: Packages: */
3681 /*************************/
3683 case N_Package_Declaration:
3684 gnu_result = gnat_to_gnu (Specification (gnat_node));
3685 break;
3687 case N_Package_Specification:
3689 start_stmt_group ();
3690 process_decls (Visible_Declarations (gnat_node),
3691 Private_Declarations (gnat_node), Empty, true, true);
3692 gnu_result = end_stmt_group ();
3693 break;
3695 case N_Package_Body:
3697 /* If this is the body of a generic package - do nothing */
3698 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
3700 gnu_result = alloc_stmt_list ();
3701 break;
3704 start_stmt_group ();
3705 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3707 if (Present (Handled_Statement_Sequence (gnat_node)))
3708 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3710 gnu_result = end_stmt_group ();
3711 break;
3713 /*********************************/
3714 /* Chapter 8: Visibility Rules: */
3715 /*********************************/
3717 case N_Use_Package_Clause:
3718 case N_Use_Type_Clause:
3719 /* Nothing to do here - but these may appear in list of declarations */
3720 gnu_result = alloc_stmt_list ();
3721 break;
3723 /***********************/
3724 /* Chapter 9: Tasks: */
3725 /***********************/
3727 case N_Protected_Type_Declaration:
3728 gnu_result = alloc_stmt_list ();
3729 break;
3731 case N_Single_Task_Declaration:
3732 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
3733 gnu_result = alloc_stmt_list ();
3734 break;
3736 /***********************************************************/
3737 /* Chapter 10: Program Structure and Compilation Issues: */
3738 /***********************************************************/
3740 case N_Compilation_Unit:
3742 /* This is not called for the main unit, which is handled in function
3743 gigi above. */
3744 start_stmt_group ();
3745 gnat_pushlevel ();
3747 Compilation_Unit_to_gnu (gnat_node);
3748 gnu_result = alloc_stmt_list ();
3749 break;
3751 case N_Subprogram_Body_Stub:
3752 case N_Package_Body_Stub:
3753 case N_Protected_Body_Stub:
3754 case N_Task_Body_Stub:
3755 /* Simply process whatever unit is being inserted. */
3756 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
3757 break;
3759 case N_Subunit:
3760 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
3761 break;
3763 /***************************/
3764 /* Chapter 11: Exceptions: */
3765 /***************************/
3767 case N_Handled_Sequence_Of_Statements:
3768 /* If there is an At_End procedure attached to this node, and the EH
3769 mechanism is SJLJ, we must have at least a corresponding At_End
3770 handler, unless the No_Exception_Handlers restriction is set. */
3771 gcc_assert (type_annotate_only
3772 || Exception_Mechanism != Setjmp_Longjmp
3773 || No (At_End_Proc (gnat_node))
3774 || Present (Exception_Handlers (gnat_node))
3775 || No_Exception_Handlers_Set ());
3777 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
3778 break;
3780 case N_Exception_Handler:
3781 if (Exception_Mechanism == Setjmp_Longjmp)
3782 gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node);
3783 else if (Exception_Mechanism == GCC_ZCX)
3784 gnu_result = Exception_Handler_to_gnu_zcx (gnat_node);
3785 else
3786 gcc_unreachable ();
3788 break;
3790 /*******************************/
3791 /* Chapter 12: Generic Units: */
3792 /*******************************/
3794 case N_Generic_Function_Renaming_Declaration:
3795 case N_Generic_Package_Renaming_Declaration:
3796 case N_Generic_Procedure_Renaming_Declaration:
3797 case N_Generic_Package_Declaration:
3798 case N_Generic_Subprogram_Declaration:
3799 case N_Package_Instantiation:
3800 case N_Procedure_Instantiation:
3801 case N_Function_Instantiation:
3802 /* These nodes can appear on a declaration list but there is nothing to
3803 to be done with them. */
3804 gnu_result = alloc_stmt_list ();
3805 break;
3807 /***************************************************/
3808 /* Chapter 13: Representation Clauses and */
3809 /* Implementation-Dependent Features: */
3810 /***************************************************/
3812 case N_Attribute_Definition_Clause:
3814 gnu_result = alloc_stmt_list ();
3816 /* The only one we need deal with is for 'Address. For the others, SEM
3817 puts the information elsewhere. We need only deal with 'Address
3818 if the object has a Freeze_Node (which it never will currently). */
3819 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address
3820 || No (Freeze_Node (Entity (Name (gnat_node)))))
3821 break;
3823 /* Get the value to use as the address and save it as the
3824 equivalent for GNAT_TEMP. When the object is frozen,
3825 gnat_to_gnu_entity will do the right thing. */
3826 save_gnu_tree (Entity (Name (gnat_node)),
3827 gnat_to_gnu (Expression (gnat_node)), true);
3828 break;
3830 case N_Enumeration_Representation_Clause:
3831 case N_Record_Representation_Clause:
3832 case N_At_Clause:
3833 /* We do nothing with these. SEM puts the information elsewhere. */
3834 gnu_result = alloc_stmt_list ();
3835 break;
3837 case N_Code_Statement:
3838 if (!type_annotate_only)
3840 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
3841 tree gnu_input_list = NULL_TREE, gnu_output_list = NULL_TREE;
3842 tree gnu_clobber_list = NULL_TREE;
3843 char *clobber;
3845 /* First process inputs, then outputs, then clobbers. */
3846 Setup_Asm_Inputs (gnat_node);
3847 while (Present (gnat_temp = Asm_Input_Value ()))
3849 tree gnu_value = gnat_to_gnu (gnat_temp);
3850 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3851 (Asm_Input_Constraint ()));
3853 gnu_input_list
3854 = tree_cons (gnu_constr, gnu_value, gnu_input_list);
3855 Next_Asm_Input ();
3858 Setup_Asm_Outputs (gnat_node);
3859 while (Present (gnat_temp = Asm_Output_Variable ()))
3861 tree gnu_value = gnat_to_gnu (gnat_temp);
3862 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
3863 (Asm_Output_Constraint ()));
3865 gnu_output_list
3866 = tree_cons (gnu_constr, gnu_value, gnu_output_list);
3867 Next_Asm_Output ();
3870 Clobber_Setup (gnat_node);
3871 while ((clobber = Clobber_Get_Next ()))
3872 gnu_clobber_list
3873 = tree_cons (NULL_TREE,
3874 build_string (strlen (clobber) + 1, clobber),
3875 gnu_clobber_list);
3877 gnu_input_list = nreverse (gnu_input_list);
3878 gnu_output_list = nreverse (gnu_output_list);
3879 gnu_result = build4 (ASM_EXPR, void_type_node,
3880 gnu_template, gnu_output_list,
3881 gnu_input_list, gnu_clobber_list);
3882 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
3884 else
3885 gnu_result = alloc_stmt_list ();
3887 break;
3889 /***************************************************/
3890 /* Added Nodes */
3891 /***************************************************/
3893 case N_Freeze_Entity:
3894 start_stmt_group ();
3895 process_freeze_entity (gnat_node);
3896 process_decls (Actions (gnat_node), Empty, Empty, true, true);
3897 gnu_result = end_stmt_group ();
3898 break;
3900 case N_Itype_Reference:
3901 if (!present_gnu_tree (Itype (gnat_node)))
3902 process_type (Itype (gnat_node));
3904 gnu_result = alloc_stmt_list ();
3905 break;
3907 case N_Free_Statement:
3908 if (!type_annotate_only)
3910 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
3911 tree gnu_obj_type;
3912 tree gnu_obj_size;
3913 int align;
3915 /* If this is a thin pointer, we must dereference it to create
3916 a fat pointer, then go back below to a thin pointer. The
3917 reason for this is that we need a fat pointer someplace in
3918 order to properly compute the size. */
3919 if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
3920 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
3921 build_unary_op (INDIRECT_REF, NULL_TREE,
3922 gnu_ptr));
3924 /* If this is an unconstrained array, we know the object must
3925 have been allocated with the template in front of the object.
3926 So pass the template address, but get the total size. Do this
3927 by converting to a thin pointer. */
3928 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
3929 gnu_ptr
3930 = convert (build_pointer_type
3931 (TYPE_OBJECT_RECORD_TYPE
3932 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
3933 gnu_ptr);
3935 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
3936 gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
3937 align = TYPE_ALIGN (gnu_obj_type);
3939 if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
3940 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
3942 tree gnu_char_ptr_type = build_pointer_type (char_type_node);
3943 tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
3944 tree gnu_byte_offset
3945 = convert (gnu_char_ptr_type,
3946 size_diffop (size_zero_node, gnu_pos));
3948 gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
3949 gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
3950 gnu_ptr, gnu_byte_offset);
3953 gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
3954 Procedure_To_Call (gnat_node),
3955 Storage_Pool (gnat_node),
3956 gnat_node);
3958 break;
3960 case N_Raise_Constraint_Error:
3961 case N_Raise_Program_Error:
3962 case N_Raise_Storage_Error:
3963 if (type_annotate_only)
3965 gnu_result = alloc_stmt_list ();
3966 break;
3969 gnu_result_type = get_unpadded_type (Etype (gnat_node));
3970 gnu_result = build_call_raise (UI_To_Int (Reason (gnat_node)));
3972 /* If the type is VOID, this is a statement, so we need to
3973 generate the code for the call. Handle a Condition, if there
3974 is one. */
3975 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
3977 annotate_with_node (gnu_result, gnat_node);
3979 if (Present (Condition (gnat_node)))
3980 gnu_result = build3 (COND_EXPR, void_type_node,
3981 gnat_to_gnu (Condition (gnat_node)),
3982 gnu_result, alloc_stmt_list ());
3984 else
3985 gnu_result = build1 (NULL_EXPR, gnu_result_type, gnu_result);
3986 break;
3988 case N_Validate_Unchecked_Conversion:
3989 /* If the result is a pointer type, see if we are either converting
3990 from a non-pointer or from a pointer to a type with a different
3991 alias set and warn if so. If the result defined in the same unit as
3992 this unchecked convertion, we can allow this because we can know to
3993 make that type have alias set 0. */
3995 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
3996 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
3998 if (POINTER_TYPE_P (gnu_target_type)
3999 && !In_Same_Source_Unit (Target_Type (gnat_node), gnat_node)
4000 && get_alias_set (TREE_TYPE (gnu_target_type)) != 0
4001 && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node)))
4002 && (!POINTER_TYPE_P (gnu_source_type)
4003 || (get_alias_set (TREE_TYPE (gnu_source_type))
4004 != get_alias_set (TREE_TYPE (gnu_target_type)))))
4006 post_error_ne
4007 ("?possible aliasing problem for type&",
4008 gnat_node, Target_Type (gnat_node));
4009 post_error
4010 ("\\?use -fno-strict-aliasing switch for references",
4011 gnat_node);
4012 post_error_ne
4013 ("\\?or use `pragma No_Strict_Aliasing (&);`",
4014 gnat_node, Target_Type (gnat_node));
4017 gnu_result = alloc_stmt_list ();
4018 break;
4020 case N_Raise_Statement:
4021 case N_Function_Specification:
4022 case N_Procedure_Specification:
4023 case N_Op_Concat:
4024 case N_Component_Association:
4025 case N_Task_Body:
4026 default:
4027 gcc_assert (type_annotate_only);
4028 gnu_result = alloc_stmt_list ();
4031 /* If we pushed our level as part of processing the elaboration routine,
4032 pop it back now. */
4033 if (went_into_elab_proc)
4035 add_stmt (gnu_result);
4036 gnat_poplevel ();
4037 gnu_result = end_stmt_group ();
4038 current_function_decl = NULL_TREE;
4041 /* Set the location information into the result. Note that we may have
4042 no result if we just expanded a procedure with no side-effects. */
4043 if (gnu_result && EXPR_P (gnu_result))
4044 annotate_with_node (gnu_result, gnat_node);
4046 /* If we're supposed to return something of void_type, it means we have
4047 something we're elaborating for effect, so just return. */
4048 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
4049 return gnu_result;
4051 /* If the result is a constant that overflows, raise constraint error. */
4052 else if (TREE_CODE (gnu_result) == INTEGER_CST
4053 && TREE_CONSTANT_OVERFLOW (gnu_result))
4055 post_error ("Constraint_Error will be raised at run-time?", gnat_node);
4057 gnu_result
4058 = build1 (NULL_EXPR, gnu_result_type,
4059 build_call_raise (CE_Overflow_Check_Failed));
4062 /* If our result has side-effects and is of an unconstrained type,
4063 make a SAVE_EXPR so that we can be sure it will only be referenced
4064 once. Note we must do this before any conversions. */
4065 if (TREE_SIDE_EFFECTS (gnu_result)
4066 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
4067 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
4068 gnu_result = gnat_stabilize_reference (gnu_result, 0);
4070 /* Now convert the result to the proper type. If the type is void or if
4071 we have no result, return error_mark_node to show we have no result.
4072 If the type of the result is correct or if we have a label (which doesn't
4073 have any well-defined type), return our result. Also don't do the
4074 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4075 since those are the cases where the front end may have the type wrong due
4076 to "instantiating" the unconstrained record with discriminant values
4077 or if this is a FIELD_DECL. If this is the Name of an assignment
4078 statement or a parameter of a procedure call, return what we have since
4079 the RHS has to be converted to our type there in that case, unless
4080 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
4081 record types with the same name, the expression type has integral mode,
4082 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
4083 we are converting from a packable type to its actual type and we need
4084 those conversions to be NOPs in order for assignments into these types to
4085 work properly if the inner object is a bitfield and hence can't have
4086 its address taken. Finally, don't convert integral types that are the
4087 operand of an unchecked conversion since we need to ignore those
4088 conversions (for 'Valid). Otherwise, convert the result to the proper
4089 type. */
4091 if (Present (Parent (gnat_node))
4092 && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement
4093 && Name (Parent (gnat_node)) == gnat_node)
4094 || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement
4095 && Name (Parent (gnat_node)) != gnat_node)
4096 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
4097 && !AGGREGATE_TYPE_P (gnu_result_type)
4098 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4099 || Nkind (Parent (gnat_node)) == N_Parameter_Association)
4100 && !(TYPE_SIZE (gnu_result_type)
4101 && TYPE_SIZE (TREE_TYPE (gnu_result))
4102 && (AGGREGATE_TYPE_P (gnu_result_type)
4103 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
4104 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
4105 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
4106 != INTEGER_CST))
4107 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4108 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
4109 && (CONTAINS_PLACEHOLDER_P
4110 (TYPE_SIZE (TREE_TYPE (gnu_result))))))
4111 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
4112 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
4114 /* In this case remove padding only if the inner object is of
4115 self-referential size: in that case it must be an object of
4116 unconstrained type with a default discriminant. In other cases,
4117 we want to avoid copying too much data. */
4118 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4119 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
4120 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4121 (TREE_TYPE (TYPE_FIELDS
4122 (TREE_TYPE (gnu_result))))))
4123 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4124 gnu_result);
4127 else if (TREE_CODE (gnu_result) == LABEL_DECL
4128 || TREE_CODE (gnu_result) == FIELD_DECL
4129 || TREE_CODE (gnu_result) == ERROR_MARK
4130 || (TYPE_SIZE (gnu_result_type)
4131 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
4132 && TREE_CODE (gnu_result) != INDIRECT_REF
4133 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
4134 || ((TYPE_NAME (gnu_result_type)
4135 == TYPE_NAME (TREE_TYPE (gnu_result)))
4136 && TREE_CODE (gnu_result_type) == RECORD_TYPE
4137 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4138 && TYPE_MODE (gnu_result_type) == BLKmode
4139 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result)))
4140 == MODE_INT)))
4142 /* Remove any padding record, but do nothing more in this case. */
4143 if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
4144 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)))
4145 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
4146 gnu_result);
4149 else if (gnu_result == error_mark_node
4150 || gnu_result_type == void_type_node)
4151 gnu_result = error_mark_node;
4152 else if (gnu_result_type != TREE_TYPE (gnu_result))
4153 gnu_result = convert (gnu_result_type, gnu_result);
4155 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4156 while ((TREE_CODE (gnu_result) == NOP_EXPR
4157 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
4158 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
4159 gnu_result = TREE_OPERAND (gnu_result, 0);
4161 return gnu_result;
4164 /* Record the current code position in GNAT_NODE. */
4166 static void
4167 record_code_position (Node_Id gnat_node)
4169 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
4171 add_stmt_with_node (stmt_stmt, gnat_node);
4172 save_gnu_tree (gnat_node, stmt_stmt, true);
4175 /* Insert the code for GNAT_NODE at the position saved for that node. */
4177 static void
4178 insert_code_for (Node_Id gnat_node)
4180 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node);
4181 save_gnu_tree (gnat_node, NULL_TREE, true);
4184 /* Start a new statement group chained to the previous group. */
4186 static void
4187 start_stmt_group ()
4189 struct stmt_group *group = stmt_group_free_list;
4191 /* First see if we can get one from the free list. */
4192 if (group)
4193 stmt_group_free_list = group->previous;
4194 else
4195 group = (struct stmt_group *) ggc_alloc (sizeof (struct stmt_group));
4197 group->previous = current_stmt_group;
4198 group->stmt_list = group->block = group->cleanups = NULL_TREE;
4199 current_stmt_group = group;
4202 /* Add GNU_STMT to the current statement group. */
4204 void
4205 add_stmt (tree gnu_stmt)
4207 append_to_statement_list (gnu_stmt, &current_stmt_group->stmt_list);
4209 /* If we're at top level, show everything in here is in use in case
4210 any of it is shared by a subprogram. */
4211 if (global_bindings_p ())
4212 walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
4216 /* Similar, but set the location of GNU_STMT to that of GNAT_NODE. */
4218 void
4219 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
4221 if (Present (gnat_node))
4222 annotate_with_node (gnu_stmt, gnat_node);
4223 add_stmt (gnu_stmt);
4226 /* Add a declaration statement for GNU_DECL to the current statement group.
4227 Get SLOC from Entity_Id. */
4229 void
4230 add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
4232 tree gnu_stmt;
4234 /* If this is a variable that Gigi is to ignore, we may have been given
4235 an ERROR_MARK. So test for it. We also might have been given a
4236 reference for a renaming. So only do something for a decl. Also
4237 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
4238 if (!DECL_P (gnu_decl)
4239 || (TREE_CODE (gnu_decl) == TYPE_DECL
4240 && TREE_CODE (TREE_TYPE (gnu_decl)) == UNCONSTRAINED_ARRAY_TYPE))
4241 return;
4243 /* If we are global, we don't want to actually output the DECL_EXPR for
4244 this decl since we already have evaluated the expressions in the
4245 sizes and positions as globals and doing it again would be wrong.
4246 But we do have to mark everything as used. */
4247 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
4248 if (!global_bindings_p ())
4249 add_stmt_with_node (gnu_stmt, gnat_entity);
4250 else
4252 walk_tree (&gnu_stmt, mark_visited, NULL, NULL);
4253 if (TREE_CODE (gnu_decl) == VAR_DECL
4254 || TREE_CODE (gnu_decl) == CONST_DECL)
4256 walk_tree (&DECL_SIZE (gnu_decl), mark_visited, NULL, NULL);
4257 walk_tree (&DECL_SIZE_UNIT (gnu_decl), mark_visited, NULL, NULL);
4258 walk_tree (&DECL_INITIAL (gnu_decl), mark_visited, NULL, NULL);
4262 /* If this is a DECL_EXPR for a variable with DECL_INITIAl set,
4263 there are two cases we need to handle here. */
4264 if (TREE_CODE (gnu_decl) == VAR_DECL && DECL_INITIAL (gnu_decl))
4266 tree gnu_init = DECL_INITIAL (gnu_decl);
4267 tree gnu_lhs = NULL_TREE;
4269 /* If this is a DECL_EXPR for a variable with DECL_INITIAL set
4270 and decl has a padded type, convert it to the unpadded type so the
4271 assignment is done properly. */
4272 if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
4273 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_decl)))
4274 gnu_lhs
4275 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_decl))), gnu_decl);
4277 /* Otherwise, if this is going into memory and the initializer isn't
4278 valid for the assembler and loader. Gimplification could do this,
4279 but would be run too late if -fno-unit-at-a-time. */
4280 else if (TREE_STATIC (gnu_decl)
4281 && !initializer_constant_valid_p (gnu_init,
4282 TREE_TYPE (gnu_decl)))
4283 gnu_lhs = gnu_decl;
4285 if (gnu_lhs)
4287 tree gnu_assign_stmt
4288 = build_binary_op (MODIFY_EXPR, NULL_TREE,
4289 gnu_lhs, DECL_INITIAL (gnu_decl));
4291 DECL_INITIAL (gnu_decl) = 0;
4292 TREE_READONLY (gnu_decl) = 0;
4293 annotate_with_locus (gnu_assign_stmt,
4294 DECL_SOURCE_LOCATION (gnu_decl));
4295 add_stmt (gnu_assign_stmt);
4300 /* Utility function to mark nodes with TREE_VISITED and types as having their
4301 sized gimplified. Called from walk_tree. We use this to indicate all
4302 variable sizes and positions in global types may not be shared by any
4303 subprogram. */
4305 static tree
4306 mark_visited (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
4308 if (TREE_VISITED (*tp))
4309 *walk_subtrees = 0;
4311 /* Don't mark a dummy type as visited because we want to mark its sizes
4312 and fields once it's filled in. */
4313 else if (!TYPE_IS_DUMMY_P (*tp))
4314 TREE_VISITED (*tp) = 1;
4316 if (TYPE_P (*tp))
4317 TYPE_SIZES_GIMPLIFIED (*tp) = 1;
4319 return NULL_TREE;
4322 /* Likewise, but to mark as unvisited. */
4324 static tree
4325 mark_unvisited (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
4326 void *data ATTRIBUTE_UNUSED)
4328 TREE_VISITED (*tp) = 0;
4330 return NULL_TREE;
4333 /* Add GNU_CLEANUP, a cleanup action, to the current code group. */
4335 static void
4336 add_cleanup (tree gnu_cleanup)
4338 append_to_statement_list (gnu_cleanup, &current_stmt_group->cleanups);
4341 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
4343 void
4344 set_block_for_group (tree gnu_block)
4346 gcc_assert (!current_stmt_group->block);
4347 current_stmt_group->block = gnu_block;
4350 /* Return code corresponding to the current code group. It is normally
4351 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
4352 BLOCK or cleanups were set. */
4354 static tree
4355 end_stmt_group ()
4357 struct stmt_group *group = current_stmt_group;
4358 tree gnu_retval = group->stmt_list;
4360 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
4361 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
4362 make a BIND_EXPR. Note that we nest in that because the cleanup may
4363 reference variables in the block. */
4364 if (gnu_retval == NULL_TREE)
4365 gnu_retval = alloc_stmt_list ();
4367 if (group->cleanups)
4368 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
4369 group->cleanups);
4371 if (current_stmt_group->block)
4372 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
4373 gnu_retval, group->block);
4375 /* Remove this group from the stack and add it to the free list. */
4376 current_stmt_group = group->previous;
4377 group->previous = stmt_group_free_list;
4378 stmt_group_free_list = group;
4380 return gnu_retval;
4383 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
4384 statements.*/
4386 static void
4387 add_stmt_list (List_Id gnat_list)
4389 Node_Id gnat_node;
4391 if (Present (gnat_list))
4392 for (gnat_node = First (gnat_list); Present (gnat_node);
4393 gnat_node = Next (gnat_node))
4394 add_stmt (gnat_to_gnu (gnat_node));
4397 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
4398 If BINDING_P is true, push and pop a binding level around the list. */
4400 static tree
4401 build_stmt_group (List_Id gnat_list, bool binding_p)
4403 start_stmt_group ();
4404 if (binding_p)
4405 gnat_pushlevel ();
4407 add_stmt_list (gnat_list);
4408 if (binding_p)
4409 gnat_poplevel ();
4411 return end_stmt_group ();
4414 /* Push and pop routines for stacks. We keep a free list around so we
4415 don't waste tree nodes. */
4417 static void
4418 push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value)
4420 tree gnu_node = gnu_stack_free_list;
4422 if (gnu_node)
4424 gnu_stack_free_list = TREE_CHAIN (gnu_node);
4425 TREE_CHAIN (gnu_node) = *gnu_stack_ptr;
4426 TREE_PURPOSE (gnu_node) = gnu_purpose;
4427 TREE_VALUE (gnu_node) = gnu_value;
4429 else
4430 gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr);
4432 *gnu_stack_ptr = gnu_node;
4435 static void
4436 pop_stack (tree *gnu_stack_ptr)
4438 tree gnu_node = *gnu_stack_ptr;
4440 *gnu_stack_ptr = TREE_CHAIN (gnu_node);
4441 TREE_CHAIN (gnu_node) = gnu_stack_free_list;
4442 gnu_stack_free_list = gnu_node;
4445 /* GNU_STMT is a statement. We generate code for that statement. */
4447 void
4448 gnat_expand_stmt (tree gnu_stmt)
4450 #if 0
4451 tree gnu_elmt, gnu_elmt_2;
4452 #endif
4454 switch (TREE_CODE (gnu_stmt))
4456 #if 0
4457 case USE_STMT:
4458 /* First write a volatile ASM_INPUT to prevent anything from being
4459 moved. */
4460 gnu_elmt = gen_rtx_ASM_INPUT (VOIDmode, "");
4461 MEM_VOLATILE_P (gnu_elmt) = 1;
4462 emit_insn (gnu_elmt);
4464 gnu_elmt = expand_expr (TREE_OPERAND (gnu_stmt, 0), NULL_RTX, VOIDmode,
4465 modifier);
4466 emit_insn (gen_rtx_USE (VOIDmode, ));
4467 return target;
4468 #endif
4470 default:
4471 gcc_unreachable ();
4475 /* Generate GIMPLE in place for the expression at *EXPR_P. */
4478 gnat_gimplify_expr (tree *expr_p, tree *pre_p, tree *post_p ATTRIBUTE_UNUSED)
4480 tree expr = *expr_p;
4482 if (IS_ADA_STMT (expr))
4483 return gnat_gimplify_stmt (expr_p);
4485 switch (TREE_CODE (expr))
4487 case NULL_EXPR:
4488 /* If this is for a scalar, just make a VAR_DECL for it. If for
4489 an aggregate, get a null pointer of the appropriate type and
4490 dereference it. */
4491 if (AGGREGATE_TYPE_P (TREE_TYPE (expr)))
4492 *expr_p = build1 (INDIRECT_REF, TREE_TYPE (expr),
4493 convert (build_pointer_type (TREE_TYPE (expr)),
4494 integer_zero_node));
4495 else
4497 *expr_p = create_tmp_var (TREE_TYPE (expr), NULL);
4498 TREE_NO_WARNING (*expr_p) = 1;
4501 append_to_statement_list (TREE_OPERAND (expr, 0), pre_p);
4502 return GS_OK;
4504 case UNCONSTRAINED_ARRAY_REF:
4505 /* We should only do this if we are just elaborating for side-effects,
4506 but we can't know that yet. */
4507 *expr_p = TREE_OPERAND (*expr_p, 0);
4508 return GS_OK;
4510 case ADDR_EXPR:
4511 /* If we're taking the address of a constant CONSTRUCTOR, force it to
4512 be put into static memory. We know it's going to be readonly given
4513 the semantics we have and it's required to be static memory in
4514 the case when the reference is in an elaboration procedure. */
4515 if (TREE_CODE (TREE_OPERAND (expr, 0)) == CONSTRUCTOR
4516 && TREE_CONSTANT (TREE_OPERAND (expr, 0)))
4518 tree new_var
4519 = create_tmp_var (TREE_TYPE (TREE_OPERAND (expr, 0)), "C");
4521 TREE_READONLY (new_var) = 1;
4522 TREE_STATIC (new_var) = 1;
4523 TREE_ADDRESSABLE (new_var) = 1;
4524 DECL_INITIAL (new_var) = TREE_OPERAND (expr, 0);
4526 TREE_OPERAND (expr, 0) = new_var;
4527 return GS_ALL_DONE;
4529 return GS_UNHANDLED;
4531 case COMPONENT_REF:
4532 /* We have a kludge here. If the FIELD_DECL is from a fat pointer and is
4533 from an early dummy type, replace it with the proper FIELD_DECL. */
4534 if (TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (*expr_p, 0)))
4535 && DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1)))
4537 TREE_OPERAND (*expr_p, 1)
4538 = DECL_ORIGINAL_FIELD (TREE_OPERAND (*expr_p, 1));
4539 return GS_OK;
4542 /* ... fall through ... */
4544 default:
4545 return GS_UNHANDLED;
4549 /* Generate GIMPLE in place for the statement at *STMT_P. */
4551 static enum gimplify_status
4552 gnat_gimplify_stmt (tree *stmt_p)
4554 tree stmt = *stmt_p;
4556 switch (TREE_CODE (stmt))
4558 case STMT_STMT:
4559 *stmt_p = STMT_STMT_STMT (stmt);
4560 return GS_OK;
4562 case USE_STMT:
4563 *stmt_p = NULL_TREE;
4564 return GS_ALL_DONE;
4566 case LOOP_STMT:
4568 tree gnu_start_label = create_artificial_label ();
4569 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
4571 /* Set to emit the statements of the loop. */
4572 *stmt_p = NULL_TREE;
4574 /* We first emit the start label and then a conditional jump to
4575 the end label if there's a top condition, then the body of the
4576 loop, then a conditional branch to the end label, then the update,
4577 if any, and finally a jump to the start label and the definition
4578 of the end label. */
4579 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
4580 gnu_start_label),
4581 stmt_p);
4583 if (LOOP_STMT_TOP_COND (stmt))
4584 append_to_statement_list (build3 (COND_EXPR, void_type_node,
4585 LOOP_STMT_TOP_COND (stmt),
4586 alloc_stmt_list (),
4587 build1 (GOTO_EXPR,
4588 void_type_node,
4589 gnu_end_label)),
4590 stmt_p);
4592 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
4594 if (LOOP_STMT_BOT_COND (stmt))
4595 append_to_statement_list (build3 (COND_EXPR, void_type_node,
4596 LOOP_STMT_BOT_COND (stmt),
4597 alloc_stmt_list (),
4598 build1 (GOTO_EXPR,
4599 void_type_node,
4600 gnu_end_label)),
4601 stmt_p);
4603 if (LOOP_STMT_UPDATE (stmt))
4604 append_to_statement_list (LOOP_STMT_UPDATE (stmt), stmt_p);
4606 append_to_statement_list (build1 (GOTO_EXPR, void_type_node,
4607 gnu_start_label),
4608 stmt_p);
4609 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
4610 gnu_end_label),
4611 stmt_p);
4612 return GS_OK;
4615 case EXIT_STMT:
4616 /* Build a statement to jump to the corresponding end label, then
4617 see if it needs to be conditional. */
4618 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
4619 if (EXIT_STMT_COND (stmt))
4620 *stmt_p = build3 (COND_EXPR, void_type_node,
4621 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
4622 return GS_OK;
4624 default:
4625 gcc_unreachable ();
4629 /* Force references to each of the entities in packages GNAT_NODE with's
4630 so that the debugging information for all of them are identical
4631 in all clients. Operate recursively on anything it with's, but check
4632 that we aren't elaborating something more than once. */
4634 /* The reason for this routine's existence is two-fold.
4635 First, with some debugging formats, notably MDEBUG on SGI
4636 IRIX, the linker will remove duplicate debugging information if two
4637 clients have identical debugguing information. With the normal scheme
4638 of elaboration, this does not usually occur, since entities in with'ed
4639 packages are elaborated on demand, and if clients have different usage
4640 patterns, the normal case, then the order and selection of entities
4641 will differ. In most cases however, it seems that linkers do not know
4642 how to eliminate duplicate debugging information, even if it is
4643 identical, so the use of this routine would increase the total amount
4644 of debugging information in the final executable.
4646 Second, this routine is called in type_annotate mode, to compute DDA
4647 information for types in withed units, for ASIS use */
4649 static void
4650 elaborate_all_entities (Node_Id gnat_node)
4652 Entity_Id gnat_with_clause, gnat_entity;
4654 /* Process each unit only once. As we trace the context of all relevant
4655 units transitively, including generic bodies, we may encounter the
4656 same generic unit repeatedly */
4658 if (!present_gnu_tree (gnat_node))
4659 save_gnu_tree (gnat_node, integer_zero_node, true);
4661 /* Save entities in all context units. A body may have an implicit_with
4662 on its own spec, if the context includes a child unit, so don't save
4663 the spec twice. */
4665 for (gnat_with_clause = First (Context_Items (gnat_node));
4666 Present (gnat_with_clause);
4667 gnat_with_clause = Next (gnat_with_clause))
4668 if (Nkind (gnat_with_clause) == N_With_Clause
4669 && !present_gnu_tree (Library_Unit (gnat_with_clause))
4670 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
4672 elaborate_all_entities (Library_Unit (gnat_with_clause));
4674 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
4676 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
4677 Present (gnat_entity);
4678 gnat_entity = Next_Entity (gnat_entity))
4679 if (Is_Public (gnat_entity)
4680 && Convention (gnat_entity) != Convention_Intrinsic
4681 && Ekind (gnat_entity) != E_Package
4682 && Ekind (gnat_entity) != E_Package_Body
4683 && Ekind (gnat_entity) != E_Operator
4684 && !(IN (Ekind (gnat_entity), Type_Kind)
4685 && !Is_Frozen (gnat_entity))
4686 && !((Ekind (gnat_entity) == E_Procedure
4687 || Ekind (gnat_entity) == E_Function)
4688 && Is_Intrinsic_Subprogram (gnat_entity))
4689 && !IN (Ekind (gnat_entity), Named_Kind)
4690 && !IN (Ekind (gnat_entity), Generic_Unit_Kind))
4691 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4693 else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
4695 Node_Id gnat_body
4696 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
4698 /* Retrieve compilation unit node of generic body. */
4699 while (Present (gnat_body)
4700 && Nkind (gnat_body) != N_Compilation_Unit)
4701 gnat_body = Parent (gnat_body);
4703 /* If body is available, elaborate its context. */
4704 if (Present (gnat_body))
4705 elaborate_all_entities (gnat_body);
4709 if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
4710 elaborate_all_entities (Library_Unit (gnat_node));
4713 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
4715 static void
4716 process_freeze_entity (Node_Id gnat_node)
4718 Entity_Id gnat_entity = Entity (gnat_node);
4719 tree gnu_old;
4720 tree gnu_new;
4721 tree gnu_init
4722 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
4723 && present_gnu_tree (Declaration_Node (gnat_entity)))
4724 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
4726 /* If this is a package, need to generate code for the package. */
4727 if (Ekind (gnat_entity) == E_Package)
4729 insert_code_for
4730 (Parent (Corresponding_Body
4731 (Parent (Declaration_Node (gnat_entity)))));
4732 return;
4735 /* Check for old definition after the above call. This Freeze_Node
4736 might be for one its Itypes. */
4737 gnu_old
4738 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
4740 /* If this entity has an Address representation clause, GNU_OLD is the
4741 address, so discard it here. */
4742 if (Present (Address_Clause (gnat_entity)))
4743 gnu_old = 0;
4745 /* Don't do anything for class-wide types they are always
4746 transformed into their root type. */
4747 if (Ekind (gnat_entity) == E_Class_Wide_Type
4748 || (Ekind (gnat_entity) == E_Class_Wide_Subtype
4749 && Present (Equivalent_Type (gnat_entity))))
4750 return;
4752 /* Don't do anything for subprograms that may have been elaborated before
4753 their freeze nodes. This can happen, for example because of an inner call
4754 in an instance body. */
4755 if (gnu_old
4756 && TREE_CODE (gnu_old) == FUNCTION_DECL
4757 && (Ekind (gnat_entity) == E_Function
4758 || Ekind (gnat_entity) == E_Procedure))
4759 return;
4761 /* If we have a non-dummy type old tree, we have nothing to do. Unless
4762 this is the public view of a private type whose full view was not
4763 delayed, this node was never delayed as it should have been.
4764 Also allow this to happen for concurrent types since we may have
4765 frozen both the Corresponding_Record_Type and this type. */
4766 if (gnu_old
4767 && !(TREE_CODE (gnu_old) == TYPE_DECL
4768 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
4770 gcc_assert ((IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4771 && Present (Full_View (gnat_entity))
4772 && No (Freeze_Node (Full_View (gnat_entity))))
4773 || Is_Concurrent_Type (gnat_entity));
4774 return;
4777 /* Reset the saved tree, if any, and elaborate the object or type for real.
4778 If there is a full declaration, elaborate it and copy the type to
4779 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4780 a class wide type or subtype. */
4781 if (gnu_old)
4783 save_gnu_tree (gnat_entity, NULL_TREE, false);
4784 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4785 && Present (Full_View (gnat_entity))
4786 && present_gnu_tree (Full_View (gnat_entity)))
4787 save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
4788 if (Present (Class_Wide_Type (gnat_entity))
4789 && Class_Wide_Type (gnat_entity) != gnat_entity)
4790 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
4793 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
4794 && Present (Full_View (gnat_entity)))
4796 gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
4798 /* The above call may have defined this entity (the simplest example
4799 of this is when we have a private enumeral type since the bounds
4800 will have the public view. */
4801 if (!present_gnu_tree (gnat_entity))
4802 save_gnu_tree (gnat_entity, gnu_new, false);
4803 if (Present (Class_Wide_Type (gnat_entity))
4804 && Class_Wide_Type (gnat_entity) != gnat_entity)
4805 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
4807 else
4808 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
4810 /* If we've made any pointers to the old version of this type, we
4811 have to update them. */
4812 if (gnu_old)
4813 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
4814 TREE_TYPE (gnu_new));
4817 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4818 N_Compilation_Unit. */
4820 static void
4821 process_inlined_subprograms (Node_Id gnat_node)
4823 Entity_Id gnat_entity;
4824 Node_Id gnat_body;
4826 /* If we can inline, generate RTL for all the inlined subprograms.
4827 Define the entity first so we set DECL_EXTERNAL. */
4828 if (optimize > 0 && !flag_no_inline)
4829 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
4830 Present (gnat_entity);
4831 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
4833 gnat_body = Parent (Declaration_Node (gnat_entity));
4835 if (Nkind (gnat_body) != N_Subprogram_Body)
4837 /* ??? This really should always be Present. */
4838 if (No (Corresponding_Body (gnat_body)))
4839 continue;
4841 gnat_body
4842 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
4845 if (Present (gnat_body))
4847 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
4848 add_stmt (gnat_to_gnu (gnat_body));
4853 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4854 We make two passes, one to elaborate anything other than bodies (but
4855 we declare a function if there was no spec). The second pass
4856 elaborates the bodies.
4858 GNAT_END_LIST gives the element in the list past the end. Normally,
4859 this is Empty, but can be First_Real_Statement for a
4860 Handled_Sequence_Of_Statements.
4862 We make a complete pass through both lists if PASS1P is true, then make
4863 the second pass over both lists if PASS2P is true. The lists usually
4864 correspond to the public and private parts of a package. */
4866 static void
4867 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
4868 Node_Id gnat_end_list, bool pass1p, bool pass2p)
4870 List_Id gnat_decl_array[2];
4871 Node_Id gnat_decl;
4872 int i;
4874 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
4876 if (pass1p)
4877 for (i = 0; i <= 1; i++)
4878 if (Present (gnat_decl_array[i]))
4879 for (gnat_decl = First (gnat_decl_array[i]);
4880 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4882 /* For package specs, we recurse inside the declarations,
4883 thus taking the two pass approach inside the boundary. */
4884 if (Nkind (gnat_decl) == N_Package_Declaration
4885 && (Nkind (Specification (gnat_decl)
4886 == N_Package_Specification)))
4887 process_decls (Visible_Declarations (Specification (gnat_decl)),
4888 Private_Declarations (Specification (gnat_decl)),
4889 Empty, true, false);
4891 /* Similarly for any declarations in the actions of a
4892 freeze node. */
4893 else if (Nkind (gnat_decl) == N_Freeze_Entity)
4895 process_freeze_entity (gnat_decl);
4896 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
4899 /* Package bodies with freeze nodes get their elaboration deferred
4900 until the freeze node, but the code must be placed in the right
4901 place, so record the code position now. */
4902 else if (Nkind (gnat_decl) == N_Package_Body
4903 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
4904 record_code_position (gnat_decl);
4906 else if (Nkind (gnat_decl) == N_Package_Body_Stub
4907 && Present (Library_Unit (gnat_decl))
4908 && Present (Freeze_Node
4909 (Corresponding_Spec
4910 (Proper_Body (Unit
4911 (Library_Unit (gnat_decl)))))))
4912 record_code_position
4913 (Proper_Body (Unit (Library_Unit (gnat_decl))));
4915 /* We defer most subprogram bodies to the second pass. */
4916 else if (Nkind (gnat_decl) == N_Subprogram_Body)
4918 if (Acts_As_Spec (gnat_decl))
4920 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
4922 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
4923 && Ekind (gnat_subprog_id) != E_Generic_Function)
4924 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4927 /* For bodies and stubs that act as their own specs, the entity
4928 itself must be elaborated in the first pass, because it may
4929 be used in other declarations. */
4930 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
4932 Node_Id gnat_subprog_id =
4933 Defining_Entity (Specification (gnat_decl));
4935 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
4936 && Ekind (gnat_subprog_id) != E_Generic_Procedure
4937 && Ekind (gnat_subprog_id) != E_Generic_Function)
4938 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
4941 /* Concurrent stubs stand for the corresponding subprogram bodies,
4942 which are deferred like other bodies. */
4943 else if (Nkind (gnat_decl) == N_Task_Body_Stub
4944 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4946 else
4947 add_stmt (gnat_to_gnu (gnat_decl));
4950 /* Here we elaborate everything we deferred above except for package bodies,
4951 which are elaborated at their freeze nodes. Note that we must also
4952 go inside things (package specs and freeze nodes) the first pass did. */
4953 if (pass2p)
4954 for (i = 0; i <= 1; i++)
4955 if (Present (gnat_decl_array[i]))
4956 for (gnat_decl = First (gnat_decl_array[i]);
4957 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
4959 if (Nkind (gnat_decl) == N_Subprogram_Body
4960 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
4961 || Nkind (gnat_decl) == N_Task_Body_Stub
4962 || Nkind (gnat_decl) == N_Protected_Body_Stub)
4963 add_stmt (gnat_to_gnu (gnat_decl));
4965 else if (Nkind (gnat_decl) == N_Package_Declaration
4966 && (Nkind (Specification (gnat_decl)
4967 == N_Package_Specification)))
4968 process_decls (Visible_Declarations (Specification (gnat_decl)),
4969 Private_Declarations (Specification (gnat_decl)),
4970 Empty, false, true);
4972 else if (Nkind (gnat_decl) == N_Freeze_Entity)
4973 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
4977 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4978 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4979 which we have to check. */
4981 static tree
4982 emit_range_check (tree gnu_expr, Entity_Id gnat_range_type)
4984 tree gnu_range_type = get_unpadded_type (gnat_range_type);
4985 tree gnu_low = TYPE_MIN_VALUE (gnu_range_type);
4986 tree gnu_high = TYPE_MAX_VALUE (gnu_range_type);
4987 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr));
4989 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4990 we can't do anything since we might be truncating the bounds. No
4991 check is needed in this case. */
4992 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr))
4993 && (TYPE_PRECISION (gnu_compare_type)
4994 < TYPE_PRECISION (get_base_type (gnu_range_type))))
4995 return gnu_expr;
4997 /* Checked expressions must be evaluated only once. */
4998 gnu_expr = protect_multiple_eval (gnu_expr);
5000 /* There's no good type to use here, so we might as well use
5001 integer_type_node. Note that the form of the check is
5002 (not (expr >= lo)) or (not (expr >= hi))
5003 the reason for this slightly convoluted form is that NaN's
5004 are not considered to be in range in the float case. */
5005 return emit_check
5006 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5007 invert_truthvalue
5008 (build_binary_op (GE_EXPR, integer_type_node,
5009 convert (gnu_compare_type, gnu_expr),
5010 convert (gnu_compare_type, gnu_low))),
5011 invert_truthvalue
5012 (build_binary_op (LE_EXPR, integer_type_node,
5013 convert (gnu_compare_type, gnu_expr),
5014 convert (gnu_compare_type,
5015 gnu_high)))),
5016 gnu_expr, CE_Range_Check_Failed);
5019 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
5020 which we are about to index, GNU_EXPR is the index expression to be
5021 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
5022 against which GNU_EXPR has to be checked. Note that for index
5023 checking we cannot use the emit_range_check function (although very
5024 similar code needs to be generated in both cases) since for index
5025 checking the array type against which we are checking the indeces
5026 may be unconstrained and consequently we need to retrieve the
5027 actual index bounds from the array object itself
5028 (GNU_ARRAY_OBJECT). The place where we need to do that is in
5029 subprograms having unconstrained array formal parameters */
5031 static tree
5032 emit_index_check (tree gnu_array_object,
5033 tree gnu_expr,
5034 tree gnu_low,
5035 tree gnu_high)
5037 tree gnu_expr_check;
5039 /* Checked expressions must be evaluated only once. */
5040 gnu_expr = protect_multiple_eval (gnu_expr);
5042 /* Must do this computation in the base type in case the expression's
5043 type is an unsigned subtypes. */
5044 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
5046 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
5047 the object we are handling. */
5048 gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object);
5049 gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object);
5051 /* There's no good type to use here, so we might as well use
5052 integer_type_node. */
5053 return emit_check
5054 (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
5055 build_binary_op (LT_EXPR, integer_type_node,
5056 gnu_expr_check,
5057 convert (TREE_TYPE (gnu_expr_check),
5058 gnu_low)),
5059 build_binary_op (GT_EXPR, integer_type_node,
5060 gnu_expr_check,
5061 convert (TREE_TYPE (gnu_expr_check),
5062 gnu_high))),
5063 gnu_expr, CE_Index_Check_Failed);
5066 /* GNU_COND contains the condition corresponding to an access, discriminant or
5067 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if
5068 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
5069 REASON is the code that says why the exception was raised. */
5071 static tree
5072 emit_check (tree gnu_cond, tree gnu_expr, int reason)
5074 tree gnu_call;
5075 tree gnu_result;
5077 gnu_call = build_call_raise (reason);
5079 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
5080 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
5081 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
5082 out. */
5083 gnu_result = fold (build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
5084 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr),
5085 gnu_call, gnu_expr),
5086 gnu_expr));
5088 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
5089 protect it. Otherwise, show GNU_RESULT has no side effects: we
5090 don't need to evaluate it just for the check. */
5091 if (TREE_SIDE_EFFECTS (gnu_expr))
5092 gnu_result
5093 = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, gnu_result);
5094 else
5095 TREE_SIDE_EFFECTS (gnu_result) = 0;
5097 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
5098 we will repeatedly do the test. It would be nice if GCC was able
5099 to optimize this and only do it once. */
5100 return save_expr (gnu_result);
5103 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
5104 overflow checks if OVERFLOW_P is nonzero and range checks if
5105 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
5106 If TRUNCATE_P is nonzero, do a float to integer conversion with
5107 truncation; otherwise round. */
5109 static tree
5110 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp,
5111 bool rangep, bool truncatep)
5113 tree gnu_type = get_unpadded_type (gnat_type);
5114 tree gnu_in_type = TREE_TYPE (gnu_expr);
5115 tree gnu_in_basetype = get_base_type (gnu_in_type);
5116 tree gnu_base_type = get_base_type (gnu_type);
5117 tree gnu_ada_base_type = get_ada_base_type (gnu_type);
5118 tree gnu_result = gnu_expr;
5120 /* If we are not doing any checks, the output is an integral type, and
5121 the input is not a floating type, just do the conversion. This
5122 shortcut is required to avoid problems with packed array types
5123 and simplifies code in all cases anyway. */
5124 if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type)
5125 && !FLOAT_TYPE_P (gnu_in_type))
5126 return convert (gnu_type, gnu_expr);
5128 /* First convert the expression to its base type. This
5129 will never generate code, but makes the tests below much simpler.
5130 But don't do this if converting from an integer type to an unconstrained
5131 array type since then we need to get the bounds from the original
5132 (unpacked) type. */
5133 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
5134 gnu_result = convert (gnu_in_basetype, gnu_result);
5136 /* If overflow checks are requested, we need to be sure the result will
5137 fit in the output base type. But don't do this if the input
5138 is integer and the output floating-point. */
5139 if (overflowp
5140 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype)))
5142 /* Ensure GNU_EXPR only gets evaluated once. */
5143 tree gnu_input = protect_multiple_eval (gnu_result);
5144 tree gnu_cond = integer_zero_node;
5145 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype);
5146 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype);
5147 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
5148 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type);
5150 /* Convert the lower bounds to signed types, so we're sure we're
5151 comparing them properly. Likewise, convert the upper bounds
5152 to unsigned types. */
5153 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype))
5154 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb);
5156 if (INTEGRAL_TYPE_P (gnu_in_basetype)
5157 && !TYPE_UNSIGNED (gnu_in_basetype))
5158 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub);
5160 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
5161 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb);
5163 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
5164 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub);
5166 /* Check each bound separately and only if the result bound
5167 is tighter than the bound on the input type. Note that all the
5168 types are base types, so the bounds must be constant. Also,
5169 the comparison is done in the base type of the input, which
5170 always has the proper signedness. First check for input
5171 integer (which means output integer), output float (which means
5172 both float), or mixed, in which case we always compare.
5173 Note that we have to do the comparison which would *fail* in the
5174 case of an error since if it's an FP comparison and one of the
5175 values is a NaN or Inf, the comparison will fail. */
5176 if (INTEGRAL_TYPE_P (gnu_in_basetype)
5177 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
5178 : (FLOAT_TYPE_P (gnu_base_type)
5179 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb),
5180 TREE_REAL_CST (gnu_out_lb))
5181 : 1))
5182 gnu_cond
5183 = invert_truthvalue
5184 (build_binary_op (GE_EXPR, integer_type_node,
5185 gnu_input, convert (gnu_in_basetype,
5186 gnu_out_lb)));
5188 if (INTEGRAL_TYPE_P (gnu_in_basetype)
5189 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
5190 : (FLOAT_TYPE_P (gnu_base_type)
5191 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub),
5192 TREE_REAL_CST (gnu_in_lb))
5193 : 1))
5194 gnu_cond
5195 = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_cond,
5196 invert_truthvalue
5197 (build_binary_op (LE_EXPR, integer_type_node,
5198 gnu_input,
5199 convert (gnu_in_basetype,
5200 gnu_out_ub))));
5202 if (!integer_zerop (gnu_cond))
5203 gnu_result = emit_check (gnu_cond, gnu_input,
5204 CE_Overflow_Check_Failed);
5207 /* Now convert to the result base type. If this is a non-truncating
5208 float-to-integer conversion, round. */
5209 if (INTEGRAL_TYPE_P (gnu_ada_base_type) && FLOAT_TYPE_P (gnu_in_basetype)
5210 && !truncatep)
5212 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
5213 tree gnu_conv, gnu_zero, gnu_comp, gnu_saved_result, calc_type;
5214 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
5215 const struct real_format *fmt;
5217 /* The following calculations depend on proper rounding to even
5218 of each arithmetic operation. In order to prevent excess
5219 precision from spoiling this property, use the widest hardware
5220 floating-point type.
5222 FIXME: For maximum efficiency, this should only be done for machines
5223 and types where intermediates may have extra precision. */
5225 calc_type = longest_float_type_node;
5226 /* FIXME: Should not have padding in the first place */
5227 if (TREE_CODE (calc_type) == RECORD_TYPE
5228 && TYPE_IS_PADDING_P (calc_type))
5229 calc_type = TREE_TYPE (TYPE_FIELDS (calc_type));
5231 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
5232 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
5233 real_2expN (&half_minus_pred_half, -(fmt->p) - 1);
5234 REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf,
5235 half_minus_pred_half);
5236 gnu_pred_half = build_real (calc_type, pred_half);
5238 /* If the input is strictly negative, subtract this value
5239 and otherwise add it from the input. For 0.5, the result
5240 is exactly between 1.0 and the machine number preceding 1.0
5241 (for calc_type). Since the last bit of 1.0 is even, this 0.5
5242 will round to 1.0, while all other number with an absolute
5243 value less than 0.5 round to 0.0. For larger numbers exactly
5244 halfway between integers, rounding will always be correct as
5245 the true mathematical result will be closer to the higher
5246 integer compared to the lower one. So, this constant works
5247 for all floating-point numbers.
5249 The reason to use the same constant with subtract/add instead
5250 of a positive and negative constant is to allow the comparison
5251 to be scheduled in parallel with retrieval of the constant and
5252 conversion of the input to the calc_type (if necessary).
5255 gnu_zero = convert (gnu_in_basetype, integer_zero_node);
5256 gnu_saved_result = save_expr (gnu_result);
5257 gnu_conv = convert (calc_type, gnu_saved_result);
5258 gnu_comp = build2 (GE_EXPR, integer_type_node,
5259 gnu_saved_result, gnu_zero);
5260 gnu_add_pred_half
5261 = build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5262 gnu_subtract_pred_half
5263 = build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
5264 gnu_result = build3 (COND_EXPR, calc_type, gnu_comp,
5265 gnu_add_pred_half, gnu_subtract_pred_half);
5268 if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
5269 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type)
5270 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
5271 gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result, false);
5272 else
5273 gnu_result = convert (gnu_ada_base_type, gnu_result);
5275 /* Finally, do the range check if requested. Note that if the
5276 result type is a modular type, the range check is actually
5277 an overflow check. */
5279 if (rangep
5280 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE
5281 && TYPE_MODULAR_P (gnu_base_type) && overflowp))
5282 gnu_result = emit_range_check (gnu_result, gnat_type);
5284 return convert (gnu_type, gnu_result);
5287 /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
5288 it is an expression involving computation or if it involves a bitfield
5289 reference. This returns the same as gnat_mark_addressable in most
5290 cases. */
5292 static bool
5293 addressable_p (tree gnu_expr)
5295 switch (TREE_CODE (gnu_expr))
5297 case VAR_DECL:
5298 case PARM_DECL:
5299 case FUNCTION_DECL:
5300 case RESULT_DECL:
5301 /* All DECLs are addressable: if they are in a register, we can force
5302 them to memory. */
5303 return true;
5305 case UNCONSTRAINED_ARRAY_REF:
5306 case INDIRECT_REF:
5307 case CONSTRUCTOR:
5308 case NULL_EXPR:
5309 case SAVE_EXPR:
5310 return true;
5312 case COMPONENT_REF:
5313 return (!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
5314 && (!DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
5315 || !flag_strict_aliasing)
5316 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5318 case ARRAY_REF: case ARRAY_RANGE_REF:
5319 case REALPART_EXPR: case IMAGPART_EXPR:
5320 case NOP_EXPR:
5321 return addressable_p (TREE_OPERAND (gnu_expr, 0));
5323 case CONVERT_EXPR:
5324 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
5325 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5327 case VIEW_CONVERT_EXPR:
5329 /* This is addressable if we can avoid a copy. */
5330 tree type = TREE_TYPE (gnu_expr);
5331 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
5333 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
5334 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
5335 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
5336 || ((TYPE_MODE (type) == BLKmode
5337 || TYPE_MODE (inner_type) == BLKmode)
5338 && (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
5339 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
5340 || TYPE_ALIGN_OK (type)
5341 || TYPE_ALIGN_OK (inner_type))))
5342 && addressable_p (TREE_OPERAND (gnu_expr, 0)));
5345 default:
5346 return false;
5350 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
5351 a separate Freeze node exists, delay the bulk of the processing. Otherwise
5352 make a GCC type for GNAT_ENTITY and set up the correspondance. */
5354 void
5355 process_type (Entity_Id gnat_entity)
5357 tree gnu_old
5358 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
5359 tree gnu_new;
5361 /* If we are to delay elaboration of this type, just do any
5362 elaborations needed for expressions within the declaration and
5363 make a dummy type entry for this node and its Full_View (if
5364 any) in case something points to it. Don't do this if it
5365 has already been done (the only way that can happen is if
5366 the private completion is also delayed). */
5367 if (Present (Freeze_Node (gnat_entity))
5368 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5369 && Present (Full_View (gnat_entity))
5370 && Freeze_Node (Full_View (gnat_entity))
5371 && !present_gnu_tree (Full_View (gnat_entity))))
5373 elaborate_entity (gnat_entity);
5375 if (!gnu_old)
5377 tree gnu_decl = create_type_decl (get_entity_name (gnat_entity),
5378 make_dummy_type (gnat_entity),
5379 NULL, false, false, gnat_entity);
5381 save_gnu_tree (gnat_entity, gnu_decl, false);
5382 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
5383 && Present (Full_View (gnat_entity)))
5384 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
5387 return;
5390 /* If we saved away a dummy type for this node it means that this
5391 made the type that corresponds to the full type of an incomplete
5392 type. Clear that type for now and then update the type in the
5393 pointers. */
5394 if (gnu_old)
5396 if (TREE_CODE (gnu_old) != TYPE_DECL
5397 || !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))
5399 /* If this was a withed access type, this is not an error
5400 and merely indicates we've already elaborated the type
5401 already. */
5402 gcc_assert (Is_Type (gnat_entity) && From_With_Type (gnat_entity));
5403 return;
5406 save_gnu_tree (gnat_entity, NULL_TREE, false);
5409 /* Now fully elaborate the type. */
5410 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
5411 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
5413 /* If we have an old type and we've made pointers to this type,
5414 update those pointers. */
5415 if (gnu_old)
5416 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
5417 TREE_TYPE (gnu_new));
5419 /* If this is a record type corresponding to a task or protected type
5420 that is a completion of an incomplete type, perform a similar update
5421 on the type. */
5422 /* ??? Including protected types here is a guess. */
5424 if (IN (Ekind (gnat_entity), Record_Kind)
5425 && Is_Concurrent_Record_Type (gnat_entity)
5426 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
5428 tree gnu_task_old
5429 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
5431 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
5432 NULL_TREE, false);
5433 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
5434 gnu_new, false);
5436 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
5437 TREE_TYPE (gnu_new));
5441 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
5442 GNU_TYPE is the GCC type of the corresponding record.
5444 Return a CONSTRUCTOR to build the record. */
5446 static tree
5447 assoc_to_constructor (Node_Id gnat_assoc, tree gnu_type)
5449 tree gnu_list, gnu_result;
5451 /* We test for GNU_FIELD being empty in the case where a variant
5452 was the last thing since we don't take things off GNAT_ASSOC in
5453 that case. We check GNAT_ASSOC in case we have a variant, but it
5454 has no fields. */
5456 for (gnu_list = NULL_TREE; Present (gnat_assoc);
5457 gnat_assoc = Next (gnat_assoc))
5459 Node_Id gnat_field = First (Choices (gnat_assoc));
5460 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
5461 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
5463 /* The expander is supposed to put a single component selector name
5464 in every record component association */
5465 gcc_assert (No (Next (gnat_field)));
5467 /* Ignore fields that have Corresponding_Discriminants since we'll
5468 be setting that field in the parent. */
5469 if (Present (Corresponding_Discriminant (Entity (gnat_field)))
5470 && Is_Tagged_Type (Scope (Entity (gnat_field))))
5471 continue;
5473 /* Before assigning a value in an aggregate make sure range checks
5474 are done if required. Then convert to the type of the field. */
5475 if (Do_Range_Check (Expression (gnat_assoc)))
5476 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field));
5478 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
5480 /* Add the field and expression to the list. */
5481 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
5484 gnu_result = extract_values (gnu_list, gnu_type);
5486 #ifdef ENABLE_CHECKING
5488 tree gnu_field;
5490 /* Verify every enty in GNU_LIST was used. */
5491 for (gnu_field = gnu_list; gnu_field; gnu_field = TREE_CHAIN (gnu_field))
5492 gcc_assert (TREE_ADDRESSABLE (gnu_field));
5494 #endif
5496 return gnu_result;
5499 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5500 is the first element of an array aggregate. It may itself be an
5501 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5502 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5503 of the array component. It is needed for range checking. */
5505 static tree
5506 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type,
5507 Entity_Id gnat_component_type)
5509 tree gnu_expr_list = NULL_TREE;
5510 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
5511 tree gnu_expr;
5513 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr))
5515 /* If the expression is itself an array aggregate then first build the
5516 innermost constructor if it is part of our array (multi-dimensional
5517 case). */
5519 if (Nkind (gnat_expr) == N_Aggregate
5520 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
5521 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
5522 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
5523 TREE_TYPE (gnu_array_type),
5524 gnat_component_type);
5525 else
5527 gnu_expr = gnat_to_gnu (gnat_expr);
5529 /* before assigning the element to the array make sure it is
5530 in range */
5531 if (Do_Range_Check (gnat_expr))
5532 gnu_expr = emit_range_check (gnu_expr, gnat_component_type);
5535 gnu_expr_list
5536 = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr),
5537 gnu_expr_list);
5539 gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0);
5542 return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list));
5545 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5546 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
5547 of the associations that are from RECORD_TYPE. If we see an internal
5548 record, make a recursive call to fill it in as well. */
5550 static tree
5551 extract_values (tree values, tree record_type)
5553 tree result = NULL_TREE;
5554 tree field, tem;
5556 for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
5558 tree value = 0;
5560 /* _Parent is an internal field, but may have values in the aggregate,
5561 so check for values first. */
5562 if ((tem = purpose_member (field, values)))
5564 value = TREE_VALUE (tem);
5565 TREE_ADDRESSABLE (tem) = 1;
5568 else if (DECL_INTERNAL_P (field))
5570 value = extract_values (values, TREE_TYPE (field));
5571 if (TREE_CODE (value) == CONSTRUCTOR && !CONSTRUCTOR_ELTS (value))
5572 value = 0;
5574 else
5575 /* If we have a record subtype, the names will match, but not the
5576 actual FIELD_DECLs. */
5577 for (tem = values; tem; tem = TREE_CHAIN (tem))
5578 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
5580 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
5581 TREE_ADDRESSABLE (tem) = 1;
5584 if (!value)
5585 continue;
5587 result = tree_cons (field, value, result);
5590 return gnat_build_constructor (record_type, nreverse (result));
5593 /* EXP is to be treated as an array or record. Handle the cases when it is
5594 an access object and perform the required dereferences. */
5596 static tree
5597 maybe_implicit_deref (tree exp)
5599 /* If the type is a pointer, dereference it. */
5601 if (POINTER_TYPE_P (TREE_TYPE (exp)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp)))
5602 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp);
5604 /* If we got a padded type, remove it too. */
5605 if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
5606 && TYPE_IS_PADDING_P (TREE_TYPE (exp)))
5607 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
5609 return exp;
5612 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
5614 tree
5615 protect_multiple_eval (tree exp)
5617 tree type = TREE_TYPE (exp);
5619 /* If this has no side effects, we don't need to do anything. */
5620 if (!TREE_SIDE_EFFECTS (exp))
5621 return exp;
5623 /* If it is a conversion, protect what's inside the conversion.
5624 Similarly, if we're indirectly referencing something, we only
5625 actually need to protect the address since the data itself can't
5626 change in these situations. */
5627 else if (TREE_CODE (exp) == NON_LVALUE_EXPR
5628 || TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR
5629 || TREE_CODE (exp) == VIEW_CONVERT_EXPR
5630 || TREE_CODE (exp) == INDIRECT_REF
5631 || TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF)
5632 return build1 (TREE_CODE (exp), type,
5633 protect_multiple_eval (TREE_OPERAND (exp, 0)));
5635 /* If EXP is a fat pointer or something that can be placed into a register,
5636 just make a SAVE_EXPR. */
5637 if (TYPE_FAT_POINTER_P (type) || TYPE_MODE (type) != BLKmode)
5638 return save_expr (exp);
5640 /* Otherwise, dereference, protect the address, and re-reference. */
5641 else
5642 return
5643 build_unary_op (INDIRECT_REF, type,
5644 save_expr (build_unary_op (ADDR_EXPR,
5645 build_reference_type (type),
5646 exp)));
5649 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5650 how to handle our new nodes and we take an extra argument that says
5651 whether to force evaluation of everything. */
5653 tree
5654 gnat_stabilize_reference (tree ref, bool force)
5656 tree type = TREE_TYPE (ref);
5657 enum tree_code code = TREE_CODE (ref);
5658 tree result;
5660 switch (code)
5662 case VAR_DECL:
5663 case PARM_DECL:
5664 case RESULT_DECL:
5665 /* No action is needed in this case. */
5666 return ref;
5668 case NOP_EXPR:
5669 case CONVERT_EXPR:
5670 case FLOAT_EXPR:
5671 case FIX_TRUNC_EXPR:
5672 case FIX_FLOOR_EXPR:
5673 case FIX_ROUND_EXPR:
5674 case FIX_CEIL_EXPR:
5675 case VIEW_CONVERT_EXPR:
5676 case ADDR_EXPR:
5677 result
5678 = build1 (code, type,
5679 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
5680 break;
5682 case INDIRECT_REF:
5683 case UNCONSTRAINED_ARRAY_REF:
5684 result = build1 (code, type,
5685 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5686 force));
5687 break;
5689 case COMPONENT_REF:
5690 result = build3 (COMPONENT_REF, type,
5691 gnat_stabilize_reference (TREE_OPERAND (ref, 0),
5692 force),
5693 TREE_OPERAND (ref, 1), NULL_TREE);
5694 break;
5696 case BIT_FIELD_REF:
5697 result = build3 (BIT_FIELD_REF, type,
5698 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5699 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5700 force),
5701 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
5702 force));
5703 break;
5705 case ARRAY_REF:
5706 case ARRAY_RANGE_REF:
5707 result = build4 (code, type,
5708 gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
5709 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
5710 force),
5711 NULL_TREE, NULL_TREE);
5712 break;
5714 case COMPOUND_EXPR:
5715 result = build2 (COMPOUND_EXPR, type,
5716 gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
5717 force),
5718 gnat_stabilize_reference (TREE_OPERAND (ref, 1),
5719 force));
5720 break;
5722 /* If arg isn't a kind of lvalue we recognize, make no change.
5723 Caller should recognize the error for an invalid lvalue. */
5724 default:
5725 return ref;
5727 case ERROR_MARK:
5728 return error_mark_node;
5731 TREE_READONLY (result) = TREE_READONLY (ref);
5733 /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS attached to the initial
5734 expression may not be sustained across some paths, such as the way via
5735 build1 for INDIRECT_REF. We re-populate those flags here for the general
5736 case, which is consistent with the GCC version of this routine.
5738 Special care should be taken regarding TREE_SIDE_EFFECTS, because some
5739 paths introduce side effects where there was none initially (e.g. calls
5740 to save_expr), and we also want to keep track of that. */
5742 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
5743 TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref);
5745 return result;
5748 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5749 arg to force a SAVE_EXPR for everything. */
5751 static tree
5752 gnat_stabilize_reference_1 (tree e, bool force)
5754 enum tree_code code = TREE_CODE (e);
5755 tree type = TREE_TYPE (e);
5756 tree result;
5758 /* We cannot ignore const expressions because it might be a reference
5759 to a const array but whose index contains side-effects. But we can
5760 ignore things that are actual constant or that already have been
5761 handled by this function. */
5763 if (TREE_CONSTANT (e) || code == SAVE_EXPR)
5764 return e;
5766 switch (TREE_CODE_CLASS (code))
5768 case tcc_exceptional:
5769 case tcc_type:
5770 case tcc_declaration:
5771 case tcc_comparison:
5772 case tcc_statement:
5773 case tcc_expression:
5774 case tcc_reference:
5775 /* If this is a COMPONENT_REF of a fat pointer, save the entire
5776 fat pointer. This may be more efficient, but will also allow
5777 us to more easily find the match for the PLACEHOLDER_EXPR. */
5778 if (code == COMPONENT_REF
5779 && TYPE_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (e, 0))))
5780 result = build3 (COMPONENT_REF, type,
5781 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
5782 force),
5783 TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
5784 else if (TREE_SIDE_EFFECTS (e) || force)
5785 return save_expr (e);
5786 else
5787 return e;
5788 break;
5790 case tcc_constant:
5791 /* Constants need no processing. In fact, we should never reach
5792 here. */
5793 return e;
5795 case tcc_binary:
5796 /* Recursively stabilize each operand. */
5797 result = build2 (code, type,
5798 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), force),
5799 gnat_stabilize_reference_1 (TREE_OPERAND (e, 1),
5800 force));
5801 break;
5803 case tcc_unary:
5804 /* Recursively stabilize each operand. */
5805 result = build1 (code, type,
5806 gnat_stabilize_reference_1 (TREE_OPERAND (e, 0),
5807 force));
5808 break;
5810 default:
5811 gcc_unreachable ();
5814 TREE_READONLY (result) = TREE_READONLY (e);
5816 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e);
5817 TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e);
5818 return result;
5821 extern char *__gnat_to_canonical_file_spec (char *);
5823 /* Convert Sloc into *LOCUS (a location_t). Return true if this Sloc
5824 corresponds to a source code location and false if it doesn't. In the
5825 latter case, we don't update *LOCUS. We also set the Gigi global variable
5826 REF_FILENAME to the reference file name as given by sinput (i.e no
5827 directory). */
5829 bool
5830 Sloc_to_locus (Source_Ptr Sloc, location_t *locus)
5832 /* If node not from source code, ignore. */
5833 if (Sloc < 0)
5834 return false;
5836 /* Use the identifier table to make a hashed, permanent copy of the filename,
5837 since the name table gets reallocated after Gigi returns but before all
5838 the debugging information is output. The __gnat_to_canonical_file_spec
5839 call translates filenames from pragmas Source_Reference that contain host
5840 style syntax not understood by gdb. */
5841 locus->file
5842 = IDENTIFIER_POINTER
5843 (get_identifier
5844 (__gnat_to_canonical_file_spec
5845 (Get_Name_String (Full_Debug_Name (Get_Source_File_Index (Sloc))))));
5847 locus->line = Get_Logical_Line_Number (Sloc);
5849 ref_filename
5850 = IDENTIFIER_POINTER
5851 (get_identifier
5852 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));;
5854 return true;
5857 /* Similar to annotate_with_locus, but start with the Sloc of GNAT_NODE and
5858 don't do anything if it doesn't correspond to a source location. */
5860 static void
5861 annotate_with_node (tree node, Node_Id gnat_node)
5863 location_t locus;
5865 if (!Sloc_to_locus (Sloc (gnat_node), &locus))
5866 return;
5868 annotate_with_locus (node, locus);
5871 /* Post an error message. MSG is the error message, properly annotated.
5872 NODE is the node at which to post the error and the node to use for the
5873 "&" substitution. */
5875 void
5876 post_error (const char *msg, Node_Id node)
5878 String_Template temp;
5879 Fat_Pointer fp;
5881 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5882 fp.Array = msg, fp.Bounds = &temp;
5883 if (Present (node))
5884 Error_Msg_N (fp, node);
5887 /* Similar, but NODE is the node at which to post the error and ENT
5888 is the node to use for the "&" substitution. */
5890 void
5891 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
5893 String_Template temp;
5894 Fat_Pointer fp;
5896 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5897 fp.Array = msg, fp.Bounds = &temp;
5898 if (Present (node))
5899 Error_Msg_NE (fp, node, ent);
5902 /* Similar, but NODE is the node at which to post the error, ENT is the node
5903 to use for the "&" substitution, and N is the number to use for the ^. */
5905 void
5906 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int n)
5908 String_Template temp;
5909 Fat_Pointer fp;
5911 temp.Low_Bound = 1, temp.High_Bound = strlen (msg);
5912 fp.Array = msg, fp.Bounds = &temp;
5913 Error_Msg_Uint_1 = UI_From_Int (n);
5915 if (Present (node))
5916 Error_Msg_NE (fp, node, ent);
5919 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5920 number to write. If the tree represents a constant that fits within
5921 a host integer, the text inside curly brackets in MSG will be output
5922 (presumably including a '^'). Otherwise that text will not be output
5923 and the text inside square brackets will be output instead. */
5925 void
5926 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
5928 char *newmsg = alloca (strlen (msg) + 1);
5929 String_Template temp = {1, 0};
5930 Fat_Pointer fp;
5931 char start_yes, end_yes, start_no, end_no;
5932 const char *p;
5933 char *q;
5935 fp.Array = newmsg, fp.Bounds = &temp;
5937 if (host_integerp (t, 1)
5938 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5940 compare_tree_int
5941 (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
5942 #endif
5945 Error_Msg_Uint_1 = UI_From_Int (tree_low_cst (t, 1));
5946 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
5948 else
5949 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
5951 for (p = msg, q = newmsg; *p; p++)
5953 if (*p == start_yes)
5954 for (p++; *p != end_yes; p++)
5955 *q++ = *p;
5956 else if (*p == start_no)
5957 for (p++; *p != end_no; p++)
5959 else
5960 *q++ = *p;
5963 *q = 0;
5965 temp.High_Bound = strlen (newmsg);
5966 if (Present (node))
5967 Error_Msg_NE (fp, node, ent);
5970 /* Similar to post_error_ne_tree, except that NUM is a second
5971 integer to write in the message. */
5973 void
5974 post_error_ne_tree_2 (const char *msg,
5975 Node_Id node,
5976 Entity_Id ent,
5977 tree t,
5978 int num)
5980 Error_Msg_Uint_2 = UI_From_Int (num);
5981 post_error_ne_tree (msg, node, ent, t);
5984 /* Set the node for a second '&' in the error message. */
5986 void
5987 set_second_error_entity (Entity_Id e)
5989 Error_Msg_Node_2 = e;
5992 /* Initialize the table that maps GNAT codes to GCC codes for simple
5993 binary and unary operations. */
5995 void
5996 init_code_table (void)
5998 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
5999 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
6001 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
6002 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
6003 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
6004 gnu_codes[N_Op_Eq] = EQ_EXPR;
6005 gnu_codes[N_Op_Ne] = NE_EXPR;
6006 gnu_codes[N_Op_Lt] = LT_EXPR;
6007 gnu_codes[N_Op_Le] = LE_EXPR;
6008 gnu_codes[N_Op_Gt] = GT_EXPR;
6009 gnu_codes[N_Op_Ge] = GE_EXPR;
6010 gnu_codes[N_Op_Add] = PLUS_EXPR;
6011 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
6012 gnu_codes[N_Op_Multiply] = MULT_EXPR;
6013 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
6014 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
6015 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
6016 gnu_codes[N_Op_Abs] = ABS_EXPR;
6017 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
6018 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
6019 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
6020 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
6021 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
6022 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
6025 #include "gt-ada-trans.h"