1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
9 * Copyright (C) 1992-2004, Free Software Foundation, Inc. *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
22 * GNAT was originally developed by the GNAT team at New York University. *
23 * Extensive contributions were provided by Ada Core Technologies Inc. *
25 ****************************************************************************/
29 #include "coretypes.h"
59 struct Node
*Nodes_Ptr
;
60 Node_Id
*Next_Node_Ptr
;
61 Node_Id
*Prev_Node_Ptr
;
62 struct Elist_Header
*Elists_Ptr
;
63 struct Elmt_Item
*Elmts_Ptr
;
64 struct String_Entry
*Strings_Ptr
;
65 Char_Code
*String_Chars_Ptr
;
66 struct List_Header
*List_Headers_Ptr
;
68 /* Current filename without path. */
69 const char *ref_filename
;
71 /* Flag indicating whether file names are discarded in exception messages */
72 int discard_file_names
;
74 /* If true, then gigi is being called on an analyzed but unexpanded
75 tree, and the only purpose of the call is to properly annotate
76 types with representation information. */
77 int type_annotate_only
;
79 /* List of TREE_LIST nodes representing a block stack. TREE_VALUE
80 of each gives the variable used for the setjmp buffer in the current
81 block, if any. TREE_PURPOSE gives the bottom condition for a loop,
82 if this block is for a loop. The latter is only used to save the tree
86 /* List of TREE_LIST nodes representing a stack of exception pointer
87 variables. TREE_VALUE is the VAR_DECL that stores the address of
88 the raised exception. Nonzero means we are in an exception
89 handler. Not used in the zero-cost case. */
90 static GTY(()) tree gnu_except_ptr_stack
;
92 /* List of TREE_LIST nodes containing pending elaborations lists.
93 used to prevent the elaborations being reclaimed by GC. */
94 static GTY(()) tree gnu_pending_elaboration_lists
;
96 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
97 static enum tree_code gnu_codes
[Number_Node_Kinds
];
99 /* Current node being treated, in case gigi_abort called. */
100 Node_Id error_gnat_node
;
102 /* Variable that stores a list of labels to be used as a goto target instead of
103 a return in some functions. See processing for N_Subprogram_Body. */
104 static GTY(()) tree gnu_return_label_stack
;
106 static tree
tree_transform (Node_Id
);
107 static rtx
first_nondeleted_insn (rtx
);
108 static tree
build_block_stmt (List_Id
);
109 static tree
make_expr_stmt_from_rtl (rtx
, Node_Id
);
110 static void elaborate_all_entities (Node_Id
);
111 static void process_freeze_entity (Node_Id
);
112 static void process_inlined_subprograms (Node_Id
);
113 static void process_decls (List_Id
, List_Id
, Node_Id
, int, int);
114 static tree
emit_range_check (tree
, Node_Id
);
115 static tree
emit_index_check (tree
, tree
, tree
, tree
);
116 static tree
emit_check (tree
, tree
, int);
117 static tree
convert_with_check (Entity_Id
, tree
, int, int, int);
118 static int addressable_p (tree
);
119 static tree
assoc_to_constructor (Node_Id
, tree
);
120 static tree
extract_values (tree
, tree
);
121 static tree
pos_to_constructor (Node_Id
, tree
, Entity_Id
);
122 static tree
maybe_implicit_deref (tree
);
123 static tree
gnat_stabilize_reference_1 (tree
, int);
124 static int build_unit_elab (Entity_Id
, int, tree
);
126 /* Constants for +0.5 and -0.5 for float-to-integer rounding. */
127 static REAL_VALUE_TYPE dconstp5
;
128 static REAL_VALUE_TYPE dconstmp5
;
130 /* This is the main program of the back-end. It sets up all the table
131 structures and then generates code. */
134 gigi (Node_Id gnat_root
,
137 struct Node
*nodes_ptr
,
138 Node_Id
*next_node_ptr
,
139 Node_Id
*prev_node_ptr
,
140 struct Elist_Header
*elists_ptr
,
141 struct Elmt_Item
*elmts_ptr
,
142 struct String_Entry
*strings_ptr
,
143 Char_Code
*string_chars_ptr
,
144 struct List_Header
*list_headers_ptr
,
145 Int number_units ATTRIBUTE_UNUSED
,
146 char *file_info_ptr ATTRIBUTE_UNUSED
,
147 Entity_Id standard_integer
,
148 Entity_Id standard_long_long_float
,
149 Entity_Id standard_exception_type
,
150 Int gigi_operating_mode
)
152 tree gnu_standard_long_long_float
;
153 tree gnu_standard_exception_type
;
155 max_gnat_nodes
= max_gnat_node
;
156 number_names
= number_name
;
157 Nodes_Ptr
= nodes_ptr
;
158 Next_Node_Ptr
= next_node_ptr
;
159 Prev_Node_Ptr
= prev_node_ptr
;
160 Elists_Ptr
= elists_ptr
;
161 Elmts_Ptr
= elmts_ptr
;
162 Strings_Ptr
= strings_ptr
;
163 String_Chars_Ptr
= string_chars_ptr
;
164 List_Headers_Ptr
= list_headers_ptr
;
166 type_annotate_only
= (gigi_operating_mode
== 1);
168 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
170 if (type_annotate_only
)
172 TYPE_SIZE (void_type_node
) = bitsize_zero_node
;
173 TYPE_SIZE_UNIT (void_type_node
) = size_zero_node
;
176 /* See if we should discard file names in exception messages. */
177 discard_file_names
= Debug_Flag_NN
;
179 if (Nkind (gnat_root
) != N_Compilation_Unit
)
182 set_lineno (gnat_root
, 0);
184 /* Initialize ourselves. */
188 gnat_compute_largest_alignment ();
190 /* Enable GNAT stack checking method if needed */
191 if (!Stack_Check_Probes_On_Target
)
192 set_stack_check_libfunc (gen_rtx_SYMBOL_REF (Pmode
, "_gnat_stack_check"));
194 /* Save the type we made for integer as the type for Standard.Integer.
195 Then make the rest of the standard types. Note that some of these
197 save_gnu_tree (Base_Type (standard_integer
),
198 TYPE_NAME (integer_type_node
), 0);
200 gnu_except_ptr_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
202 REAL_ARITHMETIC (dconstp5
, RDIV_EXPR
, dconst1
, dconst2
);
203 REAL_ARITHMETIC (dconstmp5
, RDIV_EXPR
, dconstm1
, dconst2
);
205 gnu_standard_long_long_float
206 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
207 gnu_standard_exception_type
208 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
210 init_gigi_decls (gnu_standard_long_long_float
, gnu_standard_exception_type
);
212 /* Process any Pragma Ident for the main unit. */
213 #ifdef ASM_OUTPUT_IDENT
214 if (Present (Ident_String (Main_Unit
)))
217 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
220 /* If we are using the GCC exception mechanism, let GCC know. */
221 if (Exception_Mechanism
== GCC_ZCX
)
224 gnat_to_code (gnat_root
);
228 /* This function is the driver of the GNAT to GCC tree transformation process.
229 GNAT_NODE is the root of some gnat tree. It generates code for that
233 gnat_to_code (Node_Id gnat_node
)
237 /* Save node number in case error */
238 error_gnat_node
= gnat_node
;
240 gnu_root
= tree_transform (gnat_node
);
242 /* If we return a statement, generate code for it. */
243 if (IS_STMT (gnu_root
))
244 expand_expr_stmt (gnu_root
);
246 /* This should just generate code, not return a value. If it returns
247 a value, something is wrong. */
248 else if (gnu_root
!= error_mark_node
)
252 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
253 tree corresponding to that GNAT tree. Normally, no code is generated.
254 We just return an equivalent tree which is used elsewhere to generate
258 gnat_to_gnu (Node_Id gnat_node
)
261 bool made_sequence
= false;
263 /* We support the use of this on statements now as a transition
264 to full function-at-a-time processing. So we need to see if anything
265 we do generates RTL and returns error_mark_node. */
266 if (!global_bindings_p ())
268 do_pending_stack_adjust ();
271 emit_note (NOTE_INSN_DELETED
);
272 made_sequence
= true;
275 /* Save node number in case error */
276 error_gnat_node
= gnat_node
;
278 gnu_root
= tree_transform (gnat_node
);
280 if (gnu_root
== error_mark_node
)
284 if (type_annotate_only
)
290 do_pending_stack_adjust ();
292 gnu_root
= make_expr_stmt_from_rtl (first_nondeleted_insn (get_insns ()),
296 else if (made_sequence
)
300 do_pending_stack_adjust ();
302 insns
= first_nondeleted_insn (get_insns ());
307 /* If we have a statement, we need to first evaluate any RTL we
308 made in the process of building it and then the statement. */
309 if (IS_STMT (gnu_root
))
311 tree gnu_expr_stmt
= make_expr_stmt_from_rtl (insns
, gnat_node
);
313 TREE_CHAIN (gnu_expr_stmt
) = gnu_root
;
314 gnu_root
= build_nt (BLOCK_STMT
, gnu_expr_stmt
);
315 TREE_TYPE (gnu_root
) = void_type_node
;
316 TREE_SLOC (gnu_root
) = Sloc (gnat_node
);
326 /* This function is the driver of the GNAT to GCC tree transformation process.
327 It is the entry point of the tree transformer. GNAT_NODE is the root of
328 some GNAT tree. Return the root of the corresponding GCC tree or
329 error_mark_node to signal that there is no GCC tree to return.
331 The latter is the case if only code generation actions have to be performed
332 like in the case of if statements, loops, etc. This routine is wrapped
333 in the above two routines for most purposes. */
336 tree_transform (Node_Id gnat_node
)
338 tree gnu_result
= error_mark_node
; /* Default to no value. */
339 tree gnu_result_type
= void_type_node
;
341 tree gnu_lhs
, gnu_rhs
;
343 Entity_Id gnat_temp_type
;
345 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
346 set_lineno (gnat_node
, 0);
348 if (IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
349 && type_annotate_only
)
350 return error_mark_node
;
352 /* If this is a Statement and we are at top level, we add the statement
353 as an elaboration for a null tree. That will cause it to be placed
354 in the elaboration procedure. */
355 if (global_bindings_p ()
356 && ((IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
357 && Nkind (gnat_node
) != N_Null_Statement
)
358 || Nkind (gnat_node
) == N_Procedure_Call_Statement
359 || Nkind (gnat_node
) == N_Label
360 || (Nkind (gnat_node
) == N_Handled_Sequence_Of_Statements
361 && (Present (Exception_Handlers (gnat_node
))
362 || Present (At_End_Proc (gnat_node
))))
363 || ((Nkind (gnat_node
) == N_Raise_Constraint_Error
364 || Nkind (gnat_node
) == N_Raise_Storage_Error
365 || Nkind (gnat_node
) == N_Raise_Program_Error
)
366 && (Ekind (Etype (gnat_node
)) == E_Void
))))
368 add_pending_elaborations (NULL_TREE
, make_transform_expr (gnat_node
));
370 return error_mark_node
;
373 /* If this node is a non-static subexpression and we are only
374 annotating types, make this into a NULL_EXPR for non-VOID types
375 and error_mark_node for void return types. But allow
376 N_Identifier since we use it for lots of things, including
377 getting trees for discriminants. */
379 if (type_annotate_only
380 && IN (Nkind (gnat_node
), N_Subexpr
)
381 && Nkind (gnat_node
) != N_Identifier
382 && ! Compile_Time_Known_Value (gnat_node
))
384 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
386 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
387 return error_mark_node
;
389 return build1 (NULL_EXPR
, gnu_result_type
,
390 build_call_raise (CE_Range_Check_Failed
));
393 switch (Nkind (gnat_node
))
395 /********************************/
396 /* Chapter 2: Lexical Elements: */
397 /********************************/
400 case N_Expanded_Name
:
401 case N_Operator_Symbol
:
402 case N_Defining_Identifier
:
404 /* If the Etype of this node does not equal the Etype of the
405 Entity, something is wrong with the entity map, probably in
406 generic instantiation. However, this does not apply to
407 types. Since we sometime have strange Ekind's, just do
408 this test for objects. Also, if the Etype of the Entity is
409 private, the Etype of the N_Identifier is allowed to be the full
410 type and also we consider a packed array type to be the same as
411 the original type. Similarly, a class-wide type is equivalent
412 to a subtype of itself. Finally, if the types are Itypes,
413 one may be a copy of the other, which is also legal. */
415 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
416 ? gnat_node
: Entity (gnat_node
));
417 gnat_temp_type
= Etype (gnat_temp
);
419 if (Etype (gnat_node
) != gnat_temp_type
420 && ! (Is_Packed (gnat_temp_type
)
421 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
422 && ! (Is_Class_Wide_Type (Etype (gnat_node
)))
423 && ! (IN (Ekind (gnat_temp_type
), Private_Kind
)
424 && Present (Full_View (gnat_temp_type
))
425 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
426 || (Is_Packed (Full_View (gnat_temp_type
))
427 && Etype (gnat_node
) ==
428 Packed_Array_Type (Full_View (gnat_temp_type
)))))
429 && (!Is_Itype (Etype (gnat_node
)) || !Is_Itype (gnat_temp_type
))
430 && (Ekind (gnat_temp
) == E_Variable
431 || Ekind (gnat_temp
) == E_Component
432 || Ekind (gnat_temp
) == E_Constant
433 || Ekind (gnat_temp
) == E_Loop_Parameter
434 || IN (Ekind (gnat_temp
), Formal_Kind
)))
437 /* If this is a reference to a deferred constant whose partial view
438 is an unconstrained private type, the proper type is on the full
439 view of the constant, not on the full view of the type, which may
442 This may be a reference to a type, for example in the prefix of the
443 attribute Position, generated for dispatching code (see Make_DT in
444 exp_disp,adb). In that case we need the type itself, not is parent,
445 in particular if it is a derived type */
447 if (Is_Private_Type (gnat_temp_type
)
448 && Has_Unknown_Discriminants (gnat_temp_type
)
449 && Present (Full_View (gnat_temp
))
450 && ! Is_Type (gnat_temp
))
452 gnat_temp
= Full_View (gnat_temp
);
453 gnat_temp_type
= Etype (gnat_temp
);
454 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
458 /* Expand the type of this identitier first, in case it is
459 an enumeral literal, which only get made when the type
460 is expanded. There is no order-of-elaboration issue here.
461 We want to use the Actual_Subtype if it has already been
462 elaborated, otherwise the Etype. Avoid using Actual_Subtype
463 for packed arrays to simplify things. */
464 if ((Ekind (gnat_temp
) == E_Constant
465 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
466 && ! (Is_Array_Type (Etype (gnat_temp
))
467 && Present (Packed_Array_Type (Etype (gnat_temp
))))
468 && Present (Actual_Subtype (gnat_temp
))
469 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
470 gnat_temp_type
= Actual_Subtype (gnat_temp
);
472 gnat_temp_type
= Etype (gnat_node
);
474 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
477 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
479 /* If we are in an exception handler, force this variable into memory
480 to ensure optimization does not remove stores that appear
481 redundant but are actually needed in case an exception occurs.
483 ??? Note that we need not do this if the variable is declared within
484 the handler, only if it is referenced in the handler and declared
485 in an enclosing block, but we have no way of testing that
487 if (TREE_VALUE (gnu_except_ptr_stack
) != 0)
489 gnat_mark_addressable (gnu_result
);
490 flush_addressof (gnu_result
);
493 /* Some objects (such as parameters passed by reference, globals of
494 variable size, and renamed objects) actually represent the address
495 of the object. In that case, we must do the dereference. Likewise,
496 deal with parameters to foreign convention subprograms. Call fold
497 here since GNU_RESULT may be a CONST_DECL. */
498 if (DECL_P (gnu_result
)
499 && (DECL_BY_REF_P (gnu_result
)
500 || (TREE_CODE (gnu_result
) == PARM_DECL
501 && DECL_BY_COMPONENT_PTR_P (gnu_result
))))
503 int ro
= DECL_POINTS_TO_READONLY_P (gnu_result
);
505 if (TREE_CODE (gnu_result
) == PARM_DECL
506 && DECL_BY_COMPONENT_PTR_P (gnu_result
))
507 gnu_result
= convert (build_pointer_type (gnu_result_type
),
510 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
512 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
) = ro
;
515 /* The GNAT tree has the type of a function as the type of its result.
516 Also use the type of the result if the Etype is a subtype which
517 is nominally unconstrained. But remove any padding from the
519 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
520 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
522 gnu_result_type
= TREE_TYPE (gnu_result
);
523 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
524 && TYPE_IS_PADDING_P (gnu_result_type
))
525 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
528 /* We always want to return the underlying INTEGER_CST for an
529 enumeration literal to avoid the need to call fold in lots
530 of places. But don't do this is the parent will be taking
531 the address of this object. */
532 if (TREE_CODE (gnu_result
) == CONST_DECL
)
534 gnat_temp
= Parent (gnat_node
);
535 if (DECL_CONST_CORRESPONDING_VAR (gnu_result
) == 0
536 || (Nkind (gnat_temp
) != N_Reference
537 && ! (Nkind (gnat_temp
) == N_Attribute_Reference
538 && ((Get_Attribute_Id (Attribute_Name (gnat_temp
))
540 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
542 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
543 == Attr_Unchecked_Access
)
544 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
545 == Attr_Unrestricted_Access
)))))
546 gnu_result
= DECL_INITIAL (gnu_result
);
550 case N_Integer_Literal
:
554 /* Get the type of the result, looking inside any padding and
555 left-justified modular types. Then get the value in that type. */
556 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
558 if (TREE_CODE (gnu_type
) == RECORD_TYPE
559 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
560 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
562 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
564 /* If the result overflows (meaning it doesn't fit in its base type),
565 abort. We would like to check that the value is within the range
566 of the subtype, but that causes problems with subtypes whose usage
567 will raise Constraint_Error and with biased representation, so
569 if (TREE_CONSTANT_OVERFLOW (gnu_result
))
574 case N_Character_Literal
:
575 /* If a Entity is present, it means that this was one of the
576 literals in a user-defined character type. In that case,
577 just return the value in the CONST_DECL. Otherwise, use the
578 character code. In that case, the base type should be an
579 INTEGER_TYPE, but we won't bother checking for that. */
580 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
581 if (Present (Entity (gnat_node
)))
582 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
584 gnu_result
= convert (gnu_result_type
,
585 build_int_2 (Char_Literal_Value (gnat_node
), 0));
589 /* If this is of a fixed-point type, the value we want is the
590 value of the corresponding integer. */
591 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
593 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
594 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
596 if (TREE_CONSTANT_OVERFLOW (gnu_result
))
600 /* We should never see a Vax_Float type literal, since the front end
601 is supposed to transform these using appropriate conversions */
602 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
607 Ureal ur_realval
= Realval (gnat_node
);
609 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
611 /* If the real value is zero, so is the result. Otherwise,
612 convert it to a machine number if it isn't already. That
613 forces BASE to 0 or 2 and simplifies the rest of our logic. */
614 if (UR_Is_Zero (ur_realval
))
615 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
618 if (! Is_Machine_Number (gnat_node
))
620 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
621 ur_realval
, Round_Even
, gnat_node
);
624 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
626 /* If we have a base of zero, divide by the denominator.
627 Otherwise, the base must be 2 and we scale the value, which
628 we know can fit in the mantissa of the type (hence the use
629 of that type above). */
630 if (Rbase (ur_realval
) == 0)
632 = build_binary_op (RDIV_EXPR
,
633 get_base_type (gnu_result_type
),
635 UI_To_gnu (Denominator (ur_realval
),
637 else if (Rbase (ur_realval
) != 2)
644 real_ldexp (&tmp
, &TREE_REAL_CST (gnu_result
),
645 - UI_To_Int (Denominator (ur_realval
)));
646 gnu_result
= build_real (gnu_result_type
, tmp
);
650 /* Now see if we need to negate the result. Do it this way to
651 properly handle -0. */
652 if (UR_Is_Negative (Realval (gnat_node
)))
654 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
660 case N_String_Literal
:
661 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
662 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
664 /* We assume here that all strings are of type standard.string.
665 "Weird" types of string have been converted to an aggregate
667 String_Id gnat_string
= Strval (gnat_node
);
668 int length
= String_Length (gnat_string
);
669 char *string
= (char *) alloca (length
+ 1);
672 /* Build the string with the characters in the literal. Note
673 that Ada strings are 1-origin. */
674 for (i
= 0; i
< length
; i
++)
675 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
677 /* Put a null at the end of the string in case it's in a context
678 where GCC will want to treat it as a C string. */
681 gnu_result
= build_string (length
, string
);
683 /* Strings in GCC don't normally have types, but we want
684 this to not be converted to the array type. */
685 TREE_TYPE (gnu_result
) = gnu_result_type
;
689 /* Build a list consisting of each character, then make
691 String_Id gnat_string
= Strval (gnat_node
);
692 int length
= String_Length (gnat_string
);
694 tree gnu_list
= NULL_TREE
;
696 for (i
= 0; i
< length
; i
++)
698 = tree_cons (NULL_TREE
,
699 convert (TREE_TYPE (gnu_result_type
),
700 build_int_2 (Get_String_Char (gnat_string
,
706 = gnat_build_constructor (gnu_result_type
, nreverse (gnu_list
));
711 if (type_annotate_only
)
714 /* Check for (and ignore) unrecognized pragma */
715 if (! Is_Pragma_Name (Chars (gnat_node
)))
718 switch (Get_Pragma_Id (Chars (gnat_node
)))
720 case Pragma_Inspection_Point
:
721 /* Do nothing at top level: all such variables are already
723 if (global_bindings_p ())
726 set_lineno (gnat_node
, 1);
727 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
729 gnat_temp
= Next (gnat_temp
))
731 gnu_expr
= gnat_to_gnu (Expression (gnat_temp
));
732 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
733 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
735 gnu_expr
= build1 (USE_EXPR
, void_type_node
, gnu_expr
);
736 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
737 expand_expr_stmt (gnu_expr
);
741 case Pragma_Optimize
:
742 switch (Chars (Expression
743 (First (Pragma_Argument_Associations (gnat_node
)))))
745 case Name_Time
: case Name_Space
:
747 post_error ("insufficient -O value?", gnat_node
);
752 post_error ("must specify -O0?", gnat_node
);
761 case Pragma_Reviewable
:
762 if (write_symbols
== NO_DEBUG
)
763 post_error ("must specify -g?", gnat_node
);
768 /**************************************/
769 /* Chapter 3: Declarations and Types: */
770 /**************************************/
772 case N_Subtype_Declaration
:
773 case N_Full_Type_Declaration
:
774 case N_Incomplete_Type_Declaration
:
775 case N_Private_Type_Declaration
:
776 case N_Private_Extension_Declaration
:
777 case N_Task_Type_Declaration
:
778 process_type (Defining_Entity (gnat_node
));
781 case N_Object_Declaration
:
782 case N_Exception_Declaration
:
783 gnat_temp
= Defining_Entity (gnat_node
);
785 /* If we are just annotating types and this object has an unconstrained
786 or task type, don't elaborate it. */
787 if (type_annotate_only
788 && (((Is_Array_Type (Etype (gnat_temp
))
789 || Is_Record_Type (Etype (gnat_temp
)))
790 && ! Is_Constrained (Etype (gnat_temp
)))
791 || Is_Concurrent_Type (Etype (gnat_temp
))))
794 if (Present (Expression (gnat_node
))
795 && ! (Nkind (gnat_node
) == N_Object_Declaration
796 && No_Initialization (gnat_node
))
797 && (! type_annotate_only
798 || Compile_Time_Known_Value (Expression (gnat_node
))))
800 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
801 if (Do_Range_Check (Expression (gnat_node
)))
802 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_temp
));
804 /* If this object has its elaboration delayed, we must force
805 evaluation of GNU_EXPR right now and save it for when the object
807 if (Present (Freeze_Node (gnat_temp
)))
809 if ((Is_Public (gnat_temp
) || global_bindings_p ())
810 && ! TREE_CONSTANT (gnu_expr
))
812 = create_var_decl (create_concat_name (gnat_temp
, "init"),
813 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
814 0, Is_Public (gnat_temp
), 0, 0, 0);
816 gnu_expr
= maybe_variable (gnu_expr
, Expression (gnat_node
));
818 save_gnu_tree (gnat_node
, gnu_expr
, 1);
824 if (type_annotate_only
&& gnu_expr
!= 0
825 && TREE_CODE (gnu_expr
) == ERROR_MARK
)
828 if (No (Freeze_Node (gnat_temp
)))
829 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
832 case N_Object_Renaming_Declaration
:
834 gnat_temp
= Defining_Entity (gnat_node
);
836 /* Don't do anything if this renaming is handled by the front end.
837 or if we are just annotating types and this object has a
838 composite or task type, don't elaborate it. */
839 if (! Is_Renaming_Of_Object (gnat_temp
)
840 && ! (type_annotate_only
841 && (Is_Array_Type (Etype (gnat_temp
))
842 || Is_Record_Type (Etype (gnat_temp
))
843 || Is_Concurrent_Type (Etype (gnat_temp
)))))
845 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_temp
));
846 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
850 case N_Implicit_Label_Declaration
:
851 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
854 case N_Exception_Renaming_Declaration
:
855 case N_Number_Declaration
:
856 case N_Package_Renaming_Declaration
:
857 case N_Subprogram_Renaming_Declaration
:
858 /* These are fully handled in the front end. */
861 /*************************************/
862 /* Chapter 4: Names and Expressions: */
863 /*************************************/
865 case N_Explicit_Dereference
:
866 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
867 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
868 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
871 case N_Indexed_Component
:
873 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
877 Node_Id
*gnat_expr_array
;
879 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
880 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
882 /* If we got a padded type, remove it too. */
883 if (TREE_CODE (TREE_TYPE (gnu_array_object
)) == RECORD_TYPE
884 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
886 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
889 gnu_result
= gnu_array_object
;
891 /* First compute the number of dimensions of the array, then
892 fill the expression array, the order depending on whether
893 this is a Convention_Fortran array or not. */
894 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
895 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
896 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
897 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
900 gnat_expr_array
= (Node_Id
*) alloca (ndim
* sizeof (Node_Id
));
902 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
903 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
905 i
--, gnat_temp
= Next (gnat_temp
))
906 gnat_expr_array
[i
] = gnat_temp
;
908 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
910 i
++, gnat_temp
= Next (gnat_temp
))
911 gnat_expr_array
[i
] = gnat_temp
;
913 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
914 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
916 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
919 gnat_temp
= gnat_expr_array
[i
];
920 gnu_expr
= gnat_to_gnu (gnat_temp
);
922 if (Do_Range_Check (gnat_temp
))
925 (gnu_array_object
, gnu_expr
,
926 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
927 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
929 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
930 gnu_result
, gnu_expr
);
934 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
940 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
942 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
943 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
945 /* Do any implicit dereferences of the prefix and do any needed
947 gnu_result
= maybe_implicit_deref (gnu_result
);
948 gnu_result
= maybe_unconstrained_array (gnu_result
);
949 gnu_type
= TREE_TYPE (gnu_result
);
950 if (Do_Range_Check (gnat_range_node
))
952 /* Get the bounds of the slice. */
954 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
955 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
956 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
957 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
959 /* Check to see that the minimum slice value is in range */
962 (gnu_result
, gnu_min_expr
,
963 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
964 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
966 /* Check to see that the maximum slice value is in range */
969 (gnu_result
, gnu_max_expr
,
970 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
971 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
973 /* Derive a good type to convert everything too */
974 gnu_expr_type
= get_base_type (TREE_TYPE (gnu_expr_l
));
976 /* Build a compound expression that does the range checks */
978 = build_binary_op (COMPOUND_EXPR
, gnu_expr_type
,
979 convert (gnu_expr_type
, gnu_expr_h
),
980 convert (gnu_expr_type
, gnu_expr_l
));
982 /* Build a conditional expression that returns the range checks
983 expression if the slice range is not null (max >= min) or
984 returns the min if the slice range is null */
986 = fold (build (COND_EXPR
, gnu_expr_type
,
987 build_binary_op (GE_EXPR
, gnu_expr_type
,
988 convert (gnu_expr_type
,
990 convert (gnu_expr_type
,
992 gnu_expr
, gnu_min_expr
));
995 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
997 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
998 gnu_result
, gnu_expr
);
1002 case N_Selected_Component
:
1004 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1005 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
1006 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
1009 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
1010 || IN (Ekind (gnat_pref_type
), Access_Kind
))
1012 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
1013 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
1014 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
1015 gnat_pref_type
= Designated_Type (gnat_pref_type
);
1018 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1020 /* For discriminant references in tagged types always substitute the
1021 corresponding discriminant as the actual selected component. */
1023 if (Is_Tagged_Type (gnat_pref_type
))
1024 while (Present (Corresponding_Discriminant (gnat_field
)))
1025 gnat_field
= Corresponding_Discriminant (gnat_field
);
1027 /* For discriminant references of untagged types always substitute the
1028 corresponding stored discriminant. */
1030 else if (Present (Corresponding_Discriminant (gnat_field
)))
1031 gnat_field
= Original_Record_Component (gnat_field
);
1033 /* Handle extracting the real or imaginary part of a complex.
1034 The real part is the first field and the imaginary the last. */
1036 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
1037 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
1038 ? REALPART_EXPR
: IMAGPART_EXPR
,
1039 NULL_TREE
, gnu_prefix
);
1042 gnu_field
= gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0);
1044 /* If there are discriminants, the prefix might be
1045 evaluated more than once, which is a problem if it has
1047 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
1048 ? Designated_Type (Etype
1049 (Prefix (gnat_node
)))
1050 : Etype (Prefix (gnat_node
))))
1051 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, 0);
1054 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
,
1055 (Nkind (Parent (gnat_node
))
1056 == N_Attribute_Reference
));
1059 if (gnu_result
== 0)
1062 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1066 case N_Attribute_Reference
:
1068 /* The attribute designator (like an enumeration value). */
1069 int attribute
= Get_Attribute_Id (Attribute_Name (gnat_node
));
1070 int prefix_unused
= 0;
1074 /* The Elab_Spec and Elab_Body attributes are special in that
1075 Prefix is a unit, not an object with a GCC equivalent. Similarly
1076 for Elaborated, since that variable isn't otherwise known. */
1077 if (attribute
== Attr_Elab_Body
|| attribute
== Attr_Elab_Spec
)
1080 = create_subprog_decl
1081 (create_concat_name (Entity (Prefix (gnat_node
)),
1082 attribute
== Attr_Elab_Body
1083 ? "elabb" : "elabs"),
1084 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 1, 0);
1088 gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1089 gnu_type
= TREE_TYPE (gnu_prefix
);
1091 /* If the input is a NULL_EXPR, make a new one. */
1092 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1094 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1095 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
,
1096 TREE_OPERAND (gnu_prefix
, 0));
1104 /* These are just conversions until since representation
1105 clauses for enumerations are handled in the front end. */
1107 int check_p
= Do_Range_Check (First (Expressions (gnat_node
)));
1109 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1110 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1111 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1112 check_p
, check_p
, 1);
1118 /* These just add or subject the constant 1. Representation
1119 clauses for enumerations are handled in the front-end. */
1120 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1121 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1123 if (Do_Range_Check (First (Expressions (gnat_node
))))
1125 gnu_expr
= protect_multiple_eval (gnu_expr
);
1128 (build_binary_op (EQ_EXPR
, integer_type_node
,
1130 attribute
== Attr_Pred
1131 ? TYPE_MIN_VALUE (gnu_result_type
)
1132 : TYPE_MAX_VALUE (gnu_result_type
)),
1133 gnu_expr
, CE_Range_Check_Failed
);
1137 = build_binary_op (attribute
== Attr_Pred
1138 ? MINUS_EXPR
: PLUS_EXPR
,
1139 gnu_result_type
, gnu_expr
,
1140 convert (gnu_result_type
, integer_one_node
));
1144 case Attr_Unrestricted_Access
:
1146 /* Conversions don't change something's address but can cause
1147 us to miss the COMPONENT_REF case below, so strip them off. */
1149 = remove_conversions (gnu_prefix
,
1150 ! Must_Be_Byte_Aligned (gnat_node
));
1152 /* If we are taking 'Address of an unconstrained object,
1153 this is the pointer to the underlying array. */
1154 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1156 /* ... fall through ... */
1159 case Attr_Unchecked_Access
:
1160 case Attr_Code_Address
:
1162 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1164 = build_unary_op (((attribute
== Attr_Address
1165 || attribute
== Attr_Unrestricted_Access
)
1166 && ! Must_Be_Byte_Aligned (gnat_node
))
1167 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1168 gnu_result_type
, gnu_prefix
);
1170 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1171 so that we don't try to build a trampoline. */
1172 if (attribute
== Attr_Code_Address
)
1174 for (gnu_expr
= gnu_result
;
1175 TREE_CODE (gnu_expr
) == NOP_EXPR
1176 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
1177 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
1178 TREE_CONSTANT (gnu_expr
) = 1;
1181 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1182 TREE_STATIC (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1187 case Attr_Pool_Address
:
1190 tree gnu_ptr
= gnu_prefix
;
1192 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1194 /* If this is an unconstrained array, we know the object must
1195 have been allocated with the template in front of the object.
1196 So compute the template address.*/
1198 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
1200 = convert (build_pointer_type
1201 (TYPE_OBJECT_RECORD_TYPE
1202 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
1205 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
1206 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
1207 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
1209 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
1210 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
1211 tree gnu_byte_offset
1212 = convert (gnu_char_ptr_type
,
1213 size_diffop (size_zero_node
, gnu_pos
));
1215 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
1216 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
1217 gnu_ptr
, gnu_byte_offset
);
1220 gnu_result
= convert (gnu_result_type
, gnu_ptr
);
1225 case Attr_Object_Size
:
1226 case Attr_Value_Size
:
1227 case Attr_Max_Size_In_Storage_Elements
:
1229 gnu_expr
= gnu_prefix
;
1231 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1232 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1233 while (TREE_CODE (gnu_expr
) == NOP_EXPR
)
1234 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1236 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1238 gnu_type
= TREE_TYPE (gnu_prefix
);
1240 /* Replace an unconstrained array type with the type of the
1241 underlying array. We can't do this with a call to
1242 maybe_unconstrained_array since we may have a TYPE_DECL.
1243 For 'Max_Size_In_Storage_Elements, use the record type
1244 that will be used to allocate the object and its template. */
1246 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1248 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1249 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1250 gnu_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)));
1253 /* If we are looking for the size of a field, return the
1254 field size. Otherwise, if the prefix is an object,
1255 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1256 been specified, the result is the GCC size of the type.
1257 Otherwise, the result is the RM_Size of the type. */
1258 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1259 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1260 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1261 || attribute
== Attr_Object_Size
1262 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1264 /* If this is a padded type, the GCC size isn't relevant
1265 to the programmer. Normally, what we want is the RM_Size,
1266 which was set from the specified size, but if it was not
1267 set, we want the size of the relevant field. Using the MAX
1268 of those two produces the right result in all case. Don't
1269 use the size of the field if it's a self-referential type,
1270 since that's never what's wanted. */
1271 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1272 && TYPE_IS_PADDING_P (gnu_type
)
1273 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
1275 gnu_result
= rm_size (gnu_type
);
1276 if (! (CONTAINS_PLACEHOLDER_P
1277 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)))))
1279 = size_binop (MAX_EXPR
, gnu_result
,
1280 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
1283 gnu_result
= TYPE_SIZE (gnu_type
);
1286 gnu_result
= rm_size (gnu_type
);
1288 if (gnu_result
== 0)
1291 /* Deal with a self-referential size by returning the maximum
1292 size for a type and by qualifying the size with
1293 the object for 'Size of an object. */
1295 if (CONTAINS_PLACEHOLDER_P (gnu_result
))
1297 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1298 gnu_result
= substitute_placeholder_in_expr (gnu_result
,
1301 gnu_result
= max_size (gnu_result
, 1);
1304 /* If the type contains a template, subtract the size of the
1306 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1307 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1308 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1309 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1311 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1313 /* Always perform division using unsigned arithmetic as the
1314 size cannot be negative, but may be an overflowed positive
1315 value. This provides correct results for sizes up to 512 MB.
1316 ??? Size should be calculated in storage elements directly. */
1318 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1319 gnu_result
= convert (sizetype
,
1320 fold (build (CEIL_DIV_EXPR
, bitsizetype
,
1322 bitsize_unit_node
)));
1325 case Attr_Alignment
:
1326 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1327 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1329 && (TYPE_IS_PADDING_P
1330 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1331 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1333 gnu_type
= TREE_TYPE (gnu_prefix
);
1334 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1337 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1339 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)));
1341 gnu_result
= size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
);
1346 case Attr_Range_Length
:
1349 if (INTEGRAL_TYPE_P (gnu_type
)
1350 || TREE_CODE (gnu_type
) == REAL_TYPE
)
1352 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1354 if (attribute
== Attr_First
)
1355 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1356 else if (attribute
== Attr_Last
)
1357 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1361 (MAX_EXPR
, get_base_type (gnu_result_type
),
1363 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1364 build_binary_op (MINUS_EXPR
,
1365 get_base_type (gnu_result_type
),
1366 convert (gnu_result_type
,
1367 TYPE_MAX_VALUE (gnu_type
)),
1368 convert (gnu_result_type
,
1369 TYPE_MIN_VALUE (gnu_type
))),
1370 convert (gnu_result_type
, integer_one_node
)),
1371 convert (gnu_result_type
, integer_zero_node
));
1375 /* ... fall through ... */
1379 = (Present (Expressions (gnat_node
))
1380 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1383 /* Make sure any implicit dereference gets done. */
1384 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1385 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1386 gnu_type
= TREE_TYPE (gnu_prefix
);
1388 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1390 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1395 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1396 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1397 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1398 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1401 Dimension
= ndim
+ 1 - Dimension
;
1404 for (; Dimension
> 1; Dimension
--)
1405 gnu_type
= TREE_TYPE (gnu_type
);
1407 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1410 if (attribute
== Attr_First
)
1412 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1413 else if (attribute
== Attr_Last
)
1415 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1417 /* 'Length or 'Range_Length. */
1419 tree gnu_compute_type
1420 = gnat_signed_or_unsigned_type
1421 (0, get_base_type (gnu_result_type
));
1425 (MAX_EXPR
, gnu_compute_type
,
1427 (PLUS_EXPR
, gnu_compute_type
,
1429 (MINUS_EXPR
, gnu_compute_type
,
1430 convert (gnu_compute_type
,
1432 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)))),
1433 convert (gnu_compute_type
,
1435 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))))),
1436 convert (gnu_compute_type
, integer_one_node
)),
1437 convert (gnu_compute_type
, integer_zero_node
));
1440 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1441 we are handling. Note that these attributes could not
1442 have been used on an unconstrained array type. */
1443 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
,
1449 case Attr_Bit_Position
:
1451 case Attr_First_Bit
:
1455 HOST_WIDE_INT bitsize
;
1456 HOST_WIDE_INT bitpos
;
1458 tree gnu_field_bitpos
;
1459 tree gnu_field_offset
;
1461 enum machine_mode mode
;
1462 int unsignedp
, volatilep
;
1464 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1465 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1468 /* We can have 'Bit on any object, but if it isn't a
1469 COMPONENT_REF, the result is zero. Do not allow
1470 'Bit on a bare component, though. */
1471 if (attribute
== Attr_Bit
1472 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1473 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1475 gnu_result
= integer_zero_node
;
1479 else if (TREE_CODE (gnu_prefix
) != COMPONENT_REF
1480 && ! (attribute
== Attr_Bit_Position
1481 && TREE_CODE (gnu_prefix
) == FIELD_DECL
))
1484 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1485 &mode
, &unsignedp
, &volatilep
);
1487 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1490 = bit_position (TREE_OPERAND (gnu_prefix
, 1));
1492 = byte_position (TREE_OPERAND (gnu_prefix
, 1));
1494 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1495 TREE_CODE (gnu_inner
) == COMPONENT_REF
1496 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1497 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1500 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1501 bit_position (TREE_OPERAND (gnu_inner
,
1504 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1505 byte_position (TREE_OPERAND (gnu_inner
,
1509 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1511 gnu_field_bitpos
= bit_position (gnu_prefix
);
1512 gnu_field_offset
= byte_position (gnu_prefix
);
1516 gnu_field_bitpos
= bitsize_zero_node
;
1517 gnu_field_offset
= size_zero_node
;
1523 gnu_result
= gnu_field_offset
;
1526 case Attr_First_Bit
:
1528 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1532 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1534 = size_binop (PLUS_EXPR
, gnu_result
,
1535 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1536 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1540 case Attr_Bit_Position
:
1541 gnu_result
= gnu_field_bitpos
;
1545 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1547 gnu_result
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result
,
1555 gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1556 gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1558 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1559 gnu_result
= build_binary_op (attribute
== Attr_Min
1560 ? MIN_EXPR
: MAX_EXPR
,
1561 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1564 case Attr_Passed_By_Reference
:
1565 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1566 || must_pass_by_ref (gnu_type
));
1567 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1570 case Attr_Component_Size
:
1571 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1572 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1574 && (TYPE_IS_PADDING_P
1575 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1576 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1578 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1579 gnu_type
= TREE_TYPE (gnu_prefix
);
1581 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1583 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1585 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1586 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1587 gnu_type
= TREE_TYPE (gnu_type
);
1589 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1592 /* Note this size cannot be self-referential. */
1593 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1594 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1598 case Attr_Null_Parameter
:
1599 /* This is just a zero cast to the pointer type for
1600 our prefix and dereferenced. */
1601 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1603 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1604 convert (build_pointer_type (gnu_result_type
),
1605 integer_zero_node
));
1606 TREE_PRIVATE (gnu_result
) = 1;
1609 case Attr_Mechanism_Code
:
1612 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1615 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1616 if (Present (Expressions (gnat_node
)))
1618 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1620 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1621 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1625 code
= Mechanism (gnat_obj
);
1626 if (code
== Default
)
1627 code
= ((present_gnu_tree (gnat_obj
)
1628 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1629 || ((TREE_CODE (get_gnu_tree (gnat_obj
))
1631 && (DECL_BY_COMPONENT_PTR_P
1632 (get_gnu_tree (gnat_obj
))))))
1633 ? By_Reference
: By_Copy
);
1634 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1639 /* Say we have an unimplemented attribute. Then set the
1640 value to be returned to be a zero and hope that's something
1641 we can convert to the type of this attribute. */
1643 post_error ("unimplemented attribute", gnat_node
);
1644 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1645 gnu_result
= integer_zero_node
;
1649 /* If this is an attribute where the prefix was unused,
1650 force a use of it if it has a side-effect. But don't do it if
1651 the prefix is just an entity name. However, if an access check
1652 is needed, we must do it. See second example in AARM 11.6(5.e). */
1653 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
)
1654 && ! Is_Entity_Name (Prefix (gnat_node
)))
1655 gnu_result
= fold (build (COMPOUND_EXPR
, TREE_TYPE (gnu_result
),
1656 gnu_prefix
, gnu_result
));
1661 /* Like 'Access as far as we are concerned. */
1662 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
1663 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
1664 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1668 case N_Extension_Aggregate
:
1672 /* ??? It is wrong to evaluate the type now, but there doesn't
1673 seem to be any other practical way of doing it. */
1675 gnu_aggr_type
= gnu_result_type
1676 = get_unpadded_type (Etype (gnat_node
));
1678 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
1679 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
1681 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type
)));
1683 if (Null_Record_Present (gnat_node
))
1684 gnu_result
= gnat_build_constructor (gnu_aggr_type
, NULL_TREE
);
1686 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
)
1688 = assoc_to_constructor (First (Component_Associations (gnat_node
)),
1690 else if (TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
1692 /* The first element is the discrimant, which we ignore. The
1693 next is the field we're building. Convert the expression
1694 to the type of the field and then to the union type. */
1696 = Next (First (Component_Associations (gnat_node
)));
1697 Entity_Id gnat_field
= Entity (First (Choices (gnat_assoc
)));
1699 = TREE_TYPE (gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0));
1701 gnu_result
= convert (gnu_field_type
,
1702 gnat_to_gnu (Expression (gnat_assoc
)));
1704 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
1705 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
1707 Component_Type (Etype (gnat_node
)));
1708 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
1711 (COMPLEX_EXPR
, gnu_aggr_type
,
1712 gnat_to_gnu (Expression (First
1713 (Component_Associations (gnat_node
)))),
1714 gnat_to_gnu (Expression
1716 (First (Component_Associations (gnat_node
))))));
1720 gnu_result
= convert (gnu_result_type
, gnu_result
);
1725 gnu_result
= null_pointer_node
;
1726 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1729 case N_Type_Conversion
:
1730 case N_Qualified_Expression
:
1731 /* Get the operand expression. */
1732 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1733 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1736 = convert_with_check (Etype (gnat_node
), gnu_result
,
1737 Do_Overflow_Check (gnat_node
),
1738 Do_Range_Check (Expression (gnat_node
)),
1739 Nkind (gnat_node
) == N_Type_Conversion
1740 && Float_Truncate (gnat_node
));
1743 case N_Unchecked_Type_Conversion
:
1744 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1745 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1747 /* If the result is a pointer type, see if we are improperly
1748 converting to a stricter alignment. */
1750 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
1751 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
1753 unsigned int align
= known_alignment (gnu_result
);
1754 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
1755 unsigned int oalign
= TYPE_ALIGN (gnu_obj_type
);
1757 if (align
!= 0 && align
< oalign
&& ! TYPE_ALIGN_OK (gnu_obj_type
))
1758 post_error_ne_tree_2
1759 ("?source alignment (^) < alignment of & (^)",
1760 gnat_node
, Designated_Type (Etype (gnat_node
)),
1761 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
1764 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
,
1765 No_Truncation (gnat_node
));
1771 tree gnu_object
= gnat_to_gnu (Left_Opnd (gnat_node
));
1772 Node_Id gnat_range
= Right_Opnd (gnat_node
);
1776 /* GNAT_RANGE is either an N_Range node or an identifier
1777 denoting a subtype. */
1778 if (Nkind (gnat_range
) == N_Range
)
1780 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
1781 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
1783 else if (Nkind (gnat_range
) == N_Identifier
1784 || Nkind (gnat_range
) == N_Expanded_Name
)
1786 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
1788 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
1789 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
1794 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1796 /* If LOW and HIGH are identical, perform an equality test.
1797 Otherwise, ensure that GNU_OBJECT is only evaluated once
1798 and perform a full range test. */
1799 if (operand_equal_p (gnu_low
, gnu_high
, 0))
1800 gnu_result
= build_binary_op (EQ_EXPR
, gnu_result_type
,
1801 gnu_object
, gnu_low
);
1804 gnu_object
= protect_multiple_eval (gnu_object
);
1806 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
,
1807 build_binary_op (GE_EXPR
, gnu_result_type
,
1808 gnu_object
, gnu_low
),
1809 build_binary_op (LE_EXPR
, gnu_result_type
,
1810 gnu_object
, gnu_high
));
1813 if (Nkind (gnat_node
) == N_Not_In
)
1814 gnu_result
= invert_truthvalue (gnu_result
);
1819 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1820 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1821 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1822 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
1824 : (Rounded_Result (gnat_node
)
1825 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
1826 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1829 case N_And_Then
: case N_Or_Else
:
1831 /* Some processing below (e.g. clear_last_expr) requires access to
1832 status fields now maintained in the current function context, so
1833 we'll setup a dummy one if needed. We cannot use global_binding_p,
1834 since it might be true due to force_global and making a dummy
1835 context would kill the current function context. */
1836 bool make_dummy_context
= (cfun
== 0);
1837 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1840 if (make_dummy_context
)
1841 init_dummy_function_start ();
1843 /* The elaboration of the RHS may generate code. If so,
1844 we need to make sure it gets executed after the LHS. */
1845 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1848 gnu_rhs_side
= expand_start_stmt_expr (1 /*has_scope*/);
1849 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1850 expand_end_stmt_expr (gnu_rhs_side
);
1852 if (make_dummy_context
)
1853 expand_dummy_function_end ();
1855 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1857 if (first_nondeleted_insn (RTL_EXPR_SEQUENCE (gnu_rhs_side
)))
1858 gnu_rhs
= build (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs_side
,
1861 gnu_result
= build_binary_op (code
, gnu_result_type
, gnu_lhs
, gnu_rhs
);
1865 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
1866 /* These can either be operations on booleans or on modular types.
1867 Fall through for boolean types since that's the way GNU_CODES is
1869 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
1870 Modular_Integer_Kind
))
1873 = (Nkind (gnat_node
) == N_Op_Or
? BIT_IOR_EXPR
1874 : Nkind (gnat_node
) == N_Op_And
? BIT_AND_EXPR
1877 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1878 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1879 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1880 gnu_result
= build_binary_op (code
, gnu_result_type
,
1885 /* ... fall through ... */
1887 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
1888 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
1889 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
1890 case N_Op_Mod
: case N_Op_Rem
:
1891 case N_Op_Rotate_Left
:
1892 case N_Op_Rotate_Right
:
1893 case N_Op_Shift_Left
:
1894 case N_Op_Shift_Right
:
1895 case N_Op_Shift_Right_Arithmetic
:
1897 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1900 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1901 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1902 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1904 /* If this is a comparison operator, convert any references to
1905 an unconstrained array value into a reference to the
1907 if (TREE_CODE_CLASS (code
) == '<')
1909 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
1910 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
1913 /* If the result type is a private type, its full view may be a
1914 numeric subtype. The representation we need is that of its base
1915 type, given that it is the result of an arithmetic operation. */
1916 else if (Is_Private_Type (Etype (gnat_node
)))
1917 gnu_type
= gnu_result_type
1918 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
1920 /* If this is a shift whose count is not guaranteed to be correct,
1921 we need to adjust the shift count. */
1922 if (IN (Nkind (gnat_node
), N_Op_Shift
)
1923 && ! Shift_Count_OK (gnat_node
))
1925 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
1927 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
1929 if (Nkind (gnat_node
) == N_Op_Rotate_Left
1930 || Nkind (gnat_node
) == N_Op_Rotate_Right
)
1931 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
1932 gnu_rhs
, gnu_max_shift
);
1933 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
)
1936 (MIN_EXPR
, gnu_count_type
,
1937 build_binary_op (MINUS_EXPR
,
1940 convert (gnu_count_type
,
1945 /* For right shifts, the type says what kind of shift to do,
1946 so we may need to choose a different type. */
1947 if (Nkind (gnat_node
) == N_Op_Shift_Right
1948 && ! TYPE_UNSIGNED (gnu_type
))
1949 gnu_type
= gnat_unsigned_type (gnu_type
);
1950 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
1951 && TYPE_UNSIGNED (gnu_type
))
1952 gnu_type
= gnat_signed_type (gnu_type
);
1954 if (gnu_type
!= gnu_result_type
)
1956 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
1957 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
1960 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
1962 /* If this is a logical shift with the shift count not verified,
1963 we must return zero if it is too large. We cannot compensate
1964 above in this case. */
1965 if ((Nkind (gnat_node
) == N_Op_Shift_Left
1966 || Nkind (gnat_node
) == N_Op_Shift_Right
)
1967 && ! Shift_Count_OK (gnat_node
))
1971 build_binary_op (GE_EXPR
, integer_type_node
,
1973 convert (TREE_TYPE (gnu_rhs
),
1974 TYPE_SIZE (gnu_type
))),
1975 convert (gnu_type
, integer_zero_node
),
1980 case N_Conditional_Expression
:
1982 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
1983 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1985 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
1987 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1988 gnu_result
= build_cond_expr (gnu_result_type
,
1989 gnat_truthvalue_conversion (gnu_cond
),
1990 gnu_true
, gnu_false
);
1995 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
1996 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2000 /* This case can apply to a boolean or a modular type.
2001 Fall through for a boolean operand since GNU_CODES is set
2002 up to handle this. */
2003 if (IN (Ekind (Etype (gnat_node
)), Modular_Integer_Kind
))
2005 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
2006 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2007 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
2012 /* ... fall through ... */
2014 case N_Op_Minus
: case N_Op_Abs
:
2015 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
2017 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
2018 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2020 gnu_result_type
= get_unpadded_type (Base_Type
2021 (Full_View (Etype (gnat_node
))));
2023 gnu_result
= build_unary_op (gnu_codes
[Nkind (gnat_node
)],
2024 gnu_result_type
, gnu_expr
);
2032 gnat_temp
= Expression (gnat_node
);
2034 /* The Expression operand can either be an N_Identifier or
2035 Expanded_Name, which must represent a type, or a
2036 N_Qualified_Expression, which contains both the object type and an
2037 initial value for the object. */
2038 if (Nkind (gnat_temp
) == N_Identifier
2039 || Nkind (gnat_temp
) == N_Expanded_Name
)
2040 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
2041 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
2043 Entity_Id gnat_desig_type
2044 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
2046 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
2048 gnu_init
= maybe_unconstrained_array (gnu_init
);
2049 if (Do_Range_Check (Expression (gnat_temp
)))
2050 gnu_init
= emit_range_check (gnu_init
, gnat_desig_type
);
2052 if (Is_Elementary_Type (gnat_desig_type
)
2053 || Is_Constrained (gnat_desig_type
))
2055 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
2056 gnu_init
= convert (gnu_type
, gnu_init
);
2060 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
2061 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
2062 gnu_type
= TREE_TYPE (gnu_init
);
2064 gnu_init
= convert (gnu_type
, gnu_init
);
2070 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
2071 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
2072 Procedure_To_Call (gnat_node
),
2073 Storage_Pool (gnat_node
), gnat_node
);
2077 /***************************/
2078 /* Chapter 5: Statements: */
2079 /***************************/
2082 gnu_result
= build_nt (LABEL_STMT
, gnat_to_gnu (Identifier (gnat_node
)));
2085 case N_Null_Statement
:
2088 case N_Assignment_Statement
:
2089 /* Get the LHS and RHS of the statement and convert any reference to an
2090 unconstrained array into a reference to the underlying array. */
2091 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
2093 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
2095 /* If range check is needed, emit code to generate it */
2096 if (Do_Range_Check (Expression (gnat_node
)))
2097 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)));
2099 /* If either side's type has a size that overflows, convert this
2100 into raise of Storage_Error: execution shouldn't have gotten
2102 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
2103 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs
))))
2104 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs
))) == INTEGER_CST
2105 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs
)))))
2106 gnu_result
= build_call_raise (SE_Object_Too_Large
);
2109 = build_binary_op (MODIFY_EXPR
, NULL_TREE
, gnu_lhs
, gnu_rhs
);
2111 gnu_result
= build_nt (EXPR_STMT
, gnu_result
);
2114 case N_If_Statement
:
2115 gnu_result
= NULL_TREE
;
2117 /* Make an IF_STMT for each of the "else if" parts. Avoid
2119 if (Present (Elsif_Parts (gnat_node
)))
2120 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
2121 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
2123 gnu_expr
= make_node (IF_STMT
);
2125 IF_STMT_COND (gnu_expr
) = gnat_to_gnu (Condition (gnat_temp
));
2126 IF_STMT_TRUE (gnu_expr
)
2127 = build_block_stmt (Then_Statements (gnat_temp
));
2128 IF_STMT_ELSE (gnu_expr
) = IF_STMT_ELSEIF (gnu_expr
) = NULL_TREE
;
2129 TREE_SLOC (gnu_expr
) = Sloc (Condition (gnat_temp
));
2130 TREE_CHAIN (gnu_expr
) = gnu_result
;
2131 TREE_TYPE (gnu_expr
) = void_type_node
;
2132 gnu_result
= gnu_expr
;
2135 /* Now make the IF_STMT. Also avoid non-determinism. */
2136 gnu_expr
= make_node (IF_STMT
);
2137 IF_STMT_COND (gnu_expr
) = gnat_to_gnu (Condition (gnat_node
));
2138 IF_STMT_TRUE (gnu_expr
) = build_block_stmt (Then_Statements (gnat_node
));
2139 IF_STMT_ELSEIF (gnu_expr
) = nreverse (gnu_result
);
2140 IF_STMT_ELSE (gnu_expr
) = build_block_stmt (Else_Statements (gnat_node
));
2141 gnu_result
= gnu_expr
;
2144 case N_Case_Statement
:
2147 Node_Id gnat_choice
;
2149 Node_Id gnat_statement
;
2151 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2152 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2154 /* The range of values in a case statement is determined by the
2155 rules in RM 5.4(7-9). In almost all cases, this range is
2156 represented by the Etype of the expression. One exception arises
2157 in the case of a simple name that is parenthesized. This still
2158 has the Etype of the name, but since it is not a name, para 7
2159 does not apply, and we need to go to the base type. This is the
2160 only case where parenthesization affects the dynamic semantics
2161 (i.e. the range of possible values at runtime that is covered by
2162 the others alternative.
2164 Another exception is if the subtype of the expression is
2165 non-static. In that case, we also have to use the base type. */
2166 if (Paren_Count (Expression (gnat_node
)) != 0
2167 || !Is_OK_Static_Subtype (Underlying_Type
2168 (Etype (Expression (gnat_node
)))))
2169 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2171 set_lineno (gnat_node
, 1);
2172 expand_start_case (1, gnu_expr
, TREE_TYPE (gnu_expr
), "case");
2174 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2175 Present (gnat_when
);
2176 gnat_when
= Next_Non_Pragma (gnat_when
))
2178 /* First compile all the different case choices for the current
2179 WHEN alternative. */
2181 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2182 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2186 gnu_label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2188 set_lineno (gnat_choice
, 1);
2189 switch (Nkind (gnat_choice
))
2192 /* Abort on all errors except range empty, which
2193 means we ignore this alternative. */
2195 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice
)),
2196 gnat_to_gnu (High_Bound (gnat_choice
)),
2197 convert
, gnu_label
, 0);
2199 if (error_code
!= 0 && error_code
!= 4)
2203 case N_Subtype_Indication
:
2206 (gnat_to_gnu (Low_Bound (Range_Expression
2207 (Constraint (gnat_choice
)))),
2208 gnat_to_gnu (High_Bound (Range_Expression
2209 (Constraint (gnat_choice
)))),
2210 convert
, gnu_label
, 0);
2212 if (error_code
!= 0 && error_code
!= 4)
2217 case N_Expanded_Name
:
2218 /* This represents either a subtype range or a static value
2219 of some kind; Ekind says which. If a static value,
2220 fall through to the next case. */
2221 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2223 tree type
= get_unpadded_type (Entity (gnat_choice
));
2226 = pushcase_range (fold (TYPE_MIN_VALUE (type
)),
2227 fold (TYPE_MAX_VALUE (type
)),
2228 convert
, gnu_label
, 0);
2230 if (error_code
!= 0 && error_code
!= 4)
2234 /* ... fall through ... */
2235 case N_Character_Literal
:
2236 case N_Integer_Literal
:
2237 if (pushcase (gnat_to_gnu (gnat_choice
), convert
,
2242 case N_Others_Choice
:
2243 if (pushcase (NULL_TREE
, convert
, gnu_label
, 0))
2252 /* After compiling the choices attached to the WHEN compile the
2253 body of statements that have to be executed, should the
2254 "WHEN ... =>" be taken. Push a binding level here in case
2255 variables are declared since we want them to be local to this
2256 set of statements instead of the block containing the Case
2259 expand_start_bindings (0);
2260 for (gnat_statement
= First (Statements (gnat_when
));
2261 Present (gnat_statement
);
2262 gnat_statement
= Next (gnat_statement
))
2263 gnat_to_code (gnat_statement
);
2265 /* Communicate to GCC that we are done with the current WHEN,
2266 i.e. insert a "break" statement. */
2267 expand_exit_something ();
2268 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
2269 poplevel (kept_level_p (), 1, 0);
2272 expand_end_case (gnu_expr
);
2276 case N_Loop_Statement
:
2278 /* The loop variable in GCC form, if any. */
2279 tree gnu_loop_var
= NULL_TREE
;
2280 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2281 enum tree_code gnu_update
= ERROR_MARK
;
2282 /* Used if this is a named loop for so EXIT can work. */
2283 struct nesting
*loop_id
;
2284 /* Condition to continue loop tested at top of loop. */
2285 tree gnu_top_condition
= integer_one_node
;
2286 /* Similar, but tested at bottom of loop. */
2287 tree gnu_bottom_condition
= integer_one_node
;
2288 Node_Id gnat_statement
;
2289 Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2290 Node_Id gnat_top_condition
= Empty
;
2291 int enclosing_if_p
= 0;
2293 /* Set the condition that under which the loop should continue.
2294 For "LOOP .... END LOOP;" the condition is always true. */
2295 if (No (gnat_iter_scheme
))
2297 /* The case "WHILE condition LOOP ..... END LOOP;" */
2298 else if (Present (Condition (gnat_iter_scheme
)))
2299 gnat_top_condition
= Condition (gnat_iter_scheme
);
2302 /* We have an iteration scheme. */
2303 Node_Id gnat_loop_spec
2304 = Loop_Parameter_Specification (gnat_iter_scheme
);
2305 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2306 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2307 tree gnu_type
= get_unpadded_type (gnat_type
);
2308 tree gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2309 tree gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2310 int reversep
= Reverse_Present (gnat_loop_spec
);
2311 tree gnu_first
= reversep
? gnu_high
: gnu_low
;
2312 tree gnu_last
= reversep
? gnu_low
: gnu_high
;
2313 enum tree_code end_code
= reversep
? GE_EXPR
: LE_EXPR
;
2314 tree gnu_base_type
= get_base_type (gnu_type
);
2316 = (reversep
? TYPE_MIN_VALUE (gnu_base_type
)
2317 : TYPE_MAX_VALUE (gnu_base_type
));
2319 /* We know the loop variable will not overflow if GNU_LAST is
2320 a constant and is not equal to GNU_LIMIT. If it might
2321 overflow, we have to move the limit test to the end of
2322 the loop. In that case, we have to test for an
2323 empty loop outside the loop. */
2324 if (TREE_CODE (gnu_last
) != INTEGER_CST
2325 || TREE_CODE (gnu_limit
) != INTEGER_CST
2326 || tree_int_cst_equal (gnu_last
, gnu_limit
))
2328 gnu_expr
= build_binary_op (LE_EXPR
, integer_type_node
,
2330 set_lineno (gnat_loop_spec
, 1);
2331 expand_start_cond (gnu_expr
, 0);
2335 /* Open a new nesting level that will surround the loop to declare
2336 the loop index variable. */
2338 expand_start_bindings (0);
2340 /* Declare the loop index and set it to its initial value. */
2341 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2342 if (DECL_BY_REF_P (gnu_loop_var
))
2343 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2346 /* The loop variable might be a padded type, so use `convert' to
2347 get a reference to the inner variable if so. */
2348 gnu_loop_var
= convert (get_base_type (gnu_type
), gnu_loop_var
);
2350 /* Set either the top or bottom exit condition as
2351 appropriate depending on whether we know an overflow
2352 cannot occur or not. */
2354 gnu_bottom_condition
2355 = build_binary_op (NE_EXPR
, integer_type_node
,
2356 gnu_loop_var
, gnu_last
);
2359 = build_binary_op (end_code
, integer_type_node
,
2360 gnu_loop_var
, gnu_last
);
2362 gnu_update
= reversep
? PREDECREMENT_EXPR
: PREINCREMENT_EXPR
;
2365 set_lineno (gnat_node
, 1);
2367 loop_id
= expand_start_loop_continue_elsewhere (1);
2369 loop_id
= expand_start_loop (1);
2371 /* If the loop was named, have the name point to this loop. In this
2372 case, the association is not a ..._DECL node; in fact, it isn't
2373 a GCC tree node at all. Since this name is referenced inside
2374 the loop, do it before we process the statements of the loop. */
2375 if (Present (Identifier (gnat_node
)))
2377 tree gnu_loop_id
= make_node (GNAT_LOOP_ID
);
2379 TREE_LOOP_ID (gnu_loop_id
) = loop_id
;
2380 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_id
, 1);
2383 set_lineno (gnat_node
, 1);
2385 /* We must evaluate the condition after we've entered the
2386 loop so that any expression actions get done in the right
2388 if (Present (gnat_top_condition
))
2389 gnu_top_condition
= gnat_to_gnu (gnat_top_condition
);
2391 expand_exit_loop_top_cond (0, gnu_top_condition
);
2393 /* Make the loop body into its own block, so any allocated
2394 storage will be released every iteration. This is needed
2395 for stack allocation. */
2399 = tree_cons (gnu_bottom_condition
, NULL_TREE
, gnu_block_stack
);
2400 expand_start_bindings (0);
2402 for (gnat_statement
= First (Statements (gnat_node
));
2403 Present (gnat_statement
);
2404 gnat_statement
= Next (gnat_statement
))
2405 gnat_to_code (gnat_statement
);
2407 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
2408 poplevel (kept_level_p (), 1, 0);
2409 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2411 set_lineno (gnat_node
, 1);
2412 expand_exit_loop_if_false (0, gnu_bottom_condition
);
2416 expand_loop_continue_here ();
2417 gnu_expr
= build_binary_op (gnu_update
, TREE_TYPE (gnu_loop_var
),
2419 convert (TREE_TYPE (gnu_loop_var
),
2421 set_lineno (gnat_iter_scheme
, 1);
2422 expand_expr_stmt (gnu_expr
);
2425 set_lineno (gnat_node
, 1);
2430 /* Close the nesting level that sourround the loop that was used to
2431 declare the loop index variable. */
2432 set_lineno (gnat_node
, 1);
2433 expand_end_bindings (NULL_TREE
, 1, -1);
2439 set_lineno (gnat_node
, 1);
2445 case N_Block_Statement
:
2447 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2448 expand_start_bindings (0);
2449 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2450 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2451 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
2452 poplevel (kept_level_p (), 1, 0);
2453 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2454 if (Present (Identifier (gnat_node
)))
2455 mark_out_of_scope (Entity (Identifier (gnat_node
)));
2458 case N_Exit_Statement
:
2460 /* Which loop to exit, NULL if the current loop. */
2461 struct nesting
*loop_id
= 0;
2462 /* The GCC version of the optional GNAT condition node attached to the
2463 exit statement. Exit the loop if this is false. */
2464 tree gnu_cond
= integer_zero_node
;
2466 if (Present (Name (gnat_node
)))
2468 = TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node
))));
2470 if (Present (Condition (gnat_node
)))
2471 gnu_cond
= invert_truthvalue (gnat_truthvalue_conversion
2472 (gnat_to_gnu (Condition (gnat_node
))));
2474 set_lineno (gnat_node
, 1);
2475 expand_exit_loop_if_false (loop_id
, gnu_cond
);
2479 case N_Return_Statement
:
2481 /* The gnu function type of the subprogram currently processed. */
2482 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
2483 /* The return value from the subprogram. */
2484 tree gnu_ret_val
= 0;
2486 /* If we are dealing with a "return;" from an Ada procedure with
2487 parameters passed by copy in copy out, we need to return a record
2488 containing the final values of these parameters. If the list
2489 contains only one entry, return just that entry.
2491 For a full description of the copy in copy out parameter mechanism,
2492 see the part of the gnat_to_gnu_entity routine dealing with the
2493 translation of subprograms.
2495 But if we have a return label defined, convert this into
2496 a branch to that label. */
2498 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2500 gnu_result
= build_nt (GOTO_STMT
,
2501 TREE_VALUE (gnu_return_label_stack
));
2505 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
2507 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type
)) == 1)
2508 gnu_ret_val
= TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type
));
2511 = gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
2512 TYPE_CI_CO_LIST (gnu_subprog_type
));
2515 /* If the Ada subprogram is a function, we just need to return the
2516 expression. If the subprogram returns an unconstrained
2517 array, we have to allocate a new version of the result and
2518 return it. If we return by reference, return a pointer. */
2520 else if (Present (Expression (gnat_node
)))
2522 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
2524 /* Do not remove the padding from GNU_RET_VAL if the inner
2525 type is self-referential since we want to allocate the fixed
2526 size in that case. */
2527 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
2528 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0)))
2530 && (TYPE_IS_PADDING_P
2531 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
2532 && (CONTAINS_PLACEHOLDER_P
2533 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
)))))
2534 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
2536 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type
)
2537 || By_Ref (gnat_node
))
2538 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
2540 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
))
2542 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
2544 /* We have two cases: either the function returns with
2545 depressed stack or not. If not, we allocate on the
2546 secondary stack. If so, we allocate in the stack frame.
2547 if no copy is needed, the front end will set By_Ref,
2548 which we handle in the case above. */
2549 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type
))
2551 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2552 TREE_TYPE (gnu_subprog_type
), 0, -1,
2556 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2557 TREE_TYPE (gnu_subprog_type
),
2558 Procedure_To_Call (gnat_node
),
2559 Storage_Pool (gnat_node
), gnat_node
);
2563 gnu_result
= build_nt (RETURN_STMT
, gnu_ret_val
);
2567 case N_Goto_Statement
:
2568 gnu_result
= build_nt (GOTO_STMT
, gnat_to_gnu (Name (gnat_node
)));
2571 /****************************/
2572 /* Chapter 6: Subprograms: */
2573 /****************************/
2575 case N_Subprogram_Declaration
:
2576 /* Unless there is a freeze node, declare the subprogram. We consider
2577 this a "definition" even though we're not generating code for
2578 the subprogram because we will be making the corresponding GCC
2581 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
2582 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
2587 case N_Abstract_Subprogram_Declaration
:
2588 /* This subprogram doesn't exist for code generation purposes, but we
2589 have to elaborate the types of any parameters, unless they are
2590 imported types (nothing to generate in this case). */
2592 = First_Formal (Defining_Entity (Specification (gnat_node
)));
2593 Present (gnat_temp
);
2594 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
2595 if (Is_Itype (Etype (gnat_temp
))
2596 && !From_With_Type (Etype (gnat_temp
)))
2597 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2601 case N_Defining_Program_Unit_Name
:
2602 /* For a child unit identifier go up a level to get the
2603 specificaton. We get this when we try to find the spec of
2604 a child unit package that is the compilation unit being compiled. */
2605 gnat_to_code (Parent (gnat_node
));
2608 case N_Subprogram_Body
:
2610 /* Save debug output mode in case it is reset. */
2611 enum debug_info_type save_write_symbols
= write_symbols
;
2612 const struct gcc_debug_hooks
*const save_debug_hooks
= debug_hooks
;
2613 /* Definining identifier of a parameter to the subprogram. */
2614 Entity_Id gnat_param
;
2615 /* The defining identifier for the subprogram body. Note that if a
2616 specification has appeared before for this body, then the identifier
2617 occurring in that specification will also be a defining identifier
2618 and all the calls to this subprogram will point to that
2620 Entity_Id gnat_subprog_id
2621 = (Present (Corresponding_Spec (gnat_node
))
2622 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
2624 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2625 tree gnu_subprog_decl
;
2626 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2627 tree gnu_subprog_type
;
2630 /* If this is a generic object or if it has been eliminated,
2633 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
2634 || Ekind (gnat_subprog_id
) == E_Generic_Function
2635 || Is_Eliminated (gnat_subprog_id
))
2638 /* If debug information is suppressed for the subprogram,
2639 turn debug mode off for the duration of processing. */
2640 if (!Needs_Debug_Info (gnat_subprog_id
))
2642 write_symbols
= NO_DEBUG
;
2643 debug_hooks
= &do_nothing_debug_hooks
;
2646 /* If this subprogram acts as its own spec, define it. Otherwise,
2647 just get the already-elaborated tree node. However, if this
2648 subprogram had its elaboration deferred, we will already have
2649 made a tree node for it. So treat it as not being defined in
2650 that case. Such a subprogram cannot have an address clause or
2651 a freeze node, so this test is safe, though it does disable
2652 some otherwise-useful error checking. */
2654 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
2655 Acts_As_Spec (gnat_node
)
2656 && ! present_gnu_tree (gnat_subprog_id
));
2658 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
2660 /* ??? Temporarily do this to avoid GC throwing away outer stuff. */
2661 ggc_push_context ();
2663 /* Set the line number in the decl to correspond to that of
2664 the body so that the line number notes are written
2666 set_lineno (gnat_node
, 0);
2667 DECL_SOURCE_LOCATION (gnu_subprog_decl
) = input_location
;
2669 begin_subprog_body (gnu_subprog_decl
);
2671 /* There used to be a second call to set_lineno here, with
2672 write_note_p set, but begin_subprog_body actually already emits the
2673 note we want (via init_function_start).
2675 Emitting a second note here was necessary for -ftest-coverage with
2676 GCC 2.8.1, as the first one was skipped by branch_prob. This is no
2677 longer the case with GCC 3.x, so emitting a second note here would
2678 result in having the first line of the subprogram counted twice by
2682 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2683 expand_start_bindings (0);
2685 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2687 /* If there are OUT parameters, we need to ensure that the
2688 return statement properly copies them out. We do this by
2689 making a new block and converting any inner return into a goto
2690 to a label at the end of the block. */
2692 if (gnu_cico_list
!= 0)
2694 gnu_return_label_stack
2695 = tree_cons (NULL_TREE
,
2696 build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
),
2697 gnu_return_label_stack
);
2699 expand_start_bindings (0);
2702 gnu_return_label_stack
2703 = tree_cons (NULL_TREE
, NULL_TREE
, gnu_return_label_stack
);
2705 /* See if there are any parameters for which we don't yet have
2706 GCC entities. These must be for OUT parameters for which we
2707 will be making VAR_DECL nodes here. Fill them in to
2708 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2709 We can match up the entries because TYPE_CI_CO_LIST is in the
2710 order of the parameters. */
2712 for (gnat_param
= First_Formal (gnat_subprog_id
);
2713 Present (gnat_param
);
2714 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2715 if (present_gnu_tree (gnat_param
))
2716 adjust_decl_rtl (get_gnu_tree (gnat_param
));
2719 /* Skip any entries that have been already filled in; they
2720 must correspond to IN OUT parameters. */
2721 for (; gnu_cico_list
!= 0 && TREE_VALUE (gnu_cico_list
) != 0;
2722 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
))
2725 /* Do any needed references for padded types. */
2726 TREE_VALUE (gnu_cico_list
)
2727 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list
)),
2728 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
2731 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2733 /* Generate the code of the subprogram itself. A return statement
2734 will be present and any OUT parameters will be handled there. */
2735 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2737 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
2738 poplevel (kept_level_p (), 1, 0);
2739 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2741 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2745 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
2746 poplevel (kept_level_p (), 1, 0);
2747 expand_label (TREE_VALUE (gnu_return_label_stack
));
2749 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2750 set_lineno (gnat_node
, 1);
2751 if (list_length (gnu_cico_list
) == 1)
2752 gnu_retval
= TREE_VALUE (gnu_cico_list
);
2754 gnu_retval
= gnat_build_constructor (TREE_TYPE (gnu_subprog_type
),
2757 if (DECL_P (gnu_retval
) && DECL_BY_REF_P (gnu_retval
))
2759 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_retval
);
2762 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2763 DECL_RESULT (current_function_decl
),
2768 gnu_return_label_stack
= TREE_CHAIN (gnu_return_label_stack
);
2770 /* Disconnect the trees for parameters that we made variables for
2771 from the GNAT entities since these will become unusable after
2772 we end the function. */
2773 for (gnat_param
= First_Formal (gnat_subprog_id
);
2774 Present (gnat_param
);
2775 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2776 if (TREE_CODE (get_gnu_tree (gnat_param
)) == VAR_DECL
)
2777 save_gnu_tree (gnat_param
, NULL_TREE
, 0);
2779 end_subprog_body ();
2780 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
2781 write_symbols
= save_write_symbols
;
2782 debug_hooks
= save_debug_hooks
;
2787 case N_Function_Call
:
2788 case N_Procedure_Call_Statement
:
2790 /* The GCC node corresponding to the GNAT subprogram name. This can
2791 either be a FUNCTION_DECL node if we are dealing with a standard
2792 subprogram call, or an indirect reference expression (an
2793 INDIRECT_REF node) pointing to a subprogram. */
2794 tree gnu_subprog_node
= gnat_to_gnu (Name (gnat_node
));
2795 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2796 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog_node
);
2797 tree gnu_subprog_addr
2798 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog_node
);
2799 Entity_Id gnat_formal
;
2800 Node_Id gnat_actual
;
2801 tree gnu_actual_list
= NULL_TREE
;
2802 tree gnu_name_list
= NULL_TREE
;
2803 tree gnu_before_list
= NULL_TREE
;
2804 tree gnu_after_list
= NULL_TREE
;
2805 tree gnu_subprog_call
;
2807 switch (Nkind (Name (gnat_node
)))
2810 case N_Operator_Symbol
:
2811 case N_Expanded_Name
:
2812 case N_Attribute_Reference
:
2813 if (Is_Eliminated (Entity (Name (gnat_node
))))
2814 Eliminate_Error_Msg (gnat_node
, Entity (Name (gnat_node
)));
2817 if (TREE_CODE (gnu_subprog_type
) != FUNCTION_TYPE
)
2820 /* If we are calling a stubbed function, make this into a
2821 raise of Program_Error. Elaborate all our args first. */
2823 if (TREE_CODE (gnu_subprog_node
) == FUNCTION_DECL
2824 && DECL_STUBBED_P (gnu_subprog_node
))
2826 for (gnat_actual
= First_Actual (gnat_node
);
2827 Present (gnat_actual
);
2828 gnat_actual
= Next_Actual (gnat_actual
))
2829 expand_expr_stmt (gnat_to_gnu (gnat_actual
));
2831 if (Nkind (gnat_node
) == N_Function_Call
)
2833 gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
2835 = build1 (NULL_EXPR
, gnu_result_type
,
2836 build_call_raise (PE_Stubbed_Subprogram_Called
));
2840 = build_nt (EXPR_STMT
,
2841 build_call_raise (PE_Stubbed_Subprogram_Called
));
2845 /* The only way we can be making a call via an access type is
2846 if Name is an explicit dereference. In that case, get the
2847 list of formal args from the type the access type is pointing
2848 to. Otherwise, get the formals from entity being called. */
2849 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2850 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
2851 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
2852 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2855 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
2857 /* Create the list of the actual parameters as GCC expects it, namely
2858 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2859 node is a parameter-expression and the TREE_PURPOSE field is
2860 null. Skip OUT parameters that are not passed by reference and
2861 don't need to be copied in. */
2863 for (gnat_actual
= First_Actual (gnat_node
);
2864 Present (gnat_actual
);
2865 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2866 gnat_actual
= Next_Actual (gnat_actual
))
2868 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
2869 /* We treat a conversion between aggregate types as if it
2870 is an unchecked conversion. */
2871 int unchecked_convert_p
2872 = (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
2873 || (Nkind (gnat_actual
) == N_Type_Conversion
2874 && Is_Composite_Type (Underlying_Type
2875 (Etype (gnat_formal
)))));
2877 = unchecked_convert_p
? Expression (gnat_actual
) : gnat_actual
;
2878 tree gnu_name
= gnat_to_gnu (gnat_name
);
2879 tree gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
));
2882 /* If it's possible we may need to use this expression twice,
2883 make sure than any side-effects are handled via SAVE_EXPRs.
2884 Likewise if we need to force side-effects before the call.
2885 ??? This is more conservative than we need since we don't
2886 need to do this for pass-by-ref with no conversion.
2887 If we are passing a non-addressable Out or In Out parameter by
2888 reference, pass the address of a copy and set up to copy back
2889 out after the call. */
2891 if (Ekind (gnat_formal
) != E_In_Parameter
)
2893 gnu_name
= gnat_stabilize_reference (gnu_name
, 1);
2894 if (! addressable_p (gnu_name
)
2895 && present_gnu_tree (gnat_formal
)
2896 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
2897 || (TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2898 && (DECL_BY_COMPONENT_PTR_P
2899 (get_gnu_tree (gnat_formal
))
2900 || DECL_BY_DESCRIPTOR_P
2901 (get_gnu_tree (gnat_formal
))))))
2903 tree gnu_copy
= gnu_name
;
2906 /* Remove any unpadding on the actual and make a copy.
2907 But if the actual is a left-justified modular type,
2908 first convert to it. */
2909 if (TREE_CODE (gnu_name
) == COMPONENT_REF
2910 && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name
, 0)))
2912 && (TYPE_IS_PADDING_P
2913 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0))))))
2914 gnu_name
= gnu_copy
= TREE_OPERAND (gnu_name
, 0);
2915 else if (TREE_CODE (gnu_name_type
) == RECORD_TYPE
2916 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2918 gnu_name
= convert (gnu_name_type
, gnu_name
);
2920 gnu_actual
= save_expr (gnu_name
);
2922 /* Since we're going to take the address of the SAVE_EXPR,
2923 we don't want it to be marked as unchanging.
2924 So set TREE_ADDRESSABLE. */
2925 gnu_temp
= skip_simple_arithmetic (gnu_actual
);
2926 if (TREE_CODE (gnu_temp
) == SAVE_EXPR
)
2928 TREE_ADDRESSABLE (gnu_temp
) = 1;
2929 TREE_READONLY (gnu_temp
) = 0;
2932 /* Set up to move the copy back to the original. */
2934 = build_nt (EXPR_STMT
,
2935 build (MODIFY_EXPR
, TREE_TYPE (gnu_copy
),
2936 gnu_copy
, gnu_actual
));
2938 TREE_TYPE (gnu_temp
) = void_type_node
;
2939 TREE_SLOC (gnu_temp
) = Sloc (gnat_actual
);
2940 TREE_CHAIN (gnu_temp
) = gnu_after_list
;
2941 gnu_after_list
= gnu_temp
;
2945 /* If this was a procedure call, we may not have removed any
2946 padding. So do it here for the part we will use as an
2948 gnu_actual
= gnu_name
;
2949 if (Ekind (gnat_formal
) != E_Out_Parameter
2950 && TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2951 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2952 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
2955 if (Ekind (gnat_formal
) != E_Out_Parameter
2956 && ! unchecked_convert_p
2957 && Do_Range_Check (gnat_actual
))
2958 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
2960 /* Do any needed conversions. We need only check for
2961 unchecked conversion since normal conversions will be handled
2962 by just converting to the formal type. */
2963 if (unchecked_convert_p
)
2966 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2968 (Nkind (gnat_actual
)
2969 == N_Unchecked_Type_Conversion
)
2970 && No_Truncation (gnat_actual
));
2972 /* One we've done the unchecked conversion, we still
2973 must ensure that the object is in range of the formal's
2975 if (Ekind (gnat_formal
) != E_Out_Parameter
2976 && Do_Range_Check (gnat_actual
))
2977 gnu_actual
= emit_range_check (gnu_actual
,
2978 Etype (gnat_formal
));
2980 else if (TREE_CODE (gnu_actual
) != SAVE_EXPR
)
2981 /* We may have suppressed a conversion to the Etype of the
2982 actual since the parent is a procedure call. So add the
2984 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2987 if (TREE_CODE (gnu_actual
) != SAVE_EXPR
)
2988 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2990 /* If we have not saved a GCC object for the formal, it means it
2991 is an OUT parameter not passed by reference and that does not
2992 need to be copied in. Otherwise, look at the PARM_DECL to see
2993 if it is passed by reference. */
2994 if (present_gnu_tree (gnat_formal
)
2995 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2996 && DECL_BY_REF_P (get_gnu_tree (gnat_formal
)))
2998 if (Ekind (gnat_formal
) != E_In_Parameter
)
3000 gnu_actual
= gnu_name
;
3002 /* If we have a padded type, be sure we've removed the
3004 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
3005 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
))
3006 && TREE_CODE (gnu_actual
) != SAVE_EXPR
)
3008 = convert (get_unpadded_type (Etype (gnat_actual
)),
3012 /* Otherwise, if we have a non-addressable COMPONENT_REF of a
3013 variable-size type see if it's doing a unpadding operation.
3014 If so, remove that operation since we have no way of
3015 allocating the required temporary. */
3016 if (TREE_CODE (gnu_actual
) == COMPONENT_REF
3017 && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual
)))
3018 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual
, 0)))
3020 && TYPE_IS_PADDING_P (TREE_TYPE
3021 (TREE_OPERAND (gnu_actual
, 0)))
3022 && !addressable_p (gnu_actual
))
3023 gnu_actual
= TREE_OPERAND (gnu_actual
, 0);
3025 /* The symmetry of the paths to the type of an entity is
3026 broken here since arguments don't know that they will
3027 be passed by ref. */
3028 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
3029 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
,
3032 else if (present_gnu_tree (gnat_formal
)
3033 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3034 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
)))
3036 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
3037 gnu_actual
= maybe_implicit_deref (gnu_actual
);
3038 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
3040 if (TREE_CODE (gnu_formal_type
) == RECORD_TYPE
3041 && TYPE_IS_PADDING_P (gnu_formal_type
))
3044 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
3045 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
3048 /* Take the address of the object and convert to the
3049 proper pointer type. We'd like to actually compute
3050 the address of the beginning of the array using
3051 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
3052 that the ARRAY_REF might return a constant and we'd
3053 be getting the wrong address. Neither approach is
3054 exactly correct, but this is the most likely to work
3056 gnu_actual
= convert (gnu_formal_type
,
3057 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3060 else if (present_gnu_tree (gnat_formal
)
3061 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3062 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
)))
3064 /* If arg is 'Null_Parameter, pass zero descriptor. */
3065 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
3066 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
3067 && TREE_PRIVATE (gnu_actual
))
3069 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
3073 = build_unary_op (ADDR_EXPR
, NULL_TREE
,
3074 fill_vms_descriptor (gnu_actual
,
3079 tree gnu_actual_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
));
3081 if (Ekind (gnat_formal
) != E_In_Parameter
)
3083 = chainon (gnu_name_list
,
3084 build_tree_list (NULL_TREE
, gnu_name
));
3086 if (! present_gnu_tree (gnat_formal
)
3087 || TREE_CODE (get_gnu_tree (gnat_formal
)) != PARM_DECL
)
3090 /* If this is 'Null_Parameter, pass a zero even though we are
3091 dereferencing it. */
3092 else if (TREE_CODE (gnu_actual
) == INDIRECT_REF
3093 && TREE_PRIVATE (gnu_actual
)
3094 && host_integerp (gnu_actual_size
, 1)
3095 && 0 >= compare_tree_int (gnu_actual_size
,
3099 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
3100 convert (gnat_type_for_size
3101 (tree_low_cst (gnu_actual_size
, 1), 1),
3102 integer_zero_node
), 0);
3105 = convert (TYPE_MAIN_VARIANT
3106 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
))),
3111 = chainon (gnu_actual_list
,
3112 build_tree_list (NULL_TREE
, gnu_actual
));
3115 gnu_subprog_call
= build (CALL_EXPR
, TREE_TYPE (gnu_subprog_type
),
3116 gnu_subprog_addr
, gnu_actual_list
,
3118 TREE_SIDE_EFFECTS (gnu_subprog_call
) = 1;
3120 /* If it is a function call, the result is the call expression. */
3121 if (Nkind (gnat_node
) == N_Function_Call
)
3123 gnu_result
= gnu_subprog_call
;
3125 /* If the function returns an unconstrained array or by reference,
3126 we have to de-dereference the pointer. */
3127 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
)
3128 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type
))
3129 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3132 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3136 /* If this is the case where the GNAT tree contains a procedure call
3137 but the Ada procedure has copy in copy out parameters, the special
3138 parameter passing mechanism must be used. */
3139 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
3141 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3142 in copy out parameters. */
3143 tree scalar_return_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3144 int length
= list_length (scalar_return_list
);
3150 gnu_subprog_call
= protect_multiple_eval (gnu_subprog_call
);
3152 /* If any of the names had side-effects, ensure they are
3153 all evaluated before the call. */
3154 for (gnu_name
= gnu_name_list
; gnu_name
;
3155 gnu_name
= TREE_CHAIN (gnu_name
))
3156 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name
)))
3158 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_subprog_call
),
3159 TREE_VALUE (gnu_name
), gnu_subprog_call
);
3162 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3163 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
3165 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
3167 for (gnat_actual
= First_Actual (gnat_node
);
3168 Present (gnat_actual
);
3169 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3170 gnat_actual
= Next_Actual (gnat_actual
))
3171 /* If we are dealing with a copy in copy out parameter, we must
3172 retrieve its value from the record returned in the function
3174 if (! (present_gnu_tree (gnat_formal
)
3175 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3176 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3177 || ((TREE_CODE (get_gnu_tree (gnat_formal
))
3179 && ((DECL_BY_COMPONENT_PTR_P
3180 (get_gnu_tree (gnat_formal
))
3181 || (DECL_BY_DESCRIPTOR_P
3182 (get_gnu_tree (gnat_formal
))))))))
3183 && Ekind (gnat_formal
) != E_In_Parameter
)
3185 /* Get the value to assign to this OUT or IN OUT
3186 parameter. It is either the result of the function if
3187 there is only a single such parameter or the appropriate
3188 field from the record returned. */
3190 = length
== 1 ? gnu_subprog_call
3191 : build_component_ref
3192 (gnu_subprog_call
, NULL_TREE
,
3193 TREE_PURPOSE (scalar_return_list
), 0);
3194 int unchecked_conversion
3195 = Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
;
3196 /* If the actual is a conversion, get the inner expression,
3197 which will be the real destination, and convert the
3198 result to the type of the actual parameter. */
3200 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3202 /* If the result is a padded type, remove the padding. */
3203 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3204 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3206 = convert (TREE_TYPE (TYPE_FIELDS
3207 (TREE_TYPE (gnu_result
))),
3210 /* If the result is a type conversion, do it. */
3211 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3213 = convert_with_check
3214 (Etype (Expression (gnat_actual
)), gnu_result
,
3215 Do_Overflow_Check (gnat_actual
),
3216 Do_Range_Check (Expression (gnat_actual
)),
3217 Float_Truncate (gnat_actual
));
3219 else if (unchecked_conversion
)
3221 = unchecked_convert (TREE_TYPE (gnu_actual
), gnu_result
,
3222 No_Truncation (gnat_actual
));
3225 if (Do_Range_Check (gnat_actual
))
3226 gnu_result
= emit_range_check (gnu_result
,
3227 Etype (gnat_actual
));
3229 if (! (! TREE_CONSTANT (TYPE_SIZE
3230 (TREE_TYPE (gnu_actual
)))
3231 && TREE_CONSTANT (TYPE_SIZE
3232 (TREE_TYPE (gnu_result
)))))
3233 gnu_result
= convert (TREE_TYPE (gnu_actual
),
3238 = build_nt (EXPR_STMT
,
3239 build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3240 gnu_actual
, gnu_result
));
3241 TREE_TYPE (gnu_result
) = void_type_node
;
3242 TREE_SLOC (gnu_result
) = Sloc (gnat_actual
);
3243 TREE_CHAIN (gnu_result
) = gnu_before_list
;
3244 gnu_before_list
= gnu_result
;
3245 scalar_return_list
= TREE_CHAIN (scalar_return_list
);
3246 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3251 gnu_before_list
= build_nt (EXPR_STMT
, gnu_subprog_call
);
3252 TREE_TYPE (gnu_before_list
) = void_type_node
;
3253 TREE_SLOC (gnu_before_list
) = Sloc (gnat_node
);
3256 gnu_result
= chainon (nreverse (gnu_before_list
),
3257 nreverse (gnu_after_list
));
3258 if (TREE_CHAIN (gnu_result
))
3259 gnu_result
= build_nt (BLOCK_STMT
, gnu_result
);
3263 /*************************/
3264 /* Chapter 7: Packages: */
3265 /*************************/
3267 case N_Package_Declaration
:
3268 gnat_to_code (Specification (gnat_node
));
3271 case N_Package_Specification
:
3273 process_decls (Visible_Declarations (gnat_node
),
3274 Private_Declarations (gnat_node
), Empty
, 1, 1);
3277 case N_Package_Body
:
3279 /* If this is the body of a generic package - do nothing */
3280 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
3283 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
3285 if (Present (Handled_Statement_Sequence (gnat_node
)))
3287 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
3288 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
3289 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
3293 /*********************************/
3294 /* Chapter 8: Visibility Rules: */
3295 /*********************************/
3297 case N_Use_Package_Clause
:
3298 case N_Use_Type_Clause
:
3299 /* Nothing to do here - but these may appear in list of declarations */
3302 /***********************/
3303 /* Chapter 9: Tasks: */
3304 /***********************/
3306 case N_Protected_Type_Declaration
:
3309 case N_Single_Task_Declaration
:
3310 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
3313 /***********************************************************/
3314 /* Chapter 10: Program Structure and Compilation Issues: */
3315 /***********************************************************/
3317 case N_Compilation_Unit
:
3319 /* For a body, first process the spec if there is one. */
3320 if (Nkind (Unit (gnat_node
)) == N_Package_Body
3321 || (Nkind (Unit (gnat_node
)) == N_Subprogram_Body
3322 && ! Acts_As_Spec (gnat_node
)))
3323 gnat_to_code (Library_Unit (gnat_node
));
3325 process_inlined_subprograms (gnat_node
);
3327 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
3329 elaborate_all_entities (gnat_node
);
3331 if (Nkind (Unit (gnat_node
)) == N_Subprogram_Declaration
3332 || Nkind (Unit (gnat_node
)) == N_Generic_Package_Declaration
3333 || Nkind (Unit (gnat_node
)) == N_Generic_Subprogram_Declaration
)
3337 process_decls (Declarations (Aux_Decls_Node (gnat_node
)),
3338 Empty
, Empty
, 1, 1);
3340 gnat_to_code (Unit (gnat_node
));
3342 /* Process any pragmas following the unit. */
3343 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node
))))
3344 for (gnat_temp
= First (Pragmas_After (Aux_Decls_Node (gnat_node
)));
3345 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3346 gnat_to_code (gnat_temp
);
3348 /* Put all the Actions into the elaboration routine if we already had
3349 elaborations. This will happen anyway if they are statements, but we
3350 want to force declarations there too due to order-of-elaboration
3351 issues. Most should have Is_Statically_Allocated set. If we
3352 have had no elaborations, we have no order-of-elaboration issue and
3353 don't want to create elaborations here. */
3354 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node
))))
3355 for (gnat_temp
= First (Actions (Aux_Decls_Node (gnat_node
)));
3356 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3358 if (pending_elaborations_p ())
3359 add_pending_elaborations (NULL_TREE
,
3360 make_transform_expr (gnat_temp
));
3362 gnat_to_code (gnat_temp
);
3365 /* Generate elaboration code for this unit, if necessary, and
3366 say whether we did or not. */
3367 Set_Has_No_Elaboration_Code
3370 (Defining_Entity (Unit (gnat_node
)),
3371 Nkind (Unit (gnat_node
)) == N_Package_Body
3372 || Nkind (Unit (gnat_node
)) == N_Subprogram_Body
,
3373 get_pending_elaborations ()));
3377 case N_Subprogram_Body_Stub
:
3378 case N_Package_Body_Stub
:
3379 case N_Protected_Body_Stub
:
3380 case N_Task_Body_Stub
:
3381 /* Simply process whatever unit is being inserted. */
3382 gnat_to_code (Unit (Library_Unit (gnat_node
)));
3386 gnat_to_code (Proper_Body (gnat_node
));
3389 /***************************/
3390 /* Chapter 11: Exceptions: */
3391 /***************************/
3393 case N_Handled_Sequence_Of_Statements
:
3395 /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3396 schemes and we have our own SJLJ mechanism. To call the GCC
3397 mechanism, we first call expand_eh_region_start if there is at least
3398 one handler associated with the region. We then generate code for
3399 the region and call expand_start_all_catch to announce that the
3400 associated handlers are going to be generated.
3402 For each handler we call expand_start_catch, generate code for the
3403 handler, and then call expand_end_catch.
3405 After all the handlers, we call expand_end_all_catch.
3407 Here we deal with the region level calls and the
3408 N_Exception_Handler branch deals with the handler level calls
3409 (start_catch/end_catch).
3411 ??? The region level calls down there have been specifically put in
3412 place for a ZCX context and currently the order in which things are
3413 emitted (region/handlers) is different from the SJLJ case. Instead of
3414 putting other calls with different conditions at other places for the
3415 SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3416 generalize the condition to make it not ZCX specific. */
3418 /* If there is an At_End procedure attached to this node, and the eh
3419 mechanism is GNAT oriented (SJLJ or ZCX with front end tables), we
3420 must have at least a corresponding At_End handler, unless the
3421 No_Exception_Handlers restriction is set. */
3422 if (! type_annotate_only
3423 && Exception_Mechanism
!= GCC_ZCX
3424 && Present (At_End_Proc (gnat_node
))
3425 && ! Present (Exception_Handlers (gnat_node
))
3426 && ! No_Exception_Handlers_Set())
3430 /* Need a binding level that we can exit for this sequence if there is
3431 at least one exception handler for this block (since each handler
3432 needs an identified exit point) or there is an At_End procedure
3433 attached to this node (in order to have an attachment point for a
3435 bool exitable_binding_for_block
3436 = (! type_annotate_only
3437 && (Present (Exception_Handlers (gnat_node
))
3438 || Present (At_End_Proc (gnat_node
))));
3440 /* Make a binding level that we can exit if we need one. */
3441 if (exitable_binding_for_block
)
3444 expand_start_bindings (1);
3447 /* If we are to call a function when exiting this block, expand a GCC
3448 cleanup to take care. We have made a binding level for this cleanup
3450 if (Present (At_End_Proc (gnat_node
)))
3452 tree gnu_cleanup_call
3453 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3455 tree gnu_cleanup_decl
3456 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3457 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3460 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3463 /* Now we generate the code for this block, with a different layout
3464 for GNAT SJLJ and for GCC or front end ZCX. The handlers come first
3465 in the GNAT SJLJ case, while they come after the handled sequence
3466 in the other cases. */
3468 /* First deal with possible handlers for the GNAT SJLJ scheme. */
3469 if (! type_annotate_only
3470 && Exception_Mechanism
== Setjmp_Longjmp
3471 && Present (Exception_Handlers (gnat_node
)))
3473 /* We already have a fresh binding level at hand. Declare a
3474 variable to save the old __gnat_jmpbuf value and a variable for
3475 our jmpbuf. Call setjmp and handle each of the possible
3476 exceptions if it returns one. */
3478 tree gnu_jmpsave_decl
3479 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
3481 build_call_0_expr (get_jmpbuf_decl
),
3484 tree gnu_jmpbuf_decl
3485 = create_var_decl (get_identifier ("JMP_BUF"),
3486 NULL_TREE
, jmpbuf_type
,
3487 NULL_TREE
, 0, 0, 0, 0,
3490 TREE_VALUE (gnu_block_stack
) = gnu_jmpbuf_decl
;
3492 /* When we exit this block, restore the saved value. */
3493 expand_decl_cleanup (gnu_jmpsave_decl
,
3494 build_call_1_expr (set_jmpbuf_decl
,
3497 /* Call setjmp and handle exceptions if it returns one. */
3498 set_lineno (gnat_node
, 1);
3500 (build_call_1_expr (setjmp_decl
,
3501 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3505 /* Restore our incoming longjmp value before we do anything. */
3507 (build_call_1_expr (set_jmpbuf_decl
, gnu_jmpsave_decl
));
3509 /* Make a binding level for the exception handling declarations
3510 and code. Don't assign it an exit label, since this is the
3511 outer block we want to exit at the end of each handler. */
3513 expand_start_bindings (0);
3515 gnu_except_ptr_stack
3516 = tree_cons (NULL_TREE
,
3518 (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
3519 build_pointer_type (except_type_node
),
3520 build_call_0_expr (get_excptr_decl
),
3522 gnu_except_ptr_stack
);
3524 /* Generate code for each handler. The N_Exception_Handler case
3525 below does the real work. We ignore the dummy exception handler
3526 for the identifier case, as this is used only by the front
3528 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3529 Present (gnat_temp
);
3530 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3531 gnat_to_code (gnat_temp
);
3533 /* If none of the exception handlers did anything, re-raise
3534 but do not defer abortion. */
3535 set_lineno (gnat_node
, 1);
3537 (build_call_1_expr (raise_nodefer_decl
,
3538 TREE_VALUE (gnu_except_ptr_stack
)));
3540 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3542 /* End the binding level dedicated to the exception handlers. */
3543 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
3544 poplevel (kept_level_p (), 1, 0);
3546 /* End the "if" on setjmp. Note that we have arranged things so
3547 control never returns here. */
3550 /* This is now immediately before the body proper. Set our jmp_buf
3551 as the current buffer. */
3553 (build_call_1_expr (set_jmpbuf_decl
,
3554 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3558 /* Now comes the processing for the sequence body. */
3560 /* If we use the back-end eh support, tell the back-end we are
3561 starting a new exception region. */
3562 if (! type_annotate_only
3563 && Exception_Mechanism
== GCC_ZCX
3564 && Present (Exception_Handlers (gnat_node
)))
3565 expand_eh_region_start ();
3567 /* Generate code and declarations for the prefix of this block,
3569 if (Present (First_Real_Statement (gnat_node
)))
3570 process_decls (Statements (gnat_node
), Empty
,
3571 First_Real_Statement (gnat_node
), 1, 1);
3573 /* Generate code for each statement in the block. */
3574 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
3575 ? First_Real_Statement (gnat_node
)
3576 : First (Statements (gnat_node
)));
3577 Present (gnat_temp
);
3578 gnat_temp
= Next (gnat_temp
))
3579 gnat_to_code (gnat_temp
);
3581 /* Exit the binding level we made, if any. */
3582 if (exitable_binding_for_block
)
3583 expand_exit_something ();
3585 /* Compile the handlers for front end ZCX or back-end supported
3587 if (! type_annotate_only
3588 && Exception_Mechanism
!= Setjmp_Longjmp
3589 && Present (Exception_Handlers (gnat_node
)))
3591 if (Exception_Mechanism
== GCC_ZCX
)
3592 expand_start_all_catch ();
3594 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3595 Present (gnat_temp
);
3596 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3597 gnat_to_code (gnat_temp
);
3599 if (Exception_Mechanism
== GCC_ZCX
)
3600 expand_end_all_catch ();
3603 /* Close the binding level we made, if any. */
3604 if (exitable_binding_for_block
)
3606 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
3607 poplevel (kept_level_p (), 1, 0);
3613 case N_Exception_Handler
:
3614 if (Exception_Mechanism
== Setjmp_Longjmp
)
3616 /* Unless this is "Others" or the special "Non-Ada" exception
3617 for Ada, make an "if" statement to select the proper
3618 exceptions. For "Others", exclude exceptions where
3619 Handled_By_Others is nonzero unless the All_Others flag is set.
3620 For "Non-ada", accept an exception if "Lang" is 'V'. */
3621 tree gnu_choice
= integer_zero_node
;
3623 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3624 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3628 if (Nkind (gnat_temp
) == N_Others_Choice
)
3630 if (All_Others (gnat_temp
))
3631 this_choice
= integer_one_node
;
3635 (EQ_EXPR
, integer_type_node
,
3640 (INDIRECT_REF
, NULL_TREE
,
3641 TREE_VALUE (gnu_except_ptr_stack
)),
3642 get_identifier ("not_handled_by_others"), NULL_TREE
,
3647 else if (Nkind (gnat_temp
) == N_Identifier
3648 || Nkind (gnat_temp
) == N_Expanded_Name
)
3650 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
3652 /* Exception may be a renaming. Recover original exception
3653 which is the one elaborated and registered. */
3654 if (Present (Renamed_Object (gnat_ex_id
)))
3655 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
3657 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
3661 (EQ_EXPR
, integer_type_node
,
3662 TREE_VALUE (gnu_except_ptr_stack
),
3664 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack
)),
3665 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
3667 /* If this is the distinguished exception "Non_Ada_Error"
3668 (and we are in VMS mode), also allow a non-Ada
3669 exception (a VMS condition) to match. */
3670 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
3673 = build_component_ref
3675 (INDIRECT_REF
, NULL_TREE
,
3676 TREE_VALUE (gnu_except_ptr_stack
)),
3677 get_identifier ("lang"), NULL_TREE
, 0);
3681 (TRUTH_ORIF_EXPR
, integer_type_node
,
3683 (EQ_EXPR
, integer_type_node
, gnu_comp
,
3684 convert (TREE_TYPE (gnu_comp
),
3685 build_int_2 ('V', 0))),
3692 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
3693 gnu_choice
, this_choice
);
3696 set_lineno (gnat_node
, 1);
3698 expand_start_cond (gnu_choice
, 0);
3701 /* Tell the back end that we start an exception handler if necessary. */
3702 if (Exception_Mechanism
== GCC_ZCX
)
3704 /* We build a TREE_LIST of nodes representing what exception
3705 types this handler is able to catch, with special cases
3706 for others and all others cases.
3708 Each exception type is actually identified by a pointer to the
3709 exception id, with special value zero for "others" and one for
3710 "all others". Beware that these special values are known and used
3711 by the personality routine to identify the corresponding specific
3714 ??? For initial time frame reasons, the others and all_others
3715 cases have been handled using specific type trees, but this
3716 somehow hides information to the back-end, which expects NULL to
3717 be passed for catch all and end_cleanup to be used for cleanups.
3719 Care should be taken to ensure that the control flow impact of
3720 such clauses is rendered in some way. lang_eh_type_covers is
3721 doing the trick currently. */
3723 tree gnu_expr
, gnu_etype
;
3724 tree gnu_etypes_list
= NULL_TREE
;
3726 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3727 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3729 if (Nkind (gnat_temp
) == N_Others_Choice
)
3731 = All_Others (gnat_temp
) ? integer_one_node
3732 : integer_zero_node
;
3733 else if (Nkind (gnat_temp
) == N_Identifier
3734 || Nkind (gnat_temp
) == N_Expanded_Name
)
3736 Entity_Id gnat_ex_id
= Entity (gnat_temp
);
3738 /* Exception may be a renaming. Recover original exception
3739 which is the one elaborated and registered. */
3740 if (Present (Renamed_Object (gnat_ex_id
)))
3741 gnat_ex_id
= Renamed_Object (gnat_ex_id
);
3743 gnu_expr
= gnat_to_gnu_entity (gnat_ex_id
, NULL_TREE
, 0);
3746 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
3748 /* The Non_Ada_Error case for VMS exceptions is handled
3749 by the personality routine. */
3754 /* The GCC interface expects NULL to be passed for catch all
3755 handlers, so it would be quite tempting to set gnu_etypes_list
3756 to NULL if gnu_etype is integer_zero_node. It would not work,
3757 however, because GCC's notion of "catch all" is stronger than
3758 our notion of "others". Until we correctly use the cleanup
3759 interface as well, the doing tht would prevent the "all
3760 others" handlers from beeing seen, because nothing can be
3761 caught beyond a catch all from GCC's point of view. */
3763 = tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
3767 expand_start_catch (gnu_etypes_list
);
3770 expand_start_bindings (0);
3773 /* Expand a call to the begin_handler hook at the beginning of the
3774 handler, and arrange for a call to the end_handler hook to
3775 occur on every possible exit path.
3777 The hooks expect a pointer to the low level occurrence. This
3778 is required for our stack management scheme because a raise
3779 inside the handler pushes a new occurrence on top of the
3780 stack, which means that this top does not necessarily match
3781 the occurrence this handler was dealing with.
3783 The EXC_PTR_EXPR object references the exception occurrence
3784 beeing propagated. Upon handler entry, this is the exception
3785 for which the handler is triggered. This might not be the case
3786 upon handler exit, however, as we might have a new occurrence
3787 propagated by the handler's body, and the end_handler hook
3788 called as a cleanup in this context.
3790 We use a local variable to retrieve the incoming value at
3791 handler entry time, and reuse it to feed the end_handler
3792 hook's argument at exit time. */
3793 tree gnu_current_exc_ptr
3794 = build (EXC_PTR_EXPR
, ptr_type_node
);
3795 tree gnu_incoming_exc_ptr
3796 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE
,
3797 ptr_type_node
, gnu_current_exc_ptr
,
3801 (build_call_1_expr (begin_handler_decl
, gnu_incoming_exc_ptr
));
3803 (0, build_call_1_expr (end_handler_decl
, gnu_incoming_exc_ptr
));
3807 for (gnat_temp
= First (Statements (gnat_node
));
3808 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3809 gnat_to_code (gnat_temp
);
3811 if (Exception_Mechanism
== GCC_ZCX
)
3813 /* Tell the back end that we're done with the current handler. */
3814 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
3815 poplevel (kept_level_p (), 1, 0);
3817 expand_end_catch ();
3820 /* At the end of the handler, exit the block. We made this block in
3821 N_Handled_Sequence_Of_Statements. */
3822 expand_exit_something ();
3824 if (Exception_Mechanism
== Setjmp_Longjmp
)
3829 /*******************************/
3830 /* Chapter 12: Generic Units: */
3831 /*******************************/
3833 case N_Generic_Function_Renaming_Declaration
:
3834 case N_Generic_Package_Renaming_Declaration
:
3835 case N_Generic_Procedure_Renaming_Declaration
:
3836 case N_Generic_Package_Declaration
:
3837 case N_Generic_Subprogram_Declaration
:
3838 case N_Package_Instantiation
:
3839 case N_Procedure_Instantiation
:
3840 case N_Function_Instantiation
:
3841 /* These nodes can appear on a declaration list but there is nothing to
3842 to be done with them. */
3845 /***************************************************/
3846 /* Chapter 13: Representation Clauses and */
3847 /* Implementation-Dependent Features: */
3848 /***************************************************/
3850 case N_Attribute_Definition_Clause
:
3852 /* The only one we need deal with is for 'Address. For the others, SEM
3853 puts the information elsewhere. We need only deal with 'Address
3854 if the object has a Freeze_Node (which it never will currently). */
3855 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
3856 || No (Freeze_Node (Entity (Name (gnat_node
)))))
3859 /* Get the value to use as the address and save it as the
3860 equivalent for GNAT_TEMP. When the object is frozen,
3861 gnat_to_gnu_entity will do the right thing. */
3862 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3863 save_gnu_tree (Entity (Name (gnat_node
)), gnu_expr
, 1);
3866 case N_Enumeration_Representation_Clause
:
3867 case N_Record_Representation_Clause
:
3869 /* We do nothing with these. SEM puts the information elsewhere. */
3872 case N_Code_Statement
:
3873 if (! type_annotate_only
)
3875 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
3876 tree gnu_input_list
= 0, gnu_output_list
= 0, gnu_orig_out_list
= 0;
3877 tree gnu_clobber_list
= 0;
3880 /* First process inputs, then outputs, then clobbers. */
3881 Setup_Asm_Inputs (gnat_node
);
3882 while (Present (gnat_temp
= Asm_Input_Value ()))
3884 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3885 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3886 (Asm_Input_Constraint ()));
3889 = tree_cons (gnu_constr
, gnu_value
, gnu_input_list
);
3893 Setup_Asm_Outputs (gnat_node
);
3894 while (Present (gnat_temp
= Asm_Output_Variable ()))
3896 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3897 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3898 (Asm_Output_Constraint ()));
3901 = tree_cons (gnu_constr
, gnu_value
, gnu_orig_out_list
);
3903 = tree_cons (gnu_constr
, gnu_value
, gnu_output_list
);
3907 Clobber_Setup (gnat_node
);
3908 while ((clobber
= Clobber_Get_Next ()) != 0)
3910 = tree_cons (NULL_TREE
,
3911 build_string (strlen (clobber
) + 1, clobber
),
3914 gnu_input_list
= nreverse (gnu_input_list
);
3915 gnu_output_list
= nreverse (gnu_output_list
);
3916 gnu_orig_out_list
= nreverse (gnu_orig_out_list
);
3917 gnu_result
= build_nt (ASM_STMT
, gnu_template
, gnu_output_list
,
3918 gnu_orig_out_list
, gnu_input_list
,
3920 TREE_THIS_VOLATILE (gnu_result
) = Is_Asm_Volatile (gnat_node
);
3924 /***************************************************/
3926 /***************************************************/
3928 case N_Freeze_Entity
:
3929 process_freeze_entity (gnat_node
);
3930 process_decls (Actions (gnat_node
), Empty
, Empty
, 1, 1);
3933 case N_Itype_Reference
:
3934 if (! present_gnu_tree (Itype (gnat_node
)))
3935 process_type (Itype (gnat_node
));
3938 case N_Free_Statement
:
3939 if (! type_annotate_only
)
3941 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
3946 /* If this is a thin pointer, we must dereference it to create
3947 a fat pointer, then go back below to a thin pointer. The
3948 reason for this is that we need a fat pointer someplace in
3949 order to properly compute the size. */
3950 if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr
)))
3951 gnu_ptr
= build_unary_op (ADDR_EXPR
, NULL_TREE
,
3952 build_unary_op (INDIRECT_REF
, NULL_TREE
,
3955 /* If this is an unconstrained array, we know the object must
3956 have been allocated with the template in front of the object.
3957 So pass the template address, but get the total size. Do this
3958 by converting to a thin pointer. */
3959 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
3961 = convert (build_pointer_type
3962 (TYPE_OBJECT_RECORD_TYPE
3963 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
3966 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
3967 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_obj_type
);
3968 align
= TYPE_ALIGN (gnu_obj_type
);
3970 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
3971 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
3973 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
3974 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
3975 tree gnu_byte_offset
3976 = convert (gnu_char_ptr_type
,
3977 size_diffop (size_zero_node
, gnu_pos
));
3979 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
3980 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
3981 gnu_ptr
, gnu_byte_offset
);
3985 = build_nt (EXPR_STMT
,
3986 build_call_alloc_dealloc
3987 (gnu_ptr
, gnu_obj_size
, align
,
3988 Procedure_To_Call (gnat_node
),
3989 Storage_Pool (gnat_node
), gnat_node
));
3993 case N_Raise_Constraint_Error
:
3994 case N_Raise_Program_Error
:
3995 case N_Raise_Storage_Error
:
3997 if (type_annotate_only
)
4000 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
4001 gnu_result
= build_call_raise (UI_To_Int (Reason (gnat_node
)));
4003 /* If the type is VOID, this is a statement, so we need to
4004 generate the code for the call. Handle a Condition, if there
4006 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
4008 gnu_result
= build_nt (EXPR_STMT
, gnu_result
);
4009 TREE_TYPE (gnu_result
) = void_type_node
;
4010 TREE_SLOC (gnu_result
) = Sloc (gnat_node
);
4012 if (Present (Condition (gnat_node
)))
4013 gnu_result
= build_nt (IF_STMT
,
4014 gnat_to_gnu (Condition (gnat_node
)),
4015 gnu_result
, NULL_TREE
, NULL_TREE
);
4018 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
4021 case N_Validate_Unchecked_Conversion
:
4022 /* If the result is a pointer type, see if we are either converting
4023 from a non-pointer or from a pointer to a type with a different
4024 alias set and warn if so. If the result defined in the same unit as
4025 this unchecked convertion, we can allow this because we can know to
4026 make that type have alias set 0. */
4028 tree gnu_source_type
= gnat_to_gnu_type (Source_Type (gnat_node
));
4029 tree gnu_target_type
= gnat_to_gnu_type (Target_Type (gnat_node
));
4031 if (POINTER_TYPE_P (gnu_target_type
)
4032 && !In_Same_Source_Unit (Target_Type (gnat_node
), gnat_node
)
4033 && get_alias_set (TREE_TYPE (gnu_target_type
)) != 0
4034 && !No_Strict_Aliasing (Underlying_Type (Target_Type (gnat_node
)))
4035 && (!POINTER_TYPE_P (gnu_source_type
)
4036 || (get_alias_set (TREE_TYPE (gnu_source_type
))
4037 != get_alias_set (TREE_TYPE (gnu_target_type
)))))
4040 ("?possible aliasing problem for type&",
4041 gnat_node
, Target_Type (gnat_node
));
4043 ("\\?use -fno-strict-aliasing switch for references",
4046 ("\\?or use `pragma No_Strict_Aliasing (&);`",
4047 gnat_node
, Target_Type (gnat_node
));
4052 case N_Raise_Statement
:
4053 case N_Function_Specification
:
4054 case N_Procedure_Specification
:
4056 case N_Component_Association
:
4059 if (! type_annotate_only
)
4063 /* If the result is a statement, set needed flags and return it. */
4064 if (IS_STMT (gnu_result
))
4066 TREE_TYPE (gnu_result
) = void_type_node
;
4067 TREE_THIS_VOLATILE (gnu_result
) = TREE_SIDE_EFFECTS (gnu_result
) = 1;
4068 TREE_SLOC (gnu_result
) = Sloc (gnat_node
);
4072 /* If the result is a constant that overflows, raise constraint error. */
4073 else if (TREE_CODE (gnu_result
) == INTEGER_CST
4074 && TREE_CONSTANT_OVERFLOW (gnu_result
))
4076 post_error ("Constraint_Error will be raised at run-time?", gnat_node
);
4079 = build1 (NULL_EXPR
, gnu_result_type
,
4080 build_call_raise (CE_Overflow_Check_Failed
));
4083 /* If our result has side-effects and is of an unconstrained type,
4084 make a SAVE_EXPR so that we can be sure it will only be referenced
4085 once. Note we must do this before any conversions. */
4086 if (TREE_SIDE_EFFECTS (gnu_result
)
4087 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
4088 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))))
4089 gnu_result
= gnat_stabilize_reference (gnu_result
, 0);
4091 /* Now convert the result to the proper type. If the type is void or if
4092 we have no result, return error_mark_node to show we have no result.
4093 If the type of the result is correct or if we have a label (which doesn't
4094 have any well-defined type), return our result. Also don't do the
4095 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
4096 since those are the cases where the front end may have the type wrong due
4097 to "instantiating" the unconstrained record with discriminant values
4098 or if this is a FIELD_DECL. If this is the Name of an assignment
4099 statement or a parameter of a procedure call, return what we have since
4100 the RHS has to be converted to our type there in that case, unless
4101 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
4102 record types with the same name, the expression type has integral mode,
4103 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
4104 we are converting from a packable type to its actual type and we need
4105 those conversions to be NOPs in order for assignments into these types to
4106 work properly if the inner object is a bitfield and hence can't have
4107 its address taken. Finally, don't convert integral types that are the
4108 operand of an unchecked conversion since we need to ignore those
4109 conversions (for 'Valid). Otherwise, convert the result to the proper
4112 if (Present (Parent (gnat_node
))
4113 && ((Nkind (Parent (gnat_node
)) == N_Assignment_Statement
4114 && Name (Parent (gnat_node
)) == gnat_node
)
4115 || (Nkind (Parent (gnat_node
)) == N_Procedure_Call_Statement
4116 && Name (Parent (gnat_node
)) != gnat_node
)
4117 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
4118 && ! AGGREGATE_TYPE_P (gnu_result_type
)
4119 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
4120 || Nkind (Parent (gnat_node
)) == N_Parameter_Association
)
4121 && ! (TYPE_SIZE (gnu_result_type
) != 0
4122 && TYPE_SIZE (TREE_TYPE (gnu_result
)) != 0
4123 && (AGGREGATE_TYPE_P (gnu_result_type
)
4124 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
4125 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
4126 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
4128 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
4129 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
))
4130 && (CONTAINS_PLACEHOLDER_P
4131 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
4132 && ! (TREE_CODE (gnu_result_type
) == RECORD_TYPE
4133 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type
))))
4135 /* In this case remove padding only if the inner object is of
4136 self-referential size: in that case it must be an object of
4137 unconstrained type with a default discriminant. In other cases,
4138 we want to avoid copying too much data. */
4139 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4140 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
4141 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
4142 (TREE_TYPE (TYPE_FIELDS
4143 (TREE_TYPE (gnu_result
))))))
4144 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4148 else if (TREE_CODE (gnu_result
) == LABEL_DECL
4149 || TREE_CODE (gnu_result
) == FIELD_DECL
4150 || TREE_CODE (gnu_result
) == ERROR_MARK
4151 || (TYPE_SIZE (gnu_result_type
) != 0
4152 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
4153 && TREE_CODE (gnu_result
) != INDIRECT_REF
4154 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type
)))
4155 || ((TYPE_NAME (gnu_result_type
)
4156 == TYPE_NAME (TREE_TYPE (gnu_result
)))
4157 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
4158 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4159 && TYPE_MODE (gnu_result_type
) == BLKmode
4160 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result
)))
4163 /* Remove any padding record, but do nothing more in this case. */
4164 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
4165 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
4166 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4170 else if (gnu_result
== error_mark_node
4171 || gnu_result_type
== void_type_node
)
4172 gnu_result
= error_mark_node
;
4173 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
4174 gnu_result
= convert (gnu_result_type
, gnu_result
);
4176 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4177 while ((TREE_CODE (gnu_result
) == NOP_EXPR
4178 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
4179 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
4180 gnu_result
= TREE_OPERAND (gnu_result
, 0);
4185 /* INSN is a list of insns. Return the first rtl in the list that isn't
4186 an INSN_NOTE_DELETED. */
4189 first_nondeleted_insn (rtx insns
)
4191 for (; insns
&& GET_CODE (insns
) == NOTE
4192 && NOTE_LINE_NUMBER (insns
) == NOTE_INSN_DELETED
;
4193 insns
= NEXT_INSN (insns
))
4199 /* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */
4202 build_block_stmt (List_Id gnat_list
)
4204 tree gnu_result
= NULL_TREE
;
4207 if (No (gnat_list
) || Is_Empty_List (gnat_list
))
4210 for (gnat_node
= First (gnat_list
);
4211 Present (gnat_node
);
4212 gnat_node
= Next (gnat_node
))
4213 gnu_result
= chainon (gnat_to_gnu (gnat_node
), gnu_result
);
4215 gnu_result
= build_nt (BLOCK_STMT
, nreverse (gnu_result
));
4216 TREE_SLOC (gnu_result
) = TREE_SLOC (BLOCK_STMT_LIST (gnu_result
));
4217 TREE_TYPE (gnu_result
) = void_type_node
;
4221 /* Build an EXPR_STMT to evaluate INSNS. Use Sloc from GNAT_NODE. */
4224 make_expr_stmt_from_rtl (rtx insns
, Node_Id gnat_node
)
4226 tree gnu_result
= make_node (RTL_EXPR
);
4228 TREE_TYPE (gnu_result
) = void_type_node
;
4229 RTL_EXPR_RTL (gnu_result
) = RTL_EXPR_ALT_RTL (gnu_result
) = const0_rtx
;
4230 RTL_EXPR_SEQUENCE (gnu_result
) = insns
;
4231 rtl_expr_chain
= tree_cons (NULL_TREE
, gnu_result
, rtl_expr_chain
);
4233 gnu_result
= build_nt (EXPR_STMT
, gnu_result
);
4234 TREE_SLOC (gnu_result
) = Sloc (gnat_node
);
4235 TREE_TYPE (gnu_result
) = void_type_node
;
4240 /* GNU_STMT is a statement. We generate code for that statement. */
4243 gnat_expand_stmt (tree gnu_stmt
)
4245 tree gnu_elmt
, gnu_elmt_2
;
4247 if (TREE_SLOC (gnu_stmt
))
4248 set_lineno_from_sloc (TREE_SLOC (gnu_stmt
), 1);
4250 switch (TREE_CODE (gnu_stmt
))
4253 expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt
));
4257 for (gnu_elmt
= BLOCK_STMT_LIST (gnu_stmt
); gnu_elmt
;
4258 gnu_elmt
= TREE_CHAIN (gnu_elmt
))
4259 expand_expr_stmt (gnu_elmt
);
4263 expand_start_cond (IF_STMT_COND (gnu_stmt
), 0);
4265 if (IF_STMT_TRUE (gnu_stmt
))
4266 expand_expr_stmt (IF_STMT_TRUE (gnu_stmt
));
4268 for (gnu_elmt
= IF_STMT_ELSEIF (gnu_stmt
); gnu_elmt
;
4269 gnu_elmt
= TREE_CHAIN (gnu_elmt
))
4271 expand_start_else ();
4272 set_lineno_from_sloc (TREE_SLOC (gnu_elmt
), 1);
4273 expand_elseif (IF_STMT_COND (gnu_elmt
));
4274 expand_expr_stmt (IF_STMT_TRUE (gnu_elmt
));
4277 if (IF_STMT_ELSE (gnu_stmt
))
4279 expand_start_else ();
4280 expand_expr_stmt (IF_STMT_ELSE (gnu_stmt
));
4287 TREE_USED (GOTO_STMT_LABEL (gnu_stmt
)) = 1;
4288 expand_goto (GOTO_STMT_LABEL (gnu_stmt
));
4292 expand_label (LABEL_STMT_LABEL (gnu_stmt
));
4296 if (RETURN_STMT_EXPR (gnu_stmt
))
4297 expand_return (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
4298 DECL_RESULT (current_function_decl
),
4299 RETURN_STMT_EXPR (gnu_stmt
)));
4301 expand_null_return ();
4305 expand_asm_operands (ASM_STMT_TEMPLATE (gnu_stmt
),
4306 ASM_STMT_OUTPUT (gnu_stmt
),
4307 ASM_STMT_INPUT (gnu_stmt
),
4308 ASM_STMT_CLOBBER (gnu_stmt
),
4309 TREE_THIS_VOLATILE (gnu_stmt
), input_location
);
4311 /* Copy all the intermediate outputs into the specified outputs. */
4312 for ((gnu_elmt
= ASM_STMT_OUTPUT (gnu_stmt
),
4313 gnu_elmt_2
= ASM_STMT_ORIG_OUT (gnu_stmt
));
4315 (gnu_elmt
= TREE_CHAIN (gnu_elmt
),
4316 gnu_elmt_2
= TREE_CHAIN (gnu_elmt_2
)))
4317 if (TREE_VALUE (gnu_elmt
) != TREE_VALUE (gnu_elmt_2
))
4320 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
4321 TREE_VALUE (gnu_elmt_2
),
4322 TREE_VALUE (gnu_elmt
)));
4332 /* Force references to each of the entities in packages GNAT_NODE with's
4333 so that the debugging information for all of them are identical
4334 in all clients. Operate recursively on anything it with's, but check
4335 that we aren't elaborating something more than once. */
4337 /* The reason for this routine's existence is two-fold.
4338 First, with some debugging formats, notably MDEBUG on SGI
4339 IRIX, the linker will remove duplicate debugging information if two
4340 clients have identical debugguing information. With the normal scheme
4341 of elaboration, this does not usually occur, since entities in with'ed
4342 packages are elaborated on demand, and if clients have different usage
4343 patterns, the normal case, then the order and selection of entities
4344 will differ. In most cases however, it seems that linkers do not know
4345 how to eliminate duplicate debugging information, even if it is
4346 identical, so the use of this routine would increase the total amount
4347 of debugging information in the final executable.
4349 Second, this routine is called in type_annotate mode, to compute DDA
4350 information for types in withed units, for ASIS use */
4353 elaborate_all_entities (Node_Id gnat_node
)
4355 Entity_Id gnat_with_clause
, gnat_entity
;
4357 /* Process each unit only once. As we trace the context of all relevant
4358 units transitively, including generic bodies, we may encounter the
4359 same generic unit repeatedly */
4361 if (!present_gnu_tree (gnat_node
))
4362 save_gnu_tree (gnat_node
, integer_zero_node
, 1);
4364 /* Save entities in all context units. A body may have an implicit_with
4365 on its own spec, if the context includes a child unit, so don't save
4368 for (gnat_with_clause
= First (Context_Items (gnat_node
));
4369 Present (gnat_with_clause
);
4370 gnat_with_clause
= Next (gnat_with_clause
))
4371 if (Nkind (gnat_with_clause
) == N_With_Clause
4372 && ! present_gnu_tree (Library_Unit (gnat_with_clause
))
4373 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
4375 elaborate_all_entities (Library_Unit (gnat_with_clause
));
4377 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
4379 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
4380 Present (gnat_entity
);
4381 gnat_entity
= Next_Entity (gnat_entity
))
4382 if (Is_Public (gnat_entity
)
4383 && Convention (gnat_entity
) != Convention_Intrinsic
4384 && Ekind (gnat_entity
) != E_Package
4385 && Ekind (gnat_entity
) != E_Package_Body
4386 && Ekind (gnat_entity
) != E_Operator
4387 && ! (IN (Ekind (gnat_entity
), Type_Kind
)
4388 && ! Is_Frozen (gnat_entity
))
4389 && ! ((Ekind (gnat_entity
) == E_Procedure
4390 || Ekind (gnat_entity
) == E_Function
)
4391 && Is_Intrinsic_Subprogram (gnat_entity
))
4392 && ! IN (Ekind (gnat_entity
), Named_Kind
)
4393 && ! IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
4394 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4396 else if (Ekind (Entity (Name (gnat_with_clause
))) == E_Generic_Package
)
4399 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause
)));
4401 /* Retrieve compilation unit node of generic body. */
4402 while (Present (gnat_body
)
4403 && Nkind (gnat_body
) != N_Compilation_Unit
)
4404 gnat_body
= Parent (gnat_body
);
4406 /* If body is available, elaborate its context. */
4407 if (Present (gnat_body
))
4408 elaborate_all_entities (gnat_body
);
4412 if (Nkind (Unit (gnat_node
)) == N_Package_Body
&& type_annotate_only
)
4413 elaborate_all_entities (Library_Unit (gnat_node
));
4416 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
4419 process_freeze_entity (Node_Id gnat_node
)
4421 Entity_Id gnat_entity
= Entity (gnat_node
);
4425 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
4426 && present_gnu_tree (Declaration_Node (gnat_entity
)))
4427 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
4429 /* If this is a package, need to generate code for the package. */
4430 if (Ekind (gnat_entity
) == E_Package
)
4433 (Parent (Corresponding_Body
4434 (Parent (Declaration_Node (gnat_entity
)))));
4438 /* Check for old definition after the above call. This Freeze_Node
4439 might be for one its Itypes. */
4441 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4443 /* If this entity has an Address representation clause, GNU_OLD is the
4444 address, so discard it here. */
4445 if (Present (Address_Clause (gnat_entity
)))
4448 /* Don't do anything for class-wide types they are always
4449 transformed into their root type. */
4450 if (Ekind (gnat_entity
) == E_Class_Wide_Type
4451 || (Ekind (gnat_entity
) == E_Class_Wide_Subtype
4452 && Present (Equivalent_Type (gnat_entity
))))
4455 /* Don't do anything for subprograms that may have been elaborated before
4456 their freeze nodes. This can happen, for example because of an inner call
4457 in an instance body. */
4459 && TREE_CODE (gnu_old
) == FUNCTION_DECL
4460 && (Ekind (gnat_entity
) == E_Function
4461 || Ekind (gnat_entity
) == E_Procedure
))
4464 /* If we have a non-dummy type old tree, we have nothing to do. Unless
4465 this is the public view of a private type whose full view was not
4466 delayed, this node was never delayed as it should have been.
4467 Also allow this to happen for concurrent types since we may have
4468 frozen both the Corresponding_Record_Type and this type. */
4470 && ! (TREE_CODE (gnu_old
) == TYPE_DECL
4471 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
4473 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4474 && Present (Full_View (gnat_entity
))
4475 && No (Freeze_Node (Full_View (gnat_entity
))))
4477 else if (Is_Concurrent_Type (gnat_entity
))
4483 /* Reset the saved tree, if any, and elaborate the object or type for real.
4484 If there is a full declaration, elaborate it and copy the type to
4485 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4486 a class wide type or subtype. */
4489 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4490 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4491 && Present (Full_View (gnat_entity
))
4492 && present_gnu_tree (Full_View (gnat_entity
)))
4493 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, 0);
4494 if (Present (Class_Wide_Type (gnat_entity
))
4495 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4496 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, 0);
4499 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4500 && Present (Full_View (gnat_entity
)))
4502 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
4504 /* The above call may have defined this entity (the simplest example
4505 of this is when we have a private enumeral type since the bounds
4506 will have the public view. */
4507 if (! present_gnu_tree (gnat_entity
))
4508 save_gnu_tree (gnat_entity
, gnu_new
, 0);
4509 if (Present (Class_Wide_Type (gnat_entity
))
4510 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4511 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, 0);
4514 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
4516 /* If we've made any pointers to the old version of this type, we
4517 have to update them. */
4519 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4520 TREE_TYPE (gnu_new
));
4523 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4524 N_Compilation_Unit. */
4527 process_inlined_subprograms (Node_Id gnat_node
)
4529 Entity_Id gnat_entity
;
4532 /* If we can inline, generate RTL for all the inlined subprograms.
4533 Define the entity first so we set DECL_EXTERNAL. */
4534 if (optimize
> 0 && ! flag_no_inline
)
4535 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4536 Present (gnat_entity
);
4537 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4539 gnat_body
= Parent (Declaration_Node (gnat_entity
));
4541 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4543 /* ??? This really should always be Present. */
4544 if (No (Corresponding_Body (gnat_body
)))
4548 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4551 if (Present (gnat_body
))
4553 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4554 gnat_to_code (gnat_body
);
4559 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4560 We make two passes, one to elaborate anything other than bodies (but
4561 we declare a function if there was no spec). The second pass
4562 elaborates the bodies.
4564 GNAT_END_LIST gives the element in the list past the end. Normally,
4565 this is Empty, but can be First_Real_Statement for a
4566 Handled_Sequence_Of_Statements.
4568 We make a complete pass through both lists if PASS1P is true, then make
4569 the second pass over both lists if PASS2P is true. The lists usually
4570 correspond to the public and private parts of a package. */
4573 process_decls (List_Id gnat_decls
,
4574 List_Id gnat_decls2
,
4575 Node_Id gnat_end_list
,
4579 List_Id gnat_decl_array
[2];
4583 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
4586 for (i
= 0; i
<= 1; i
++)
4587 if (Present (gnat_decl_array
[i
]))
4588 for (gnat_decl
= First (gnat_decl_array
[i
]);
4589 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4591 set_lineno (gnat_decl
, 0);
4593 /* For package specs, we recurse inside the declarations,
4594 thus taking the two pass approach inside the boundary. */
4595 if (Nkind (gnat_decl
) == N_Package_Declaration
4596 && (Nkind (Specification (gnat_decl
)
4597 == N_Package_Specification
)))
4598 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4599 Private_Declarations (Specification (gnat_decl
)),
4602 /* Similarly for any declarations in the actions of a
4604 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4606 process_freeze_entity (gnat_decl
);
4607 process_decls (Actions (gnat_decl
), Empty
, Empty
, 1, 0);
4610 /* Package bodies with freeze nodes get their elaboration deferred
4611 until the freeze node, but the code must be placed in the right
4612 place, so record the code position now. */
4613 else if (Nkind (gnat_decl
) == N_Package_Body
4614 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
4615 record_code_position (gnat_decl
);
4617 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
4618 && Present (Library_Unit (gnat_decl
))
4619 && Present (Freeze_Node
4622 (Library_Unit (gnat_decl
)))))))
4623 record_code_position
4624 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
4626 /* We defer most subprogram bodies to the second pass. */
4627 else if (Nkind (gnat_decl
) == N_Subprogram_Body
)
4629 if (Acts_As_Spec (gnat_decl
))
4631 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
4633 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
4634 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4635 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4638 /* For bodies and stubs that act as their own specs, the entity
4639 itself must be elaborated in the first pass, because it may
4640 be used in other declarations. */
4641 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
4643 Node_Id gnat_subprog_id
=
4644 Defining_Entity (Specification (gnat_decl
));
4646 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
4647 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
4648 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4649 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4652 /* Concurrent stubs stand for the corresponding subprogram bodies,
4653 which are deferred like other bodies. */
4654 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
4655 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4659 gnat_to_code (gnat_decl
);
4662 /* Here we elaborate everything we deferred above except for package bodies,
4663 which are elaborated at their freeze nodes. Note that we must also
4664 go inside things (package specs and freeze nodes) the first pass did. */
4666 for (i
= 0; i
<= 1; i
++)
4667 if (Present (gnat_decl_array
[i
]))
4668 for (gnat_decl
= First (gnat_decl_array
[i
]);
4669 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4671 if (Nkind (gnat_decl
) == N_Subprogram_Body
4672 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
4673 || Nkind (gnat_decl
) == N_Task_Body_Stub
4674 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4675 gnat_to_code (gnat_decl
);
4677 else if (Nkind (gnat_decl
) == N_Package_Declaration
4678 && (Nkind (Specification (gnat_decl
)
4679 == N_Package_Specification
)))
4680 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4681 Private_Declarations (Specification (gnat_decl
)),
4684 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4685 process_decls (Actions (gnat_decl
), Empty
, Empty
, 0, 1);
4689 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4690 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4691 which we have to check. */
4694 emit_range_check (tree gnu_expr
, Entity_Id gnat_range_type
)
4696 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
4697 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
4698 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
4699 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
4701 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4702 we can't do anything since we might be truncating the bounds. No
4703 check is needed in this case. */
4704 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
4705 && (TYPE_PRECISION (gnu_compare_type
)
4706 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
4709 /* Checked expressions must be evaluated only once. */
4710 gnu_expr
= protect_multiple_eval (gnu_expr
);
4712 /* There's no good type to use here, so we might as well use
4713 integer_type_node. Note that the form of the check is
4714 (not (expr >= lo)) or (not (expr >= hi))
4715 the reason for this slightly convoluted form is that NaN's
4716 are not considered to be in range in the float case. */
4718 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4720 (build_binary_op (GE_EXPR
, integer_type_node
,
4721 convert (gnu_compare_type
, gnu_expr
),
4722 convert (gnu_compare_type
, gnu_low
))),
4724 (build_binary_op (LE_EXPR
, integer_type_node
,
4725 convert (gnu_compare_type
, gnu_expr
),
4726 convert (gnu_compare_type
,
4728 gnu_expr
, CE_Range_Check_Failed
);
4731 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4732 which we are about to index, GNU_EXPR is the index expression to be
4733 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4734 against which GNU_EXPR has to be checked. Note that for index
4735 checking we cannot use the emit_range_check function (although very
4736 similar code needs to be generated in both cases) since for index
4737 checking the array type against which we are checking the indeces
4738 may be unconstrained and consequently we need to retrieve the
4739 actual index bounds from the array object itself
4740 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4741 subprograms having unconstrained array formal parameters */
4744 emit_index_check (tree gnu_array_object
,
4749 tree gnu_expr_check
;
4751 /* Checked expressions must be evaluated only once. */
4752 gnu_expr
= protect_multiple_eval (gnu_expr
);
4754 /* Must do this computation in the base type in case the expression's
4755 type is an unsigned subtypes. */
4756 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
4758 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4759 the object we are handling. */
4760 gnu_low
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low
, gnu_array_object
);
4761 gnu_high
= SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high
, gnu_array_object
);
4763 /* There's no good type to use here, so we might as well use
4764 integer_type_node. */
4766 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4767 build_binary_op (LT_EXPR
, integer_type_node
,
4769 convert (TREE_TYPE (gnu_expr_check
),
4771 build_binary_op (GT_EXPR
, integer_type_node
,
4773 convert (TREE_TYPE (gnu_expr_check
),
4775 gnu_expr
, CE_Index_Check_Failed
);
4778 /* Given GNU_COND which contains the condition corresponding to an access,
4779 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4780 that returns GNU_EXPR if GNU_COND is false and raises a
4781 CONSTRAINT_ERROR if GNU_COND is true. REASON is the code that says
4782 why the exception was raised. */
4785 emit_check (tree gnu_cond
, tree gnu_expr
, int reason
)
4790 gnu_call
= build_call_raise (reason
);
4792 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
4793 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
4794 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
4796 gnu_result
= fold (build (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
4797 build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
),
4798 gnu_call
, gnu_expr
),
4801 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
4802 protect it. Otherwise, show GNU_RESULT has no side effects: we
4803 don't need to evaluate it just for the check. */
4804 if (TREE_SIDE_EFFECTS (gnu_expr
))
4806 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
, gnu_result
);
4808 TREE_SIDE_EFFECTS (gnu_result
) = 0;
4810 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
4811 we will repeatedly do the test. It would be nice if GCC was able
4812 to optimize this and only do it once. */
4813 return save_expr (gnu_result
);
4816 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4817 overflow checks if OVERFLOW_P is nonzero and range checks if
4818 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
4819 If TRUNCATE_P is nonzero, do a float to integer conversion with
4820 truncation; otherwise round. */
4823 convert_with_check (Entity_Id gnat_type
,
4829 tree gnu_type
= get_unpadded_type (gnat_type
);
4830 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
4831 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
4832 tree gnu_base_type
= get_base_type (gnu_type
);
4833 tree gnu_ada_base_type
= get_ada_base_type (gnu_type
);
4834 tree gnu_result
= gnu_expr
;
4836 /* If we are not doing any checks, the output is an integral type, and
4837 the input is not a floating type, just do the conversion. This
4838 shortcut is required to avoid problems with packed array types
4839 and simplifies code in all cases anyway. */
4840 if (! range_p
&& ! overflow_p
&& INTEGRAL_TYPE_P (gnu_base_type
)
4841 && ! FLOAT_TYPE_P (gnu_in_type
))
4842 return convert (gnu_type
, gnu_expr
);
4844 /* First convert the expression to its base type. This
4845 will never generate code, but makes the tests below much simpler.
4846 But don't do this if converting from an integer type to an unconstrained
4847 array type since then we need to get the bounds from the original
4849 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
4850 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
4852 /* If overflow checks are requested, we need to be sure the result will
4853 fit in the output base type. But don't do this if the input
4854 is integer and the output floating-point. */
4856 && ! (FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
4858 /* Ensure GNU_EXPR only gets evaluated once. */
4859 tree gnu_input
= protect_multiple_eval (gnu_result
);
4860 tree gnu_cond
= integer_zero_node
;
4861 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
4862 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
4863 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
4864 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
4866 /* Convert the lower bounds to signed types, so we're sure we're
4867 comparing them properly. Likewise, convert the upper bounds
4868 to unsigned types. */
4869 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TYPE_UNSIGNED (gnu_in_basetype
))
4870 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
4872 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4873 && !TYPE_UNSIGNED (gnu_in_basetype
))
4874 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
4876 if (INTEGRAL_TYPE_P (gnu_base_type
) && TYPE_UNSIGNED (gnu_base_type
))
4877 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
4879 if (INTEGRAL_TYPE_P (gnu_base_type
) && !TYPE_UNSIGNED (gnu_base_type
))
4880 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
4882 /* Check each bound separately and only if the result bound
4883 is tighter than the bound on the input type. Note that all the
4884 types are base types, so the bounds must be constant. Also,
4885 the comparison is done in the base type of the input, which
4886 always has the proper signedness. First check for input
4887 integer (which means output integer), output float (which means
4888 both float), or mixed, in which case we always compare.
4889 Note that we have to do the comparison which would *fail* in the
4890 case of an error since if it's an FP comparison and one of the
4891 values is a NaN or Inf, the comparison will fail. */
4892 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4893 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
4894 : (FLOAT_TYPE_P (gnu_base_type
)
4895 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
4896 TREE_REAL_CST (gnu_out_lb
))
4900 (build_binary_op (GE_EXPR
, integer_type_node
,
4901 gnu_input
, convert (gnu_in_basetype
,
4904 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4905 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
4906 : (FLOAT_TYPE_P (gnu_base_type
)
4907 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
4908 TREE_REAL_CST (gnu_in_lb
))
4911 = build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
, gnu_cond
,
4913 (build_binary_op (LE_EXPR
, integer_type_node
,
4915 convert (gnu_in_basetype
,
4918 if (! integer_zerop (gnu_cond
))
4919 gnu_result
= emit_check (gnu_cond
, gnu_input
,
4920 CE_Overflow_Check_Failed
);
4923 /* Now convert to the result base type. If this is a non-truncating
4924 float-to-integer conversion, round. */
4925 if (INTEGRAL_TYPE_P (gnu_ada_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
4928 tree gnu_point_5
= build_real (gnu_in_basetype
, dconstp5
);
4929 tree gnu_minus_point_5
= build_real (gnu_in_basetype
, dconstmp5
);
4930 tree gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
4931 tree gnu_saved_result
= save_expr (gnu_result
);
4932 tree gnu_comp
= build (GE_EXPR
, integer_type_node
,
4933 gnu_saved_result
, gnu_zero
);
4934 tree gnu_adjust
= build (COND_EXPR
, gnu_in_basetype
, gnu_comp
,
4935 gnu_point_5
, gnu_minus_point_5
);
4938 = build (PLUS_EXPR
, gnu_in_basetype
, gnu_saved_result
, gnu_adjust
);
4941 if (TREE_CODE (gnu_ada_base_type
) == INTEGER_TYPE
4942 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type
)
4943 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
4944 gnu_result
= unchecked_convert (gnu_ada_base_type
, gnu_result
, 0);
4946 gnu_result
= convert (gnu_ada_base_type
, gnu_result
);
4948 /* Finally, do the range check if requested. Note that if the
4949 result type is a modular type, the range check is actually
4950 an overflow check. */
4953 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
4954 && TYPE_MODULAR_P (gnu_base_type
) && overflow_p
))
4955 gnu_result
= emit_range_check (gnu_result
, gnat_type
);
4957 return convert (gnu_type
, gnu_result
);
4960 /* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
4961 it is an expression involving computation or if it involves a bitfield
4962 reference. This returns the same as gnat_mark_addressable in most
4966 addressable_p (tree gnu_expr
)
4968 switch (TREE_CODE (gnu_expr
))
4974 /* All DECLs are addressable: if they are in a register, we can force
4978 case UNCONSTRAINED_ARRAY_REF
:
4986 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
4987 && (! DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr
, 1))
4988 || ! flag_strict_aliasing
)
4989 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4991 case ARRAY_REF
: case ARRAY_RANGE_REF
:
4992 case REALPART_EXPR
: case IMAGPART_EXPR
:
4994 return addressable_p (TREE_OPERAND (gnu_expr
, 0));
4997 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
4998 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
5000 case VIEW_CONVERT_EXPR
:
5002 /* This is addressable if we can avoid a copy. */
5003 tree type
= TREE_TYPE (gnu_expr
);
5004 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
5006 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
5007 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
5008 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
5009 || ((TYPE_MODE (type
) == BLKmode
5010 || TYPE_MODE (inner_type
) == BLKmode
)
5011 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
5012 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
5013 || TYPE_ALIGN_OK (type
)
5014 || TYPE_ALIGN_OK (inner_type
))))
5015 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
5023 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
5024 a separate Freeze node exists, delay the bulk of the processing. Otherwise
5025 make a GCC type for GNAT_ENTITY and set up the correspondance. */
5028 process_type (Entity_Id gnat_entity
)
5031 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
5034 /* If we are to delay elaboration of this type, just do any
5035 elaborations needed for expressions within the declaration and
5036 make a dummy type entry for this node and its Full_View (if
5037 any) in case something points to it. Don't do this if it
5038 has already been done (the only way that can happen is if
5039 the private completion is also delayed). */
5040 if (Present (Freeze_Node (gnat_entity
))
5041 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
5042 && Present (Full_View (gnat_entity
))
5043 && Freeze_Node (Full_View (gnat_entity
))
5044 && ! present_gnu_tree (Full_View (gnat_entity
))))
5046 elaborate_entity (gnat_entity
);
5050 tree gnu_decl
= create_type_decl (get_entity_name (gnat_entity
),
5051 make_dummy_type (gnat_entity
),
5054 save_gnu_tree (gnat_entity
, gnu_decl
, 0);
5055 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
5056 && Present (Full_View (gnat_entity
)))
5057 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, 0);
5063 /* If we saved away a dummy type for this node it means that this
5064 made the type that corresponds to the full type of an incomplete
5065 type. Clear that type for now and then update the type in the
5069 if (TREE_CODE (gnu_old
) != TYPE_DECL
5070 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)))
5072 /* If this was a withed access type, this is not an error
5073 and merely indicates we've already elaborated the type
5075 if (Is_Type (gnat_entity
) && From_With_Type (gnat_entity
))
5081 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
5084 /* Now fully elaborate the type. */
5085 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
5086 if (TREE_CODE (gnu_new
) != TYPE_DECL
)
5089 /* If we have an old type and we've made pointers to this type,
5090 update those pointers. */
5092 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
5093 TREE_TYPE (gnu_new
));
5095 /* If this is a record type corresponding to a task or protected type
5096 that is a completion of an incomplete type, perform a similar update
5098 /* ??? Including protected types here is a guess. */
5100 if (IN (Ekind (gnat_entity
), Record_Kind
)
5101 && Is_Concurrent_Record_Type (gnat_entity
)
5102 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
5105 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
5107 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
5109 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
5112 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
5113 TREE_TYPE (gnu_new
));
5117 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
5118 GNU_TYPE is the GCC type of the corresponding record.
5120 Return a CONSTRUCTOR to build the record. */
5123 assoc_to_constructor (Node_Id gnat_assoc
, tree gnu_type
)
5125 tree gnu_field
, gnu_list
, gnu_result
;
5127 /* We test for GNU_FIELD being empty in the case where a variant
5128 was the last thing since we don't take things off GNAT_ASSOC in
5129 that case. We check GNAT_ASSOC in case we have a variant, but it
5132 for (gnu_list
= NULL_TREE
; Present (gnat_assoc
);
5133 gnat_assoc
= Next (gnat_assoc
))
5135 Node_Id gnat_field
= First (Choices (gnat_assoc
));
5136 tree gnu_field
= gnat_to_gnu_entity (Entity (gnat_field
), NULL_TREE
, 0);
5137 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
5139 /* The expander is supposed to put a single component selector name
5140 in every record component association */
5141 if (Next (gnat_field
))
5144 /* Before assigning a value in an aggregate make sure range checks
5145 are done if required. Then convert to the type of the field. */
5146 if (Do_Range_Check (Expression (gnat_assoc
)))
5147 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
));
5149 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
5151 /* Add the field and expression to the list. */
5152 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
5155 gnu_result
= extract_values (gnu_list
, gnu_type
);
5157 /* Verify every enty in GNU_LIST was used. */
5158 for (gnu_field
= gnu_list
; gnu_field
; gnu_field
= TREE_CHAIN (gnu_field
))
5159 if (! TREE_ADDRESSABLE (gnu_field
))
5165 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
5166 is the first element of an array aggregate. It may itself be an
5167 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
5168 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
5169 of the array component. It is needed for range checking. */
5172 pos_to_constructor (Node_Id gnat_expr
,
5173 tree gnu_array_type
,
5174 Entity_Id gnat_component_type
)
5177 tree gnu_expr_list
= NULL_TREE
;
5179 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
5181 /* If the expression is itself an array aggregate then first build the
5182 innermost constructor if it is part of our array (multi-dimensional
5185 if (Nkind (gnat_expr
) == N_Aggregate
5186 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
5187 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
5188 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
5189 TREE_TYPE (gnu_array_type
),
5190 gnat_component_type
);
5193 gnu_expr
= gnat_to_gnu (gnat_expr
);
5195 /* before assigning the element to the array make sure it is
5197 if (Do_Range_Check (gnat_expr
))
5198 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
);
5202 = tree_cons (NULL_TREE
, convert (TREE_TYPE (gnu_array_type
), gnu_expr
),
5206 return gnat_build_constructor (gnu_array_type
, nreverse (gnu_expr_list
));
5209 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5210 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
5211 of the associations that are from RECORD_TYPE. If we see an internal
5212 record, make a recursive call to fill it in as well. */
5215 extract_values (tree values
, tree record_type
)
5217 tree result
= NULL_TREE
;
5220 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
5224 /* _Parent is an internal field, but may have values in the aggregate,
5225 so check for values first. */
5226 if ((tem
= purpose_member (field
, values
)) != 0)
5228 value
= TREE_VALUE (tem
);
5229 TREE_ADDRESSABLE (tem
) = 1;
5232 else if (DECL_INTERNAL_P (field
))
5234 value
= extract_values (values
, TREE_TYPE (field
));
5235 if (TREE_CODE (value
) == CONSTRUCTOR
5236 && CONSTRUCTOR_ELTS (value
) == 0)
5240 /* If we have a record subtype, the names will match, but not the
5241 actual FIELD_DECLs. */
5242 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
5243 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
5245 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
5246 TREE_ADDRESSABLE (tem
) = 1;
5252 result
= tree_cons (field
, value
, result
);
5255 return gnat_build_constructor (record_type
, nreverse (result
));
5258 /* EXP is to be treated as an array or record. Handle the cases when it is
5259 an access object and perform the required dereferences. */
5262 maybe_implicit_deref (tree exp
)
5264 /* If the type is a pointer, dereference it. */
5266 if (POINTER_TYPE_P (TREE_TYPE (exp
)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp
)))
5267 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
5269 /* If we got a padded type, remove it too. */
5270 if (TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
5271 && TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
5272 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
5277 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
5280 protect_multiple_eval (tree exp
)
5282 tree type
= TREE_TYPE (exp
);
5284 /* If this has no side effects, we don't need to do anything. */
5285 if (! TREE_SIDE_EFFECTS (exp
))
5288 /* If it is a conversion, protect what's inside the conversion.
5289 Similarly, if we're indirectly referencing something, we only
5290 actually need to protect the address since the data itself can't
5291 change in these situations. */
5292 else if (TREE_CODE (exp
) == NON_LVALUE_EXPR
5293 || TREE_CODE (exp
) == NOP_EXPR
|| TREE_CODE (exp
) == CONVERT_EXPR
5294 || TREE_CODE (exp
) == VIEW_CONVERT_EXPR
5295 || TREE_CODE (exp
) == INDIRECT_REF
5296 || TREE_CODE (exp
) == UNCONSTRAINED_ARRAY_REF
)
5297 return build1 (TREE_CODE (exp
), type
,
5298 protect_multiple_eval (TREE_OPERAND (exp
, 0)));
5300 /* If EXP is a fat pointer or something that can be placed into a register,
5301 just make a SAVE_EXPR. */
5302 if (TYPE_FAT_POINTER_P (type
) || TYPE_MODE (type
) != BLKmode
)
5303 return save_expr (exp
);
5305 /* Otherwise, dereference, protect the address, and re-reference. */
5308 build_unary_op (INDIRECT_REF
, type
,
5309 save_expr (build_unary_op (ADDR_EXPR
,
5310 build_reference_type (type
),
5314 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5315 how to handle our new nodes and we take an extra argument that says
5316 whether to force evaluation of everything. */
5319 gnat_stabilize_reference (tree ref
, int force
)
5321 tree type
= TREE_TYPE (ref
);
5322 enum tree_code code
= TREE_CODE (ref
);
5330 /* No action is needed in this case. */
5336 case FIX_TRUNC_EXPR
:
5337 case FIX_FLOOR_EXPR
:
5338 case FIX_ROUND_EXPR
:
5340 case VIEW_CONVERT_EXPR
:
5343 = build1 (code
, type
,
5344 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
));
5348 case UNCONSTRAINED_ARRAY_REF
:
5349 result
= build1 (code
, type
,
5350 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5355 result
= build (COMPONENT_REF
, type
,
5356 gnat_stabilize_reference (TREE_OPERAND (ref
, 0),
5358 TREE_OPERAND (ref
, 1));
5362 result
= build (BIT_FIELD_REF
, type
,
5363 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5364 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5366 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 2),
5371 result
= build (ARRAY_REF
, type
,
5372 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5373 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5377 case ARRAY_RANGE_REF
:
5378 result
= build (ARRAY_RANGE_REF
, type
,
5379 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5380 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5385 result
= build (COMPOUND_EXPR
, type
,
5386 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5388 gnat_stabilize_reference (TREE_OPERAND (ref
, 1),
5393 result
= build1 (INDIRECT_REF
, type
,
5394 save_expr (build1 (ADDR_EXPR
,
5395 build_reference_type (type
), ref
)));
5398 /* If arg isn't a kind of lvalue we recognize, make no change.
5399 Caller should recognize the error for an invalid lvalue. */
5404 return error_mark_node
;
5407 TREE_READONLY (result
) = TREE_READONLY (ref
);
5411 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5412 arg to force a SAVE_EXPR for everything. */
5415 gnat_stabilize_reference_1 (tree e
, int force
)
5417 enum tree_code code
= TREE_CODE (e
);
5418 tree type
= TREE_TYPE (e
);
5421 /* We cannot ignore const expressions because it might be a reference
5422 to a const array but whose index contains side-effects. But we can
5423 ignore things that are actual constant or that already have been
5424 handled by this function. */
5426 if (TREE_CONSTANT (e
) || code
== SAVE_EXPR
)
5429 switch (TREE_CODE_CLASS (code
))
5439 if (TREE_SIDE_EFFECTS (e
) || force
)
5440 return save_expr (e
);
5444 /* Constants need no processing. In fact, we should never reach
5449 /* Recursively stabilize each operand. */
5450 result
= build (code
, type
,
5451 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0), force
),
5452 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 1), force
));
5456 /* Recursively stabilize each operand. */
5457 result
= build1 (code
, type
,
5458 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
5466 TREE_READONLY (result
) = TREE_READONLY (e
);
5470 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5471 either a spec or a body, BODY_P says which. If needed, make a function
5472 to be the elaboration routine for that object and perform the elaborations
5475 Return 1 if we didn't need an elaboration function, zero otherwise. */
5478 build_unit_elab (Entity_Id gnat_unit
, int body_p
, tree gnu_elab_list
)
5484 /* If we have nothing to do, return. */
5485 if (gnu_elab_list
== 0)
5488 /* Prevent the elaboration list from being reclaimed by the GC. */
5489 gnu_pending_elaboration_lists
= chainon (gnu_pending_elaboration_lists
,
5492 /* Set our file and line number to that of the object and set up the
5493 elaboration routine. */
5494 gnu_decl
= create_subprog_decl (create_concat_name (gnat_unit
,
5497 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 0,
5499 DECL_ELABORATION_PROC_P (gnu_decl
) = 1;
5501 begin_subprog_body (gnu_decl
);
5502 set_lineno (gnat_unit
, 1);
5504 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
5505 expand_start_bindings (0);
5507 /* Emit the assignments for the elaborations we have to do. If there
5508 is no destination, this is just a call to execute some statement
5509 that was placed within the declarative region. But first save a
5510 pointer so we can see if any insns were generated. */
5512 insn
= get_last_insn ();
5514 for (; gnu_elab_list
; gnu_elab_list
= TREE_CHAIN (gnu_elab_list
))
5515 if (TREE_PURPOSE (gnu_elab_list
) == NULL_TREE
)
5517 if (TREE_VALUE (gnu_elab_list
) != 0)
5518 expand_expr_stmt (TREE_VALUE (gnu_elab_list
));
5522 tree lhs
= TREE_PURPOSE (gnu_elab_list
);
5524 input_location
= DECL_SOURCE_LOCATION (lhs
);
5526 /* If LHS has a padded type, convert it to the unpadded type
5527 so the assignment is done properly. */
5528 if (TREE_CODE (TREE_TYPE (lhs
)) == RECORD_TYPE
5529 && TYPE_IS_PADDING_P (TREE_TYPE (lhs
)))
5530 lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs
))), lhs
);
5532 emit_line_note (input_location
);
5533 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5534 TREE_PURPOSE (gnu_elab_list
),
5535 TREE_VALUE (gnu_elab_list
)));
5538 /* See if any non-NOTE insns were generated. */
5539 for (insn
= NEXT_INSN (insn
); insn
; insn
= NEXT_INSN (insn
))
5540 if (GET_RTX_CLASS (GET_CODE (insn
)) == RTX_INSN
)
5546 expand_end_bindings (NULL_TREE
, kept_level_p (), -1);
5547 poplevel (kept_level_p (), 1, 0);
5548 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
5549 end_subprog_body ();
5551 /* We are finished with the elaboration list it can now be discarded. */
5552 gnu_pending_elaboration_lists
= TREE_CHAIN (gnu_pending_elaboration_lists
);
5554 /* If there were no insns, we don't need an elab routine. It would
5555 be nice to not output this one, but there's no good way to do that. */
5559 extern char *__gnat_to_canonical_file_spec (char *);
5561 /* Determine the input_filename and the input_line from the source location
5562 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5563 input_line. If WRITE_NOTE_P is true, emit a line number note. */
5566 set_lineno (Node_Id gnat_node
, int write_note_p
)
5568 Source_Ptr source_location
= Sloc (gnat_node
);
5570 set_lineno_from_sloc (source_location
, write_note_p
);
5573 /* Likewise, but passed a Sloc. */
5576 set_lineno_from_sloc (Source_Ptr source_location
, int write_note_p
)
5578 /* If node not from source code, ignore. */
5579 if (source_location
< 0)
5582 /* Use the identifier table to make a hashed, permanent copy of the filename,
5583 since the name table gets reallocated after Gigi returns but before all
5584 the debugging information is output. The __gnat_to_canonical_file_spec
5585 call translates filenames from pragmas Source_Reference that contain host
5586 style syntax not understood by gdb. */
5588 = IDENTIFIER_POINTER
5590 (__gnat_to_canonical_file_spec
5592 (Full_Debug_Name (Get_Source_File_Index (source_location
))))));
5594 /* ref_filename is the reference file name as given by sinput (i.e no
5597 = IDENTIFIER_POINTER
5600 (Debug_Source_Name (Get_Source_File_Index (source_location
)))));;
5601 input_line
= Get_Logical_Line_Number (source_location
);
5604 emit_line_note (input_location
);
5607 /* Post an error message. MSG is the error message, properly annotated.
5608 NODE is the node at which to post the error and the node to use for the
5609 "&" substitution. */
5612 post_error (const char *msg
, Node_Id node
)
5614 String_Template temp
;
5617 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5618 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5620 Error_Msg_N (fp
, node
);
5623 /* Similar, but NODE is the node at which to post the error and ENT
5624 is the node to use for the "&" substitution. */
5627 post_error_ne (const char *msg
, Node_Id node
, Entity_Id ent
)
5629 String_Template temp
;
5632 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5633 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5635 Error_Msg_NE (fp
, node
, ent
);
5638 /* Similar, but NODE is the node at which to post the error, ENT is the node
5639 to use for the "&" substitution, and N is the number to use for the ^. */
5642 post_error_ne_num (const char *msg
, Node_Id node
, Entity_Id ent
, int n
)
5644 String_Template temp
;
5647 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5648 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5649 Error_Msg_Uint_1
= UI_From_Int (n
);
5652 Error_Msg_NE (fp
, node
, ent
);
5655 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5656 number to write. If the tree represents a constant that fits within
5657 a host integer, the text inside curly brackets in MSG will be output
5658 (presumably including a '^'). Otherwise that text will not be output
5659 and the text inside square brackets will be output instead. */
5662 post_error_ne_tree (const char *msg
, Node_Id node
, Entity_Id ent
, tree t
)
5664 char *newmsg
= alloca (strlen (msg
) + 1);
5665 String_Template temp
= {1, 0};
5667 char start_yes
, end_yes
, start_no
, end_no
;
5671 fp
.Array
= newmsg
, fp
.Bounds
= &temp
;
5673 if (host_integerp (t
, 1)
5674 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5677 (t
, (((unsigned HOST_WIDE_INT
) 1 << (HOST_BITS_PER_INT
- 1)) - 1)) < 0
5681 Error_Msg_Uint_1
= UI_From_Int (tree_low_cst (t
, 1));
5682 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
5685 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
5687 for (p
= msg
, q
= newmsg
; *p
!= 0; p
++)
5689 if (*p
== start_yes
)
5690 for (p
++; *p
!= end_yes
; p
++)
5692 else if (*p
== start_no
)
5693 for (p
++; *p
!= end_no
; p
++)
5701 temp
.High_Bound
= strlen (newmsg
);
5703 Error_Msg_NE (fp
, node
, ent
);
5706 /* Similar to post_error_ne_tree, except that NUM is a second
5707 integer to write in the message. */
5710 post_error_ne_tree_2 (const char *msg
,
5716 Error_Msg_Uint_2
= UI_From_Int (num
);
5717 post_error_ne_tree (msg
, node
, ent
, t
);
5720 /* Set the node for a second '&' in the error message. */
5723 set_second_error_entity (Entity_Id e
)
5725 Error_Msg_Node_2
= e
;
5728 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5729 as the relevant node that provides the location info for the error */
5732 gigi_abort (int code
)
5734 String_Template temp
= {1, 10};
5737 fp
.Array
= "Gigi abort", fp
.Bounds
= &temp
;
5739 Current_Error_Node
= error_gnat_node
;
5740 Compiler_Abort (fp
, code
);
5743 /* Initialize the table that maps GNAT codes to GCC codes for simple
5744 binary and unary operations. */
5747 init_code_table (void)
5749 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
5750 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
5752 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
5753 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
5754 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
5755 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
5756 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
5757 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
5758 gnu_codes
[N_Op_Le
] = LE_EXPR
;
5759 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
5760 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
5761 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
5762 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
5763 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
5764 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
5765 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
5766 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
5767 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
5768 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
5769 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
5770 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
5771 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
5772 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
5773 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;
5776 #include "gt-ada-trans.h"