1 /****************************************************************************
3 * GNAT COMPILER COMPONENTS *
7 * C Implementation File *
10 * Copyright (C) 1992-2002, Free Software Foundation, Inc. *
12 * GNAT is free software; you can redistribute it and/or modify it under *
13 * terms of the GNU General Public License as published by the Free Soft- *
14 * ware Foundation; either version 2, or (at your option) any later ver- *
15 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
16 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
17 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
18 * for more details. You should have received a copy of the GNU General *
19 * Public License distributed with GNAT; see file COPYING. If not, write *
20 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
21 * MA 02111-1307, USA. *
23 * GNAT was originally developed by the GNAT team at New York University. *
24 * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
26 ****************************************************************************/
58 struct Node
*Nodes_Ptr
;
59 Node_Id
*Next_Node_Ptr
;
60 Node_Id
*Prev_Node_Ptr
;
61 struct Elist_Header
*Elists_Ptr
;
62 struct Elmt_Item
*Elmts_Ptr
;
63 struct String_Entry
*Strings_Ptr
;
64 Char_Code
*String_Chars_Ptr
;
65 struct List_Header
*List_Headers_Ptr
;
67 /* Current filename without path. */
68 const char *ref_filename
;
70 /* Flag indicating whether file names are discarded in exception messages */
71 int discard_file_names
;
73 /* If true, then gigi is being called on an analyzed but unexpanded
74 tree, and the only purpose of the call is to properly annotate
75 types with representation information. */
76 int type_annotate_only
;
78 /* List of TREE_LIST nodes representing a block stack. TREE_VALUE
79 of each gives the variable used for the setjmp buffer in the current
80 block, if any. TREE_PURPOSE gives the bottom condition for a loop,
81 if this block is for a loop. The latter is only used to save the tree
85 /* List of TREE_LIST nodes representing a stack of exception pointer
86 variables. TREE_VALUE is the VAR_DECL that stores the address of
87 the raised exception. Nonzero means we are in an exception
88 handler. Not used in the zero-cost case. */
89 static tree gnu_except_ptr_stack
;
91 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
92 static enum tree_code gnu_codes
[Number_Node_Kinds
];
94 /* Current node being treated, in case gigi_abort called. */
95 Node_Id error_gnat_node
;
97 /* Variable that stores a list of labels to be used as a goto target instead of
98 a return in some functions. See processing for N_Subprogram_Body. */
99 static tree gnu_return_label_stack
;
101 static tree tree_transform
PARAMS((Node_Id
));
102 static void elaborate_all_entities
PARAMS((Node_Id
));
103 static void process_freeze_entity
PARAMS((Node_Id
));
104 static void process_inlined_subprograms
PARAMS((Node_Id
));
105 static void process_decls
PARAMS((List_Id
, List_Id
, Node_Id
,
107 static tree emit_access_check
PARAMS((tree
));
108 static tree emit_discriminant_check
PARAMS((tree
, Node_Id
));
109 static tree emit_range_check
PARAMS((tree
, Node_Id
));
110 static tree emit_index_check
PARAMS((tree
, tree
, tree
, tree
));
111 static tree emit_check
PARAMS((tree
, tree
, int));
112 static tree convert_with_check
PARAMS((Entity_Id
, tree
,
114 static int addressable_p
PARAMS((tree
));
115 static tree assoc_to_constructor
PARAMS((Node_Id
, tree
));
116 static tree extract_values
PARAMS((tree
, tree
));
117 static tree pos_to_constructor
PARAMS((Node_Id
, tree
, Entity_Id
));
118 static tree maybe_implicit_deref
PARAMS((tree
));
119 static tree gnat_stabilize_reference_1
PARAMS((tree
, int));
120 static int build_unit_elab
PARAMS((Entity_Id
, int, tree
));
122 /* Constants for +0.5 and -0.5 for float-to-integer rounding. */
123 static REAL_VALUE_TYPE dconstp5
;
124 static REAL_VALUE_TYPE dconstmp5
;
126 /* This is the main program of the back-end. It sets up all the table
127 structures and then generates code. */
130 gigi (gnat_root
, max_gnat_node
, number_name
, nodes_ptr
, next_node_ptr
,
131 prev_node_ptr
, elists_ptr
, elmts_ptr
, strings_ptr
, string_chars_ptr
,
132 list_headers_ptr
, number_units
, file_info_ptr
, standard_integer
,
133 standard_long_long_float
, standard_exception_type
, gigi_operating_mode
)
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 /* See if we should discard file names in exception messages. */
169 discard_file_names
= (Global_Discard_Names
|| Debug_Flag_NN
);
171 if (Nkind (gnat_root
) != N_Compilation_Unit
)
174 set_lineno (gnat_root
, 0);
176 /* Initialize ourselves. */
181 /* Enable GNAT stack checking method if needed */
182 if (!Stack_Check_Probes_On_Target
)
183 set_stack_check_libfunc (gen_rtx (SYMBOL_REF
, Pmode
, "_gnat_stack_check"));
185 /* Save the type we made for integer as the type for Standard.Integer.
186 Then make the rest of the standard types. Note that some of these
188 save_gnu_tree (Base_Type (standard_integer
),
189 TYPE_NAME (integer_type_node
), 0);
191 ggc_add_tree_root (&gnu_block_stack
, 1);
192 ggc_add_tree_root (&gnu_except_ptr_stack
, 1);
193 ggc_add_tree_root (&gnu_return_label_stack
, 1);
194 gnu_except_ptr_stack
= tree_cons (NULL_TREE
, NULL_TREE
, NULL_TREE
);
196 dconstp5
= REAL_VALUE_ATOF ("0.5", DFmode
);
197 dconstmp5
= REAL_VALUE_ATOF ("-0.5", DFmode
);
199 gnu_standard_long_long_float
200 = gnat_to_gnu_entity (Base_Type (standard_long_long_float
), NULL_TREE
, 0);
201 gnu_standard_exception_type
202 = gnat_to_gnu_entity (Base_Type (standard_exception_type
), NULL_TREE
, 0);
204 init_gigi_decls (gnu_standard_long_long_float
, gnu_standard_exception_type
);
206 /* Process any Pragma Ident for the main unit. */
207 #ifdef ASM_OUTPUT_IDENT
208 if (Present (Ident_String (Main_Unit
)))
211 TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit
))));
214 /* If we are using the GCC exception mechanism, let GCC know. */
215 if (Exception_Mechanism
== GCC_ZCX
)
218 gnat_to_code (gnat_root
);
222 /* This function is the driver of the GNAT to GCC tree transformation process.
223 GNAT_NODE is the root of some gnat tree. It generates code for that
227 gnat_to_code (gnat_node
)
232 /* Save node number in case error */
233 error_gnat_node
= gnat_node
;
235 gnu_root
= tree_transform (gnat_node
);
237 /* This should just generate code, not return a value. If it returns
238 a value, something is wrong. */
239 if (gnu_root
!= error_mark_node
)
243 /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC
244 tree corresponding to that GNAT tree. Normally, no code is generated.
245 We just return an equivalent tree which is used elsewhere to generate
249 gnat_to_gnu (gnat_node
)
254 /* Save node number in case error */
255 error_gnat_node
= gnat_node
;
257 gnu_root
= tree_transform (gnat_node
);
259 /* If we got no code as a result, something is wrong. */
260 if (gnu_root
== error_mark_node
&& ! type_annotate_only
)
266 /* This function is the driver of the GNAT to GCC tree transformation process.
267 It is the entry point of the tree transformer. GNAT_NODE is the root of
268 some GNAT tree. Return the root of the corresponding GCC tree or
269 error_mark_node to signal that there is no GCC tree to return.
271 The latter is the case if only code generation actions have to be performed
272 like in the case of if statements, loops, etc. This routine is wrapped
273 in the above two routines for most purposes. */
276 tree_transform (gnat_node
)
279 tree gnu_result
= error_mark_node
; /* Default to no value. */
280 tree gnu_result_type
= void_type_node
;
282 tree gnu_lhs
, gnu_rhs
;
284 Entity_Id gnat_temp_type
;
286 /* Set input_file_name and lineno from the Sloc in the GNAT tree. */
287 set_lineno (gnat_node
, 0);
289 /* If this is a Statement and we are at top level, we add the statement
290 as an elaboration for a null tree. That will cause it to be placed
291 in the elaboration procedure. */
292 if (global_bindings_p ()
293 && ((IN (Nkind (gnat_node
), N_Statement_Other_Than_Procedure_Call
)
294 && Nkind (gnat_node
) != N_Null_Statement
)
295 || Nkind (gnat_node
) == N_Procedure_Call_Statement
296 || Nkind (gnat_node
) == N_Label
297 || (Nkind (gnat_node
) == N_Handled_Sequence_Of_Statements
298 && (Present (Exception_Handlers (gnat_node
))
299 || Present (At_End_Proc (gnat_node
))))
300 || ((Nkind (gnat_node
) == N_Raise_Constraint_Error
301 || Nkind (gnat_node
) == N_Raise_Storage_Error
302 || Nkind (gnat_node
) == N_Raise_Program_Error
)
303 && (Ekind (Etype (gnat_node
)) == E_Void
))))
305 add_pending_elaborations (NULL_TREE
, make_transform_expr (gnat_node
));
307 return error_mark_node
;
310 /* If this node is a non-static subexpression and we are only
311 annotating types, make this into a NULL_EXPR for non-VOID types
312 and error_mark_node for void return types. But allow
313 N_Identifier since we use it for lots of things, including
314 getting trees for discriminants. */
316 if (type_annotate_only
317 && IN (Nkind (gnat_node
), N_Subexpr
)
318 && Nkind (gnat_node
) != N_Identifier
319 && ! Compile_Time_Known_Value (gnat_node
))
321 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
323 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
324 return error_mark_node
;
326 return build1 (NULL_EXPR
, gnu_result_type
,
327 build_call_raise (CE_Range_Check_Failed
));
330 switch (Nkind (gnat_node
))
332 /********************************/
333 /* Chapter 2: Lexical Elements: */
334 /********************************/
337 case N_Expanded_Name
:
338 case N_Operator_Symbol
:
339 case N_Defining_Identifier
:
341 /* If the Etype of this node does not equal the Etype of the
342 Entity, something is wrong with the entity map, probably in
343 generic instantiation. However, this does not apply to
344 types. Since we sometime have strange Ekind's, just do
345 this test for objects. Also, if the Etype of the Entity
346 is private, the Etype of the N_Identifier is allowed to be the
347 full type and also we consider a packed array type to be the
348 same as the original type. Finally, if the types are Itypes,
349 one may be a copy of the other, which is also legal. */
351 gnat_temp
= (Nkind (gnat_node
) == N_Defining_Identifier
352 ? gnat_node
: Entity (gnat_node
));
353 gnat_temp_type
= Etype (gnat_temp
);
355 if (Etype (gnat_node
) != gnat_temp_type
356 && ! (Is_Packed (gnat_temp_type
)
357 && Etype (gnat_node
) == Packed_Array_Type (gnat_temp_type
))
358 && ! (IN (Ekind (gnat_temp_type
), Private_Kind
)
359 && Present (Full_View (gnat_temp_type
))
360 && ((Etype (gnat_node
) == Full_View (gnat_temp_type
))
361 || (Is_Packed (Full_View (gnat_temp_type
))
362 && Etype (gnat_node
) ==
363 Packed_Array_Type (Full_View (gnat_temp_type
)))))
364 && (!Is_Itype (Etype (gnat_node
)) || !Is_Itype (gnat_temp_type
))
365 && (Ekind (gnat_temp
) == E_Variable
366 || Ekind (gnat_temp
) == E_Component
367 || Ekind (gnat_temp
) == E_Constant
368 || Ekind (gnat_temp
) == E_Loop_Parameter
369 || IN (Ekind (gnat_temp
), Formal_Kind
)))
372 /* If this is a reference to a deferred constant whose partial view
373 is an unconstrained private type, the proper type is on the full
374 view of the constant, not on the full view of the type, which may
377 This may be a reference to a type, for example in the prefix of the
378 attribute Position, generated for dispatching code (see Make_DT in
379 exp_disp,adb). In that case we need the type itself, not is parent,
380 in particular if it is a derived type */
382 if (Is_Private_Type (gnat_temp_type
)
383 && Has_Unknown_Discriminants (gnat_temp_type
)
384 && Present (Full_View (gnat_temp
))
385 && ! Is_Type (gnat_temp
))
387 gnat_temp
= Full_View (gnat_temp
);
388 gnat_temp_type
= Etype (gnat_temp
);
389 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
393 /* Expand the type of this identitier first, in case it is
394 an enumeral literal, which only get made when the type
395 is expanded. There is no order-of-elaboration issue here.
396 We want to use the Actual_Subtype if it has already been
397 elaborated, otherwise the Etype. Avoid using Actual_Subtype
398 for packed arrays to simplify things. */
399 if ((Ekind (gnat_temp
) == E_Constant
400 || Ekind (gnat_temp
) == E_Variable
|| Is_Formal (gnat_temp
))
401 && ! (Is_Array_Type (Etype (gnat_temp
))
402 && Present (Packed_Array_Type (Etype (gnat_temp
))))
403 && Present (Actual_Subtype (gnat_temp
))
404 && present_gnu_tree (Actual_Subtype (gnat_temp
)))
405 gnat_temp_type
= Actual_Subtype (gnat_temp
);
407 gnat_temp_type
= Etype (gnat_node
);
409 gnu_result_type
= get_unpadded_type (gnat_temp_type
);
412 gnu_result
= gnat_to_gnu_entity (gnat_temp
, NULL_TREE
, 0);
414 /* If we are in an exception handler, force this variable into memory
415 to ensure optimization does not remove stores that appear
416 redundant but are actually needed in case an exception occurs.
418 ??? Note that we need not do this if the variable is declared within
419 the handler, only if it is referenced in the handler and declared
420 in an enclosing block, but we have no way of testing that
422 if (TREE_VALUE (gnu_except_ptr_stack
) != 0)
424 gnat_mark_addressable (gnu_result
);
425 flush_addressof (gnu_result
);
428 /* Some objects (such as parameters passed by reference, globals of
429 variable size, and renamed objects) actually represent the address
430 of the object. In that case, we must do the dereference. Likewise,
431 deal with parameters to foreign convention subprograms. Call fold
432 here since GNU_RESULT may be a CONST_DECL. */
433 if (DECL_P (gnu_result
)
434 && (DECL_BY_REF_P (gnu_result
)
435 || DECL_BY_COMPONENT_PTR_P (gnu_result
)))
437 int ro
= DECL_POINTS_TO_READONLY_P (gnu_result
);
439 if (DECL_BY_COMPONENT_PTR_P (gnu_result
))
440 gnu_result
= convert (build_pointer_type (gnu_result_type
),
443 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
445 TREE_READONLY (gnu_result
) = TREE_STATIC (gnu_result
) = ro
;
448 /* The GNAT tree has the type of a function as the type of its result.
449 Also use the type of the result if the Etype is a subtype which
450 is nominally unconstrained. But remove any padding from the
452 if (TREE_CODE (TREE_TYPE (gnu_result
)) == FUNCTION_TYPE
453 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type
))
455 gnu_result_type
= TREE_TYPE (gnu_result
);
456 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
457 && TYPE_IS_PADDING_P (gnu_result_type
))
458 gnu_result_type
= TREE_TYPE (TYPE_FIELDS (gnu_result_type
));
461 /* We always want to return the underlying INTEGER_CST for an
462 enumeration literal to avoid the need to call fold in lots
463 of places. But don't do this is the parent will be taking
464 the address of this object. */
465 if (TREE_CODE (gnu_result
) == CONST_DECL
)
467 gnat_temp
= Parent (gnat_node
);
468 if (DECL_CONST_CORRESPONDING_VAR (gnu_result
) == 0
469 || (Nkind (gnat_temp
) != N_Reference
470 && ! (Nkind (gnat_temp
) == N_Attribute_Reference
471 && ((Get_Attribute_Id (Attribute_Name (gnat_temp
))
473 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
475 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
476 == Attr_Unchecked_Access
)
477 || (Get_Attribute_Id (Attribute_Name (gnat_temp
))
478 == Attr_Unrestricted_Access
)))))
479 gnu_result
= DECL_INITIAL (gnu_result
);
483 case N_Integer_Literal
:
487 /* Get the type of the result, looking inside any padding and
488 left-justified modular types. Then get the value in that type. */
489 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
491 if (TREE_CODE (gnu_type
) == RECORD_TYPE
492 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type
))
493 gnu_type
= TREE_TYPE (TYPE_FIELDS (gnu_type
));
495 gnu_result
= UI_To_gnu (Intval (gnat_node
), gnu_type
);
497 /* If the result overflows (meaning it doesn't fit in its base type),
498 abort. We would like to check that the value is within the range
499 of the subtype, but that causes problems with subtypes whose usage
500 will raise Constraint_Error and with biased representation, so
502 if (TREE_CONSTANT_OVERFLOW (gnu_result
))
507 case N_Character_Literal
:
508 /* If a Entity is present, it means that this was one of the
509 literals in a user-defined character type. In that case,
510 just return the value in the CONST_DECL. Otherwise, use the
511 character code. In that case, the base type should be an
512 INTEGER_TYPE, but we won't bother checking for that. */
513 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
514 if (Present (Entity (gnat_node
)))
515 gnu_result
= DECL_INITIAL (get_gnu_tree (Entity (gnat_node
)));
517 gnu_result
= convert (gnu_result_type
,
518 build_int_2 (Char_Literal_Value (gnat_node
), 0));
522 /* If this is of a fixed-point type, the value we want is the
523 value of the corresponding integer. */
524 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))), Fixed_Point_Kind
))
526 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
527 gnu_result
= UI_To_gnu (Corresponding_Integer_Value (gnat_node
),
529 if (TREE_CONSTANT_OVERFLOW (gnu_result
)
531 || (TREE_CODE (TYPE_MIN_VALUE (gnu_result_type
)) == INTEGER_CST
532 && tree_int_cst_lt (gnu_result
,
533 TYPE_MIN_VALUE (gnu_result_type
)))
534 || (TREE_CODE (TYPE_MAX_VALUE (gnu_result_type
)) == INTEGER_CST
535 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_result_type
),
541 /* We should never see a Vax_Float type literal, since the front end
542 is supposed to transform these using appropriate conversions */
543 else if (Vax_Float (Underlying_Type (Etype (gnat_node
))))
548 Ureal ur_realval
= Realval (gnat_node
);
550 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
552 /* If the real value is zero, so is the result. Otherwise,
553 convert it to a machine number if it isn't already. That
554 forces BASE to 0 or 2 and simplifies the rest of our logic. */
555 if (UR_Is_Zero (ur_realval
))
556 gnu_result
= convert (gnu_result_type
, integer_zero_node
);
559 if (! Is_Machine_Number (gnat_node
))
561 = Machine (Base_Type (Underlying_Type (Etype (gnat_node
))),
562 ur_realval
, Round_Even
);
565 = UI_To_gnu (Numerator (ur_realval
), gnu_result_type
);
567 /* If we have a base of zero, divide by the denominator.
568 Otherwise, the base must be 2 and we scale the value, which
569 we know can fit in the mantissa of the type (hence the use
570 of that type above). */
571 if (Rbase (ur_realval
) == 0)
573 = build_binary_op (RDIV_EXPR
,
574 get_base_type (gnu_result_type
),
576 UI_To_gnu (Denominator (ur_realval
),
578 else if (Rbase (ur_realval
) != 2)
583 = build_real (gnu_result_type
,
585 (TREE_REAL_CST (gnu_result
),
586 - UI_To_Int (Denominator (ur_realval
))));
589 /* Now see if we need to negate the result. Do it this way to
590 properly handle -0. */
591 if (UR_Is_Negative (Realval (gnat_node
)))
593 = build_unary_op (NEGATE_EXPR
, get_base_type (gnu_result_type
),
599 case N_String_Literal
:
600 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
601 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type
)) == HOST_BITS_PER_CHAR
)
603 /* We assume here that all strings are of type standard.string.
604 "Weird" types of string have been converted to an aggregate
606 String_Id gnat_string
= Strval (gnat_node
);
607 int length
= String_Length (gnat_string
);
608 char *string
= (char *) alloca (length
+ 1);
611 /* Build the string with the characters in the literal. Note
612 that Ada strings are 1-origin. */
613 for (i
= 0; i
< length
; i
++)
614 string
[i
] = Get_String_Char (gnat_string
, i
+ 1);
616 /* Put a null at the end of the string in case it's in a context
617 where GCC will want to treat it as a C string. */
620 gnu_result
= build_string (length
, string
);
622 /* Strings in GCC don't normally have types, but we want
623 this to not be converted to the array type. */
624 TREE_TYPE (gnu_result
) = gnu_result_type
;
628 /* Build a list consisting of each character, then make
630 String_Id gnat_string
= Strval (gnat_node
);
631 int length
= String_Length (gnat_string
);
633 tree gnu_list
= NULL_TREE
;
635 for (i
= 0; i
< length
; i
++)
637 = tree_cons (NULL_TREE
,
638 convert (TREE_TYPE (gnu_result_type
),
639 build_int_2 (Get_String_Char (gnat_string
,
645 = build_constructor (gnu_result_type
, nreverse (gnu_list
));
650 if (type_annotate_only
)
653 /* Check for (and ignore) unrecognized pragma */
654 if (! Is_Pragma_Name (Chars (gnat_node
)))
657 switch (Get_Pragma_Id (Chars (gnat_node
)))
659 case Pragma_Inspection_Point
:
660 /* Do nothing at top level: all such variables are already
662 if (global_bindings_p ())
665 set_lineno (gnat_node
, 1);
666 for (gnat_temp
= First (Pragma_Argument_Associations (gnat_node
));
668 gnat_temp
= Next (gnat_temp
))
670 gnu_expr
= gnat_to_gnu (Expression (gnat_temp
));
671 if (TREE_CODE (gnu_expr
) == UNCONSTRAINED_ARRAY_REF
)
672 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
674 gnu_expr
= build1 (USE_EXPR
, void_type_node
, gnu_expr
);
675 TREE_SIDE_EFFECTS (gnu_expr
) = 1;
676 expand_expr_stmt (gnu_expr
);
680 case Pragma_Optimize
:
681 switch (Chars (Expression
682 (First (Pragma_Argument_Associations (gnat_node
)))))
684 case Name_Time
: case Name_Space
:
686 post_error ("insufficient -O value?", gnat_node
);
691 post_error ("must specify -O0?", gnat_node
);
700 case Pragma_Reviewable
:
701 if (write_symbols
== NO_DEBUG
)
702 post_error ("must specify -g?", gnat_node
);
707 /**************************************/
708 /* Chapter 3: Declarations and Types: */
709 /**************************************/
711 case N_Subtype_Declaration
:
712 case N_Full_Type_Declaration
:
713 case N_Incomplete_Type_Declaration
:
714 case N_Private_Type_Declaration
:
715 case N_Private_Extension_Declaration
:
716 case N_Task_Type_Declaration
:
717 process_type (Defining_Entity (gnat_node
));
720 case N_Object_Declaration
:
721 case N_Exception_Declaration
:
722 gnat_temp
= Defining_Entity (gnat_node
);
724 /* If we are just annotating types and this object has an unconstrained
725 or task type, don't elaborate it. */
726 if (type_annotate_only
727 && (((Is_Array_Type (Etype (gnat_temp
))
728 || Is_Record_Type (Etype (gnat_temp
)))
729 && ! Is_Constrained (Etype (gnat_temp
)))
730 || Is_Concurrent_Type (Etype (gnat_temp
))))
733 if (Present (Expression (gnat_node
))
734 && ! (Nkind (gnat_node
) == N_Object_Declaration
735 && No_Initialization (gnat_node
))
736 && (! type_annotate_only
737 || Compile_Time_Known_Value (Expression (gnat_node
))))
739 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
740 if (Do_Range_Check (Expression (gnat_node
)))
741 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_temp
));
743 /* If this object has its elaboration delayed, we must force
744 evaluation of GNU_EXPR right now and save it for when the object
746 if (Present (Freeze_Node (gnat_temp
)))
748 if ((Is_Public (gnat_temp
) || global_bindings_p ())
749 && ! TREE_CONSTANT (gnu_expr
))
751 = create_var_decl (create_concat_name (gnat_temp
, "init"),
752 NULL_TREE
, TREE_TYPE (gnu_expr
), gnu_expr
,
753 0, Is_Public (gnat_temp
), 0, 0, 0);
755 gnu_expr
= maybe_variable (gnu_expr
, Expression (gnat_node
));
757 save_gnu_tree (gnat_node
, gnu_expr
, 1);
763 if (type_annotate_only
&& gnu_expr
!= 0
764 && TREE_CODE (gnu_expr
) == ERROR_MARK
)
767 if (No (Freeze_Node (gnat_temp
)))
768 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
771 case N_Object_Renaming_Declaration
:
773 gnat_temp
= Defining_Entity (gnat_node
);
775 /* Don't do anything if this renaming is handled by the front end.
776 or if we are just annotating types and this object has a
777 composite or task type, don't elaborate it. */
778 if (! Is_Renaming_Of_Object (gnat_temp
)
779 && ! (type_annotate_only
780 && (Is_Array_Type (Etype (gnat_temp
))
781 || Is_Record_Type (Etype (gnat_temp
))
782 || Is_Concurrent_Type (Etype (gnat_temp
)))))
784 gnu_expr
= gnat_to_gnu (Renamed_Object (gnat_temp
));
785 gnat_to_gnu_entity (gnat_temp
, gnu_expr
, 1);
789 case N_Implicit_Label_Declaration
:
790 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
793 case N_Subprogram_Renaming_Declaration
:
794 case N_Package_Renaming_Declaration
:
795 case N_Exception_Renaming_Declaration
:
796 case N_Number_Declaration
:
797 /* These are fully handled in the front end. */
800 /*************************************/
801 /* Chapter 4: Names and Expressions: */
802 /*************************************/
804 case N_Explicit_Dereference
:
805 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
806 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
808 /* Emit access check if necessary */
809 if (Do_Access_Check (gnat_node
))
810 gnu_result
= emit_access_check (gnu_result
);
812 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_result
);
815 case N_Indexed_Component
:
817 tree gnu_array_object
= gnat_to_gnu (Prefix (gnat_node
));
821 Node_Id
*gnat_expr_array
;
823 /* Emit access check if necessary */
824 if (Do_Access_Check (gnat_node
))
825 gnu_array_object
= emit_access_check (gnu_array_object
);
827 gnu_array_object
= maybe_implicit_deref (gnu_array_object
);
828 gnu_array_object
= maybe_unconstrained_array (gnu_array_object
);
830 /* If we got a padded type, remove it too. */
831 if (TREE_CODE (TREE_TYPE (gnu_array_object
)) == RECORD_TYPE
832 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object
)))
834 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object
))),
837 gnu_result
= gnu_array_object
;
839 /* First compute the number of dimensions of the array, then
840 fill the expression array, the order depending on whether
841 this is a Convention_Fortran array or not. */
842 for (ndim
= 1, gnu_type
= TREE_TYPE (gnu_array_object
);
843 TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
844 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
));
845 ndim
++, gnu_type
= TREE_TYPE (gnu_type
))
848 gnat_expr_array
= (Node_Id
*) alloca (ndim
* sizeof (Node_Id
));
850 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object
)))
851 for (i
= ndim
- 1, gnat_temp
= First (Expressions (gnat_node
));
853 i
--, gnat_temp
= Next (gnat_temp
))
854 gnat_expr_array
[i
] = gnat_temp
;
856 for (i
= 0, gnat_temp
= First (Expressions (gnat_node
));
858 i
++, gnat_temp
= Next (gnat_temp
))
859 gnat_expr_array
[i
] = gnat_temp
;
861 for (i
= 0, gnu_type
= TREE_TYPE (gnu_array_object
);
862 i
< ndim
; i
++, gnu_type
= TREE_TYPE (gnu_type
))
864 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
867 gnat_temp
= gnat_expr_array
[i
];
868 gnu_expr
= gnat_to_gnu (gnat_temp
);
870 if (Do_Range_Check (gnat_temp
))
873 (gnu_array_object
, gnu_expr
,
874 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
875 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
877 gnu_result
= build_binary_op (ARRAY_REF
, NULL_TREE
,
878 gnu_result
, gnu_expr
);
882 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
888 Node_Id gnat_range_node
= Discrete_Range (gnat_node
);
890 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
891 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
893 /* Emit access check if necessary */
894 if (Do_Access_Check (gnat_node
))
895 gnu_result
= emit_access_check (gnu_result
);
897 /* Do any implicit dereferences of the prefix and do any needed
899 gnu_result
= maybe_implicit_deref (gnu_result
);
900 gnu_result
= maybe_unconstrained_array (gnu_result
);
901 gnu_type
= TREE_TYPE (gnu_result
);
902 if (Do_Range_Check (gnat_range_node
))
904 /* Get the bounds of the slice. */
906 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type
));
907 tree gnu_min_expr
= TYPE_MIN_VALUE (gnu_index_type
);
908 tree gnu_max_expr
= TYPE_MAX_VALUE (gnu_index_type
);
909 tree gnu_expr_l
, gnu_expr_h
, gnu_expr_type
;
911 /* Check to see that the minimum slice value is in range */
914 (gnu_result
, gnu_min_expr
,
915 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
916 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
918 /* Check to see that the maximum slice value is in range */
921 (gnu_result
, gnu_max_expr
,
922 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))),
923 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))));
925 /* Derive a good type to convert everything too */
926 gnu_expr_type
= get_base_type (TREE_TYPE (gnu_expr_l
));
928 /* Build a compound expression that does the range checks */
930 = build_binary_op (COMPOUND_EXPR
, gnu_expr_type
,
931 convert (gnu_expr_type
, gnu_expr_h
),
932 convert (gnu_expr_type
, gnu_expr_l
));
934 /* Build a conditional expression that returns the range checks
935 expression if the slice range is not null (max >= min) or
936 returns the min if the slice range is null */
938 = fold (build (COND_EXPR
, gnu_expr_type
,
939 build_binary_op (GE_EXPR
, gnu_expr_type
,
940 convert (gnu_expr_type
,
942 convert (gnu_expr_type
,
944 gnu_expr
, gnu_min_expr
));
947 gnu_expr
= TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type
));
949 gnu_result
= build_binary_op (ARRAY_RANGE_REF
, gnu_result_type
,
950 gnu_result
, gnu_expr
);
954 case N_Selected_Component
:
956 tree gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
957 Entity_Id gnat_field
= Entity (Selector_Name (gnat_node
));
958 Entity_Id gnat_pref_type
= Etype (Prefix (gnat_node
));
961 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
962 || IN (Ekind (gnat_pref_type
), Access_Kind
))
964 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
965 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
966 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
967 gnat_pref_type
= Designated_Type (gnat_pref_type
);
970 if (Do_Access_Check (gnat_node
))
971 gnu_prefix
= emit_access_check (gnu_prefix
);
973 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
975 /* For discriminant references in tagged types always substitute the
976 corresponding discriminant as the actual selected component. */
978 if (Is_Tagged_Type (gnat_pref_type
))
979 while (Present (Corresponding_Discriminant (gnat_field
)))
980 gnat_field
= Corresponding_Discriminant (gnat_field
);
982 /* For discriminant references of untagged types always substitute the
983 corresponding girder discriminant. */
985 else if (Present (Corresponding_Discriminant (gnat_field
)))
986 gnat_field
= Original_Record_Component (gnat_field
);
988 /* Handle extracting the real or imaginary part of a complex.
989 The real part is the first field and the imaginary the last. */
991 if (TREE_CODE (TREE_TYPE (gnu_prefix
)) == COMPLEX_TYPE
)
992 gnu_result
= build_unary_op (Present (Next_Entity (gnat_field
))
993 ? REALPART_EXPR
: IMAGPART_EXPR
,
994 NULL_TREE
, gnu_prefix
);
997 gnu_field
= gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0);
999 /* If there are discriminants, the prefix might be
1000 evaluated more than once, which is a problem if it has
1002 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node
)))
1003 ? Designated_Type (Etype
1004 (Prefix (gnat_node
)))
1005 : Etype (Prefix (gnat_node
))))
1006 gnu_prefix
= gnat_stabilize_reference (gnu_prefix
, 0);
1008 /* Emit discriminant check if necessary. */
1009 if (Do_Discriminant_Check (gnat_node
))
1010 gnu_prefix
= emit_discriminant_check (gnu_prefix
, gnat_node
);
1012 = build_component_ref (gnu_prefix
, NULL_TREE
, gnu_field
);
1015 if (gnu_result
== 0)
1018 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1022 case N_Attribute_Reference
:
1024 /* The attribute designator (like an enumeration value). */
1025 int attribute
= Get_Attribute_Id (Attribute_Name (gnat_node
));
1026 int prefix_unused
= 0;
1030 /* The Elab_Spec and Elab_Body attributes are special in that
1031 Prefix is a unit, not an object with a GCC equivalent. Similarly
1032 for Elaborated, since that variable isn't otherwise known. */
1033 if (attribute
== Attr_Elab_Body
|| attribute
== Attr_Elab_Spec
)
1036 = create_subprog_decl
1037 (create_concat_name (Entity (Prefix (gnat_node
)),
1038 attribute
== Attr_Elab_Body
1039 ? "elabb" : "elabs"),
1040 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 1, 0);
1044 gnu_prefix
= gnat_to_gnu (Prefix (gnat_node
));
1045 gnu_type
= TREE_TYPE (gnu_prefix
);
1047 /* If the input is a NULL_EXPR, make a new one. */
1048 if (TREE_CODE (gnu_prefix
) == NULL_EXPR
)
1050 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1051 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
,
1052 TREE_OPERAND (gnu_prefix
, 0));
1060 /* These are just conversions until since representation
1061 clauses for enumerations are handled in the front end. */
1063 int check_p
= Do_Range_Check (First (Expressions (gnat_node
)));
1065 gnu_result
= gnat_to_gnu (First (Expressions (gnat_node
)));
1066 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1067 gnu_result
= convert_with_check (Etype (gnat_node
), gnu_result
,
1068 check_p
, check_p
, 1);
1074 /* These just add or subject the constant 1. Representation
1075 clauses for enumerations are handled in the front-end. */
1076 gnu_expr
= gnat_to_gnu (First (Expressions (gnat_node
)));
1077 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1079 if (Do_Range_Check (First (Expressions (gnat_node
))))
1081 gnu_expr
= protect_multiple_eval (gnu_expr
);
1084 (build_binary_op (EQ_EXPR
, integer_type_node
,
1086 attribute
== Attr_Pred
1087 ? TYPE_MIN_VALUE (gnu_result_type
)
1088 : TYPE_MAX_VALUE (gnu_result_type
)),
1089 gnu_expr
, CE_Range_Check_Failed
);
1093 = build_binary_op (attribute
== Attr_Pred
1094 ? MINUS_EXPR
: PLUS_EXPR
,
1095 gnu_result_type
, gnu_expr
,
1096 convert (gnu_result_type
, integer_one_node
));
1100 case Attr_Unrestricted_Access
:
1102 /* Conversions don't change something's address but can cause
1103 us to miss the COMPONENT_REF case below, so strip them off. */
1105 = remove_conversions (gnu_prefix
,
1106 ! Must_Be_Byte_Aligned (gnat_node
));
1108 /* If we are taking 'Address of an unconstrained object,
1109 this is the pointer to the underlying array. */
1110 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1112 /* ... fall through ... */
1115 case Attr_Unchecked_Access
:
1116 case Attr_Code_Address
:
1118 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1120 = build_unary_op (((attribute
== Attr_Address
1121 || attribute
== Attr_Unrestricted_Access
)
1122 && ! Must_Be_Byte_Aligned (gnat_node
))
1123 ? ATTR_ADDR_EXPR
: ADDR_EXPR
,
1124 gnu_result_type
, gnu_prefix
);
1126 /* For 'Code_Address, find an inner ADDR_EXPR and mark it
1127 so that we don't try to build a trampoline. */
1128 if (attribute
== Attr_Code_Address
)
1130 for (gnu_expr
= gnu_result
;
1131 TREE_CODE (gnu_expr
) == NOP_EXPR
1132 || TREE_CODE (gnu_expr
) == CONVERT_EXPR
;
1133 gnu_expr
= TREE_OPERAND (gnu_expr
, 0))
1134 TREE_CONSTANT (gnu_expr
) = 1;
1137 if (TREE_CODE (gnu_expr
) == ADDR_EXPR
)
1138 TREE_STATIC (gnu_expr
) = TREE_CONSTANT (gnu_expr
) = 1;
1144 case Attr_Object_Size
:
1145 case Attr_Value_Size
:
1146 case Attr_Max_Size_In_Storage_Elements
:
1148 gnu_expr
= gnu_prefix
;
1150 /* Remove NOPS from gnu_expr and conversions from gnu_prefix.
1151 We only use GNU_EXPR to see if a COMPONENT_REF was involved. */
1152 while (TREE_CODE (gnu_expr
) == NOP_EXPR
)
1153 gnu_expr
= TREE_OPERAND (gnu_expr
, 0);
1155 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1157 gnu_type
= TREE_TYPE (gnu_prefix
);
1159 /* Replace an unconstrained array type with the type of the
1160 underlying array. We can't do this with a call to
1161 maybe_unconstrained_array since we may have a TYPE_DECL.
1162 For 'Max_Size_In_Storage_Elements, use the record type
1163 that will be used to allocate the object and its template. */
1165 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1167 gnu_type
= TYPE_OBJECT_RECORD_TYPE (gnu_type
);
1168 if (attribute
!= Attr_Max_Size_In_Storage_Elements
)
1169 gnu_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type
)));
1172 /* If we are looking for the size of a field, return the
1173 field size. Otherwise, if the prefix is an object,
1174 or if 'Object_Size or 'Max_Size_In_Storage_Elements has
1175 been specified, the result is the GCC size of the type.
1176 Otherwise, the result is the RM_Size of the type. */
1177 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1178 gnu_result
= DECL_SIZE (TREE_OPERAND (gnu_prefix
, 1));
1179 else if (TREE_CODE (gnu_prefix
) != TYPE_DECL
1180 || attribute
== Attr_Object_Size
1181 || attribute
== Attr_Max_Size_In_Storage_Elements
)
1183 /* If this is a padded type, the GCC size isn't relevant
1184 to the programmer. Normally, what we want is the RM_Size,
1185 which was set from the specified size, but if it was not
1186 set, we want the size of the relevant field. Using the MAX
1187 of those two produces the right result in all case. Don't
1188 use the size of the field if it's a self-referential type,
1189 since that's never what's wanted. */
1190 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1191 && TYPE_IS_PADDING_P (gnu_type
)
1192 && TREE_CODE (gnu_expr
) == COMPONENT_REF
)
1194 gnu_result
= rm_size (gnu_type
);
1195 if (! (contains_placeholder_p
1196 (DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)))))
1198 = size_binop (MAX_EXPR
, gnu_result
,
1199 DECL_SIZE (TREE_OPERAND (gnu_expr
, 1)));
1202 gnu_result
= TYPE_SIZE (gnu_type
);
1205 gnu_result
= rm_size (gnu_type
);
1207 if (gnu_result
== 0)
1210 /* Deal with a self-referential size by returning the maximum
1211 size for a type and by qualifying the size with
1212 the object for 'Size of an object. */
1214 if (TREE_CODE (gnu_result
) != INTEGER_CST
1215 && contains_placeholder_p (gnu_result
))
1217 if (TREE_CODE (gnu_prefix
) != TYPE_DECL
)
1218 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1219 gnu_result
, gnu_prefix
);
1221 gnu_result
= max_size (gnu_result
, 1);
1224 /* If the type contains a template, subtract the size of the
1226 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1227 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1228 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1229 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1231 /* If the type contains a template, subtract the size of the
1233 if (TREE_CODE (gnu_type
) == RECORD_TYPE
1234 && TYPE_CONTAINS_TEMPLATE_P (gnu_type
))
1235 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1236 DECL_SIZE (TYPE_FIELDS (gnu_type
)));
1238 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1240 /* Always perform division using unsigned arithmetic as the
1241 size cannot be negative, but may be an overflowed positive
1242 value. This provides correct results for sizes up to 512 MB.
1243 ??? Size should be calculated in storage elements directly. */
1245 if (attribute
== Attr_Max_Size_In_Storage_Elements
)
1246 gnu_result
= convert (sizetype
,
1247 fold (build (CEIL_DIV_EXPR
, bitsizetype
,
1249 bitsize_unit_node
)));
1252 case Attr_Alignment
:
1253 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1254 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1256 && (TYPE_IS_PADDING_P
1257 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1258 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1260 gnu_type
= TREE_TYPE (gnu_prefix
);
1261 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1264 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1266 = size_int (DECL_ALIGN (TREE_OPERAND (gnu_prefix
, 1)));
1268 gnu_result
= size_int (TYPE_ALIGN (gnu_type
) / BITS_PER_UNIT
);
1273 case Attr_Range_Length
:
1276 if (INTEGRAL_TYPE_P (gnu_type
)
1277 || TREE_CODE (gnu_type
) == REAL_TYPE
)
1279 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1281 if (attribute
== Attr_First
)
1282 gnu_result
= TYPE_MIN_VALUE (gnu_type
);
1283 else if (attribute
== Attr_Last
)
1284 gnu_result
= TYPE_MAX_VALUE (gnu_type
);
1288 (MAX_EXPR
, get_base_type (gnu_result_type
),
1290 (PLUS_EXPR
, get_base_type (gnu_result_type
),
1291 build_binary_op (MINUS_EXPR
,
1292 get_base_type (gnu_result_type
),
1293 convert (gnu_result_type
,
1294 TYPE_MAX_VALUE (gnu_type
)),
1295 convert (gnu_result_type
,
1296 TYPE_MIN_VALUE (gnu_type
))),
1297 convert (gnu_result_type
, integer_one_node
)),
1298 convert (gnu_result_type
, integer_zero_node
));
1302 /* ... fall through ... */
1306 = (Present (Expressions (gnat_node
))
1307 ? UI_To_Int (Intval (First (Expressions (gnat_node
))))
1310 /* Emit access check if necessary */
1311 if (Do_Access_Check (gnat_node
))
1312 gnu_prefix
= emit_access_check (gnu_prefix
);
1314 /* Make sure any implicit dereference gets done. */
1315 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1316 gnu_prefix
= maybe_unconstrained_array (gnu_prefix
);
1317 gnu_type
= TREE_TYPE (gnu_prefix
);
1319 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1321 if (TYPE_CONVENTION_FORTRAN_P (gnu_type
))
1326 for (ndim
= 1, gnu_type_temp
= gnu_type
;
1327 TREE_CODE (TREE_TYPE (gnu_type_temp
)) == ARRAY_TYPE
1328 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp
));
1329 ndim
++, gnu_type_temp
= TREE_TYPE (gnu_type_temp
))
1332 Dimension
= ndim
+ 1 - Dimension
;
1335 for (; Dimension
> 1; Dimension
--)
1336 gnu_type
= TREE_TYPE (gnu_type
);
1338 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1341 if (attribute
== Attr_First
)
1343 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1344 else if (attribute
== Attr_Last
)
1346 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)));
1348 /* 'Length or 'Range_Length. */
1350 tree gnu_compute_type
1351 = gnat_signed_or_unsigned_type
1352 (0, get_base_type (gnu_result_type
));
1356 (MAX_EXPR
, gnu_compute_type
,
1358 (PLUS_EXPR
, gnu_compute_type
,
1360 (MINUS_EXPR
, gnu_compute_type
,
1361 convert (gnu_compute_type
,
1363 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
)))),
1364 convert (gnu_compute_type
,
1366 (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type
))))),
1367 convert (gnu_compute_type
, integer_one_node
)),
1368 convert (gnu_compute_type
, integer_zero_node
));
1371 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1372 we are handling. Note that these attributes could not
1373 have been used on an unconstrained array type. */
1374 if (TREE_CODE (gnu_result
) != INTEGER_CST
1375 && contains_placeholder_p (gnu_result
))
1376 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1377 gnu_result
, gnu_prefix
);
1382 case Attr_Bit_Position
:
1384 case Attr_First_Bit
:
1388 HOST_WIDE_INT bitsize
;
1389 HOST_WIDE_INT bitpos
;
1391 tree gnu_field_bitpos
;
1392 tree gnu_field_offset
;
1394 enum machine_mode mode
;
1395 int unsignedp
, volatilep
;
1397 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1398 gnu_prefix
= remove_conversions (gnu_prefix
, 1);
1401 /* We can have 'Bit on any object, but if it isn't a
1402 COMPONENT_REF, the result is zero. Do not allow
1403 'Bit on a bare component, though. */
1404 if (attribute
== Attr_Bit
1405 && TREE_CODE (gnu_prefix
) != COMPONENT_REF
1406 && TREE_CODE (gnu_prefix
) != FIELD_DECL
)
1408 gnu_result
= integer_zero_node
;
1412 else if (TREE_CODE (gnu_prefix
) != COMPONENT_REF
1413 && ! (attribute
== Attr_Bit_Position
1414 && TREE_CODE (gnu_prefix
) == FIELD_DECL
))
1417 get_inner_reference (gnu_prefix
, &bitsize
, &bitpos
, &gnu_offset
,
1418 &mode
, &unsignedp
, &volatilep
);
1420 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
)
1423 = bit_position (TREE_OPERAND (gnu_prefix
, 1));
1425 = byte_position (TREE_OPERAND (gnu_prefix
, 1));
1427 for (gnu_inner
= TREE_OPERAND (gnu_prefix
, 0);
1428 TREE_CODE (gnu_inner
) == COMPONENT_REF
1429 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner
, 1));
1430 gnu_inner
= TREE_OPERAND (gnu_inner
, 0))
1433 = size_binop (PLUS_EXPR
, gnu_field_bitpos
,
1434 bit_position (TREE_OPERAND (gnu_inner
,
1437 = size_binop (PLUS_EXPR
, gnu_field_offset
,
1438 byte_position (TREE_OPERAND (gnu_inner
,
1442 else if (TREE_CODE (gnu_prefix
) == FIELD_DECL
)
1444 gnu_field_bitpos
= bit_position (gnu_prefix
);
1445 gnu_field_offset
= byte_position (gnu_prefix
);
1449 gnu_field_bitpos
= bitsize_zero_node
;
1450 gnu_field_offset
= size_zero_node
;
1456 gnu_result
= gnu_field_offset
;
1459 case Attr_First_Bit
:
1461 gnu_result
= size_int (bitpos
% BITS_PER_UNIT
);
1465 gnu_result
= bitsize_int (bitpos
% BITS_PER_UNIT
);
1467 = size_binop (PLUS_EXPR
, gnu_result
,
1468 TYPE_SIZE (TREE_TYPE (gnu_prefix
)));
1469 gnu_result
= size_binop (MINUS_EXPR
, gnu_result
,
1473 case Attr_Bit_Position
:
1474 gnu_result
= gnu_field_bitpos
;
1478 /* If this has a PLACEHOLDER_EXPR, qualify it by the object
1480 if (TREE_CODE (gnu_result
) != INTEGER_CST
1481 && contains_placeholder_p (gnu_result
))
1482 gnu_result
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_result
),
1483 gnu_result
, gnu_prefix
);
1490 gnu_lhs
= gnat_to_gnu (First (Expressions (gnat_node
)));
1491 gnu_rhs
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1493 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1494 gnu_result
= build_binary_op (attribute
== Attr_Min
1495 ? MIN_EXPR
: MAX_EXPR
,
1496 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1499 case Attr_Passed_By_Reference
:
1500 gnu_result
= size_int (default_pass_by_ref (gnu_type
)
1501 || must_pass_by_ref (gnu_type
));
1502 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1505 case Attr_Component_Size
:
1506 if (TREE_CODE (gnu_prefix
) == COMPONENT_REF
1507 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))
1509 && (TYPE_IS_PADDING_P
1510 (TREE_TYPE (TREE_OPERAND (gnu_prefix
, 0)))))
1511 gnu_prefix
= TREE_OPERAND (gnu_prefix
, 0);
1513 gnu_prefix
= maybe_implicit_deref (gnu_prefix
);
1514 gnu_type
= TREE_TYPE (gnu_prefix
);
1516 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1518 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type
))));
1520 while (TREE_CODE (TREE_TYPE (gnu_type
)) == ARRAY_TYPE
1521 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type
)))
1522 gnu_type
= TREE_TYPE (gnu_type
);
1524 if (TREE_CODE (gnu_type
) != ARRAY_TYPE
)
1527 /* Note this size cannot be self-referential. */
1528 gnu_result
= TYPE_SIZE (TREE_TYPE (gnu_type
));
1529 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1533 case Attr_Null_Parameter
:
1534 /* This is just a zero cast to the pointer type for
1535 our prefix and dereferenced. */
1536 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1538 = build_unary_op (INDIRECT_REF
, NULL_TREE
,
1539 convert (build_pointer_type (gnu_result_type
),
1540 integer_zero_node
));
1541 TREE_PRIVATE (gnu_result
) = 1;
1544 case Attr_Mechanism_Code
:
1547 Entity_Id gnat_obj
= Entity (Prefix (gnat_node
));
1550 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1551 if (Present (Expressions (gnat_node
)))
1553 int i
= UI_To_Int (Intval (First (Expressions (gnat_node
))));
1555 for (gnat_obj
= First_Formal (gnat_obj
); i
> 1;
1556 i
--, gnat_obj
= Next_Formal (gnat_obj
))
1560 code
= Mechanism (gnat_obj
);
1561 if (code
== Default
)
1562 code
= ((present_gnu_tree (gnat_obj
)
1563 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj
))
1564 || (DECL_BY_COMPONENT_PTR_P
1565 (get_gnu_tree (gnat_obj
)))))
1566 ? By_Reference
: By_Copy
);
1567 gnu_result
= convert (gnu_result_type
, size_int (- code
));
1572 /* Say we have an unimplemented attribute. Then set the
1573 value to be returned to be a zero and hope that's something
1574 we can convert to the type of this attribute. */
1576 post_error ("unimplemented attribute", gnat_node
);
1577 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1578 gnu_result
= integer_zero_node
;
1582 /* If this is an attribute where the prefix was unused,
1583 force a use of it if it has a side-effect. But don't do it if
1584 the prefix is just an entity name. However, if an access check
1585 is needed, we must do it. See second example in AARM 11.6(5.e). */
1586 if (prefix_unused
&& TREE_SIDE_EFFECTS (gnu_prefix
)
1587 && (! Is_Entity_Name (Prefix (gnat_node
))
1588 || Do_Access_Check (gnat_node
)))
1589 gnu_result
= fold (build (COMPOUND_EXPR
, TREE_TYPE (gnu_result
),
1590 gnu_prefix
, gnu_result
));
1595 /* Like 'Access as far as we are concerned. */
1596 gnu_result
= gnat_to_gnu (Prefix (gnat_node
));
1597 gnu_result
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_result
);
1598 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1602 case N_Extension_Aggregate
:
1606 /* ??? It is wrong to evaluate the type now, but there doesn't
1607 seem to be any other practical way of doing it. */
1609 gnu_aggr_type
= gnu_result_type
1610 = get_unpadded_type (Etype (gnat_node
));
1612 if (TREE_CODE (gnu_result_type
) == RECORD_TYPE
1613 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type
))
1615 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_result_type
)));
1617 if (Null_Record_Present (gnat_node
))
1618 gnu_result
= build_constructor (gnu_aggr_type
, NULL_TREE
);
1620 else if (TREE_CODE (gnu_aggr_type
) == RECORD_TYPE
)
1622 = assoc_to_constructor (First (Component_Associations (gnat_node
)),
1624 else if (TREE_CODE (gnu_aggr_type
) == UNION_TYPE
)
1626 /* The first element is the discrimant, which we ignore. The
1627 next is the field we're building. Convert the expression
1628 to the type of the field and then to the union type. */
1630 = Next (First (Component_Associations (gnat_node
)));
1631 Entity_Id gnat_field
= Entity (First (Choices (gnat_assoc
)));
1633 = TREE_TYPE (gnat_to_gnu_entity (gnat_field
, NULL_TREE
, 0));
1635 gnu_result
= convert (gnu_field_type
,
1636 gnat_to_gnu (Expression (gnat_assoc
)));
1638 else if (TREE_CODE (gnu_aggr_type
) == ARRAY_TYPE
)
1639 gnu_result
= pos_to_constructor (First (Expressions (gnat_node
)),
1641 Component_Type (Etype (gnat_node
)));
1642 else if (TREE_CODE (gnu_aggr_type
) == COMPLEX_TYPE
)
1645 (COMPLEX_EXPR
, gnu_aggr_type
,
1646 gnat_to_gnu (Expression (First
1647 (Component_Associations (gnat_node
)))),
1648 gnat_to_gnu (Expression
1650 (First (Component_Associations (gnat_node
))))));
1654 gnu_result
= convert (gnu_result_type
, gnu_result
);
1659 gnu_result
= null_pointer_node
;
1660 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1663 case N_Type_Conversion
:
1664 case N_Qualified_Expression
:
1665 /* Get the operand expression. */
1666 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1667 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1670 = convert_with_check (Etype (gnat_node
), gnu_result
,
1671 Do_Overflow_Check (gnat_node
),
1672 Do_Range_Check (Expression (gnat_node
)),
1673 Nkind (gnat_node
) == N_Type_Conversion
1674 && Float_Truncate (gnat_node
));
1677 case N_Unchecked_Type_Conversion
:
1678 gnu_result
= gnat_to_gnu (Expression (gnat_node
));
1679 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1681 /* If the result is a pointer type, see if we are improperly
1682 converting to a stricter alignment. */
1684 if (STRICT_ALIGNMENT
&& POINTER_TYPE_P (gnu_result_type
)
1685 && IN (Ekind (Etype (gnat_node
)), Access_Kind
))
1687 unsigned int align
= known_alignment (gnu_result
);
1688 tree gnu_obj_type
= TREE_TYPE (gnu_result_type
);
1690 = TREE_CODE (gnu_obj_type
) == FUNCTION_TYPE
1691 ? FUNCTION_BOUNDARY
: TYPE_ALIGN (gnu_obj_type
);
1693 if (align
!= 0 && align
< oalign
&& ! TYPE_ALIGN_OK (gnu_obj_type
))
1694 post_error_ne_tree_2
1695 ("?source alignment (^) < alignment of & (^)",
1696 gnat_node
, Designated_Type (Etype (gnat_node
)),
1697 size_int (align
/ BITS_PER_UNIT
), oalign
/ BITS_PER_UNIT
);
1700 gnu_result
= unchecked_convert (gnu_result_type
, gnu_result
);
1706 tree gnu_object
= gnat_to_gnu (Left_Opnd (gnat_node
));
1707 Node_Id gnat_range
= Right_Opnd (gnat_node
);
1711 /* GNAT_RANGE is either an N_Range node or an identifier
1712 denoting a subtype. */
1713 if (Nkind (gnat_range
) == N_Range
)
1715 gnu_low
= gnat_to_gnu (Low_Bound (gnat_range
));
1716 gnu_high
= gnat_to_gnu (High_Bound (gnat_range
));
1718 else if (Nkind (gnat_range
) == N_Identifier
1719 || Nkind (gnat_range
) == N_Expanded_Name
)
1721 tree gnu_range_type
= get_unpadded_type (Entity (gnat_range
));
1723 gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
1724 gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
1729 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1731 /* If LOW and HIGH are identical, perform an equality test.
1732 Otherwise, ensure that GNU_OBJECT is only evaluated once
1733 and perform a full range test. */
1734 if (operand_equal_p (gnu_low
, gnu_high
, 0))
1735 gnu_result
= build_binary_op (EQ_EXPR
, gnu_result_type
,
1736 gnu_object
, gnu_low
);
1739 gnu_object
= protect_multiple_eval (gnu_object
);
1741 = build_binary_op (TRUTH_ANDIF_EXPR
, gnu_result_type
,
1742 build_binary_op (GE_EXPR
, gnu_result_type
,
1743 gnu_object
, gnu_low
),
1744 build_binary_op (LE_EXPR
, gnu_result_type
,
1745 gnu_object
, gnu_high
));
1748 if (Nkind (gnat_node
) == N_Not_In
)
1749 gnu_result
= invert_truthvalue (gnu_result
);
1754 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1755 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1756 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1757 gnu_result
= build_binary_op (FLOAT_TYPE_P (gnu_result_type
)
1759 : (Rounded_Result (gnat_node
)
1760 ? ROUND_DIV_EXPR
: TRUNC_DIV_EXPR
),
1761 gnu_result_type
, gnu_lhs
, gnu_rhs
);
1764 case N_And_Then
: case N_Or_Else
:
1766 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1769 /* The elaboration of the RHS may generate code. If so,
1770 we need to make sure it gets executed after the LHS. */
1771 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1773 gnu_rhs_side
= expand_start_stmt_expr (/*has_scope=*/1);
1774 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1775 expand_end_stmt_expr (gnu_rhs_side
);
1776 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1778 if (RTL_EXPR_SEQUENCE (gnu_rhs_side
) != 0)
1779 gnu_rhs
= build (COMPOUND_EXPR
, gnu_result_type
, gnu_rhs_side
,
1782 gnu_result
= build_binary_op (code
, gnu_result_type
, gnu_lhs
, gnu_rhs
);
1786 case N_Op_Or
: case N_Op_And
: case N_Op_Xor
:
1787 /* These can either be operations on booleans or on modular types.
1788 Fall through for boolean types since that's the way GNU_CODES is
1790 if (IN (Ekind (Underlying_Type (Etype (gnat_node
))),
1791 Modular_Integer_Kind
))
1794 = (Nkind (gnat_node
) == N_Op_Or
? BIT_IOR_EXPR
1795 : Nkind (gnat_node
) == N_Op_And
? BIT_AND_EXPR
1798 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1799 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1800 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1801 gnu_result
= build_binary_op (code
, gnu_result_type
,
1806 /* ... fall through ... */
1808 case N_Op_Eq
: case N_Op_Ne
: case N_Op_Lt
:
1809 case N_Op_Le
: case N_Op_Gt
: case N_Op_Ge
:
1810 case N_Op_Add
: case N_Op_Subtract
: case N_Op_Multiply
:
1811 case N_Op_Mod
: case N_Op_Rem
:
1812 case N_Op_Rotate_Left
:
1813 case N_Op_Rotate_Right
:
1814 case N_Op_Shift_Left
:
1815 case N_Op_Shift_Right
:
1816 case N_Op_Shift_Right_Arithmetic
:
1818 enum tree_code code
= gnu_codes
[Nkind (gnat_node
)];
1821 gnu_lhs
= gnat_to_gnu (Left_Opnd (gnat_node
));
1822 gnu_rhs
= gnat_to_gnu (Right_Opnd (gnat_node
));
1823 gnu_type
= gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1825 /* If this is a comparison operator, convert any references to
1826 an unconstrained array value into a reference to the
1828 if (TREE_CODE_CLASS (code
) == '<')
1830 gnu_lhs
= maybe_unconstrained_array (gnu_lhs
);
1831 gnu_rhs
= maybe_unconstrained_array (gnu_rhs
);
1834 /* If the result type is a private type, its full view may be a
1835 numeric subtype. The representation we need is that of its base
1836 type, given that it is the result of an arithmetic operation. */
1837 else if (Is_Private_Type (Etype (gnat_node
)))
1838 gnu_type
= gnu_result_type
1839 = get_unpadded_type (Base_Type (Full_View (Etype (gnat_node
))));
1841 /* If this is a shift whose count is not guaranteed to be correct,
1842 we need to adjust the shift count. */
1843 if (IN (Nkind (gnat_node
), N_Op_Shift
)
1844 && ! Shift_Count_OK (gnat_node
))
1846 tree gnu_count_type
= get_base_type (TREE_TYPE (gnu_rhs
));
1848 = convert (gnu_count_type
, TYPE_SIZE (gnu_type
));
1850 if (Nkind (gnat_node
) == N_Op_Rotate_Left
1851 || Nkind (gnat_node
) == N_Op_Rotate_Right
)
1852 gnu_rhs
= build_binary_op (TRUNC_MOD_EXPR
, gnu_count_type
,
1853 gnu_rhs
, gnu_max_shift
);
1854 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
)
1857 (MIN_EXPR
, gnu_count_type
,
1858 build_binary_op (MINUS_EXPR
,
1861 convert (gnu_count_type
,
1866 /* For right shifts, the type says what kind of shift to do,
1867 so we may need to choose a different type. */
1868 if (Nkind (gnat_node
) == N_Op_Shift_Right
1869 && ! TREE_UNSIGNED (gnu_type
))
1870 gnu_type
= gnat_unsigned_type (gnu_type
);
1871 else if (Nkind (gnat_node
) == N_Op_Shift_Right_Arithmetic
1872 && TREE_UNSIGNED (gnu_type
))
1873 gnu_type
= gnat_signed_type (gnu_type
);
1875 if (gnu_type
!= gnu_result_type
)
1877 gnu_lhs
= convert (gnu_type
, gnu_lhs
);
1878 gnu_rhs
= convert (gnu_type
, gnu_rhs
);
1881 gnu_result
= build_binary_op (code
, gnu_type
, gnu_lhs
, gnu_rhs
);
1883 /* If this is a logical shift with the shift count not verified,
1884 we must return zero if it is too large. We cannot compensate
1885 above in this case. */
1886 if ((Nkind (gnat_node
) == N_Op_Shift_Left
1887 || Nkind (gnat_node
) == N_Op_Shift_Right
)
1888 && ! Shift_Count_OK (gnat_node
))
1892 build_binary_op (GE_EXPR
, integer_type_node
,
1894 convert (TREE_TYPE (gnu_rhs
),
1895 TYPE_SIZE (gnu_type
))),
1896 convert (gnu_type
, integer_zero_node
),
1901 case N_Conditional_Expression
:
1903 tree gnu_cond
= gnat_to_gnu (First (Expressions (gnat_node
)));
1904 tree gnu_true
= gnat_to_gnu (Next (First (Expressions (gnat_node
))));
1906 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node
)))));
1908 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1909 gnu_result
= build_cond_expr (gnu_result_type
,
1910 gnat_truthvalue_conversion (gnu_cond
),
1911 gnu_true
, gnu_false
);
1916 gnu_result
= gnat_to_gnu (Right_Opnd (gnat_node
));
1917 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1921 /* This case can apply to a boolean or a modular type.
1922 Fall through for a boolean operand since GNU_CODES is set
1923 up to handle this. */
1924 if (IN (Ekind (Etype (gnat_node
)), Modular_Integer_Kind
))
1926 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1927 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1928 gnu_result
= build_unary_op (BIT_NOT_EXPR
, gnu_result_type
,
1933 /* ... fall through ... */
1935 case N_Op_Minus
: case N_Op_Abs
:
1936 gnu_expr
= gnat_to_gnu (Right_Opnd (gnat_node
));
1938 if (Ekind (Etype (gnat_node
)) != E_Private_Type
)
1939 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1941 gnu_result_type
= get_unpadded_type (Base_Type
1942 (Full_View (Etype (gnat_node
))));
1944 gnu_result
= build_unary_op (gnu_codes
[Nkind (gnat_node
)],
1945 gnu_result_type
, gnu_expr
);
1953 gnat_temp
= Expression (gnat_node
);
1955 /* The Expression operand can either be an N_Identifier or
1956 Expanded_Name, which must represent a type, or a
1957 N_Qualified_Expression, which contains both the object type and an
1958 initial value for the object. */
1959 if (Nkind (gnat_temp
) == N_Identifier
1960 || Nkind (gnat_temp
) == N_Expanded_Name
)
1961 gnu_type
= gnat_to_gnu_type (Entity (gnat_temp
));
1962 else if (Nkind (gnat_temp
) == N_Qualified_Expression
)
1964 Entity_Id gnat_desig_type
1965 = Designated_Type (Underlying_Type (Etype (gnat_node
)));
1967 gnu_init
= gnat_to_gnu (Expression (gnat_temp
));
1969 gnu_init
= maybe_unconstrained_array (gnu_init
);
1970 if (Do_Range_Check (Expression (gnat_temp
)))
1971 gnu_init
= emit_range_check (gnu_init
, gnat_desig_type
);
1973 if (Is_Elementary_Type (gnat_desig_type
)
1974 || Is_Constrained (gnat_desig_type
))
1976 gnu_type
= gnat_to_gnu_type (gnat_desig_type
);
1977 gnu_init
= convert (gnu_type
, gnu_init
);
1981 gnu_type
= gnat_to_gnu_type (Etype (Expression (gnat_temp
)));
1982 if (TREE_CODE (gnu_type
) == UNCONSTRAINED_ARRAY_TYPE
)
1983 gnu_type
= TREE_TYPE (gnu_init
);
1985 gnu_init
= convert (gnu_type
, gnu_init
);
1991 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
1992 return build_allocator (gnu_type
, gnu_init
, gnu_result_type
,
1993 Procedure_To_Call (gnat_node
),
1994 Storage_Pool (gnat_node
));
1998 /***************************/
1999 /* Chapter 5: Statements: */
2000 /***************************/
2003 if (! type_annotate_only
)
2005 tree gnu_label
= gnat_to_gnu (Identifier (gnat_node
));
2006 Node_Id gnat_parent
= Parent (gnat_node
);
2008 expand_label (gnu_label
);
2010 /* If this is the first label of an exception handler, we must
2011 mark that any CALL_INSN can jump to it. */
2012 if (Present (gnat_parent
)
2013 && Nkind (gnat_parent
) == N_Exception_Handler
2014 && First (Statements (gnat_parent
)) == gnat_node
)
2015 nonlocal_goto_handler_labels
2016 = gen_rtx_EXPR_LIST (VOIDmode
, label_rtx (gnu_label
),
2017 nonlocal_goto_handler_labels
);
2021 case N_Null_Statement
:
2024 case N_Assignment_Statement
:
2025 if (type_annotate_only
)
2028 /* Get the LHS and RHS of the statement and convert any reference to an
2029 unconstrained array into a reference to the underlying array. */
2030 gnu_lhs
= maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node
)));
2032 = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node
)));
2034 set_lineno (gnat_node
, 1);
2036 /* If range check is needed, emit code to generate it */
2037 if (Do_Range_Check (Expression (gnat_node
)))
2038 gnu_rhs
= emit_range_check (gnu_rhs
, Etype (Name (gnat_node
)));
2040 /* If either side's type has a size that overflows, convert this
2041 into raise of Storage_Error: execution shouldn't have gotten
2043 if ((TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_lhs
))) == INTEGER_CST
2044 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_lhs
))))
2045 || (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_rhs
))) == INTEGER_CST
2046 && TREE_OVERFLOW (TYPE_SIZE (TREE_TYPE (gnu_rhs
)))))
2047 expand_expr_stmt (build_call_raise (SE_Object_Too_Large
));
2049 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2053 case N_If_Statement
:
2054 /* Start an IF statement giving the condition. */
2055 gnu_expr
= gnat_to_gnu (Condition (gnat_node
));
2056 set_lineno (gnat_node
, 1);
2057 expand_start_cond (gnu_expr
, 0);
2059 /* Generate code for the statements to be executed if the condition
2062 for (gnat_temp
= First (Then_Statements (gnat_node
));
2063 Present (gnat_temp
);
2064 gnat_temp
= Next (gnat_temp
))
2065 gnat_to_code (gnat_temp
);
2067 /* Generate each of the "else if" parts. */
2068 if (Present (Elsif_Parts (gnat_node
)))
2070 for (gnat_temp
= First (Elsif_Parts (gnat_node
));
2071 Present (gnat_temp
);
2072 gnat_temp
= Next (gnat_temp
))
2074 Node_Id gnat_statement
;
2076 expand_start_else ();
2078 /* Set up the line numbers for each condition we test. */
2079 set_lineno (Condition (gnat_temp
), 1);
2080 expand_elseif (gnat_to_gnu (Condition (gnat_temp
)));
2082 for (gnat_statement
= First (Then_Statements (gnat_temp
));
2083 Present (gnat_statement
);
2084 gnat_statement
= Next (gnat_statement
))
2085 gnat_to_code (gnat_statement
);
2089 /* Finally, handle any statements in the "else" part. */
2090 if (Present (Else_Statements (gnat_node
)))
2092 expand_start_else ();
2094 for (gnat_temp
= First (Else_Statements (gnat_node
));
2095 Present (gnat_temp
);
2096 gnat_temp
= Next (gnat_temp
))
2097 gnat_to_code (gnat_temp
);
2103 case N_Case_Statement
:
2106 Node_Id gnat_choice
;
2108 Node_Id gnat_statement
;
2110 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
2111 gnu_expr
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
2113 set_lineno (gnat_node
, 1);
2114 expand_start_case (1, gnu_expr
, TREE_TYPE (gnu_expr
), "case");
2116 for (gnat_when
= First_Non_Pragma (Alternatives (gnat_node
));
2117 Present (gnat_when
);
2118 gnat_when
= Next_Non_Pragma (gnat_when
))
2120 /* First compile all the different case choices for the current
2121 WHEN alternative. */
2123 for (gnat_choice
= First (Discrete_Choices (gnat_when
));
2124 Present (gnat_choice
); gnat_choice
= Next (gnat_choice
))
2128 gnu_label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2130 set_lineno (gnat_choice
, 1);
2131 switch (Nkind (gnat_choice
))
2134 /* Abort on all errors except range empty, which
2135 means we ignore this alternative. */
2137 = pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice
)),
2138 gnat_to_gnu (High_Bound (gnat_choice
)),
2139 convert
, gnu_label
, 0);
2141 if (error_code
!= 0 && error_code
!= 4)
2145 case N_Subtype_Indication
:
2148 (gnat_to_gnu (Low_Bound (Range_Expression
2149 (Constraint (gnat_choice
)))),
2150 gnat_to_gnu (High_Bound (Range_Expression
2151 (Constraint (gnat_choice
)))),
2152 convert
, gnu_label
, 0);
2154 if (error_code
!= 0 && error_code
!= 4)
2159 case N_Expanded_Name
:
2160 /* This represents either a subtype range or a static value
2161 of some kind; Ekind says which. If a static value,
2162 fall through to the next case. */
2163 if (IN (Ekind (Entity (gnat_choice
)), Type_Kind
))
2165 tree type
= get_unpadded_type (Entity (gnat_choice
));
2168 = pushcase_range (fold (TYPE_MIN_VALUE (type
)),
2169 fold (TYPE_MAX_VALUE (type
)),
2170 convert
, gnu_label
, 0);
2172 if (error_code
!= 0 && error_code
!= 4)
2176 /* ... fall through ... */
2177 case N_Character_Literal
:
2178 case N_Integer_Literal
:
2179 if (pushcase (gnat_to_gnu (gnat_choice
), convert
,
2184 case N_Others_Choice
:
2185 if (pushcase (NULL_TREE
, convert
, gnu_label
, 0))
2194 /* After compiling the choices attached to the WHEN compile the
2195 body of statements that have to be executed, should the
2196 "WHEN ... =>" be taken. Push a binding level here in case
2197 variables are declared since we want them to be local to this
2198 set of statements instead of the block containing the Case
2201 expand_start_bindings (0);
2202 for (gnat_statement
= First (Statements (gnat_when
));
2203 Present (gnat_statement
);
2204 gnat_statement
= Next (gnat_statement
))
2205 gnat_to_code (gnat_statement
);
2207 /* Communicate to GCC that we are done with the current WHEN,
2208 i.e. insert a "break" statement. */
2209 expand_exit_something ();
2210 expand_end_bindings (getdecls (), kept_level_p (), 0);
2211 poplevel (kept_level_p (), 1, 0);
2214 expand_end_case (gnu_expr
);
2218 case N_Loop_Statement
:
2220 /* The loop variable in GCC form, if any. */
2221 tree gnu_loop_var
= NULL_TREE
;
2222 /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */
2223 enum tree_code gnu_update
= ERROR_MARK
;
2224 /* Used if this is a named loop for so EXIT can work. */
2225 struct nesting
*loop_id
;
2226 /* Condition to continue loop tested at top of loop. */
2227 tree gnu_top_condition
= integer_one_node
;
2228 /* Similar, but tested at bottom of loop. */
2229 tree gnu_bottom_condition
= integer_one_node
;
2230 Node_Id gnat_statement
;
2231 Node_Id gnat_iter_scheme
= Iteration_Scheme (gnat_node
);
2232 Node_Id gnat_top_condition
= Empty
;
2233 int enclosing_if_p
= 0;
2235 /* Set the condition that under which the loop should continue.
2236 For "LOOP .... END LOOP;" the condition is always true. */
2237 if (No (gnat_iter_scheme
))
2239 /* The case "WHILE condition LOOP ..... END LOOP;" */
2240 else if (Present (Condition (gnat_iter_scheme
)))
2241 gnat_top_condition
= Condition (gnat_iter_scheme
);
2244 /* We have an iteration scheme. */
2245 Node_Id gnat_loop_spec
2246 = Loop_Parameter_Specification (gnat_iter_scheme
);
2247 Entity_Id gnat_loop_var
= Defining_Entity (gnat_loop_spec
);
2248 Entity_Id gnat_type
= Etype (gnat_loop_var
);
2249 tree gnu_type
= get_unpadded_type (gnat_type
);
2250 tree gnu_low
= TYPE_MIN_VALUE (gnu_type
);
2251 tree gnu_high
= TYPE_MAX_VALUE (gnu_type
);
2252 int reversep
= Reverse_Present (gnat_loop_spec
);
2253 tree gnu_first
= reversep
? gnu_high
: gnu_low
;
2254 tree gnu_last
= reversep
? gnu_low
: gnu_high
;
2255 enum tree_code end_code
= reversep
? GE_EXPR
: LE_EXPR
;
2256 tree gnu_base_type
= get_base_type (gnu_type
);
2258 = (reversep
? TYPE_MIN_VALUE (gnu_base_type
)
2259 : TYPE_MAX_VALUE (gnu_base_type
));
2261 /* We know the loop variable will not overflow if GNU_LAST is
2262 a constant and is not equal to GNU_LIMIT. If it might
2263 overflow, we have to move the limit test to the end of
2264 the loop. In that case, we have to test for an
2265 empty loop outside the loop. */
2266 if (TREE_CODE (gnu_last
) != INTEGER_CST
2267 || TREE_CODE (gnu_limit
) != INTEGER_CST
2268 || tree_int_cst_equal (gnu_last
, gnu_limit
))
2270 gnu_expr
= build_binary_op (LE_EXPR
, integer_type_node
,
2272 set_lineno (gnat_loop_spec
, 1);
2273 expand_start_cond (gnu_expr
, 0);
2277 /* Open a new nesting level that will surround the loop to declare
2278 the loop index variable. */
2280 expand_start_bindings (0);
2282 /* Declare the loop index and set it to its initial value. */
2283 gnu_loop_var
= gnat_to_gnu_entity (gnat_loop_var
, gnu_first
, 1);
2284 if (DECL_BY_REF_P (gnu_loop_var
))
2285 gnu_loop_var
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
2288 /* The loop variable might be a padded type, so use `convert' to
2289 get a reference to the inner variable if so. */
2290 gnu_loop_var
= convert (get_base_type (gnu_type
), gnu_loop_var
);
2292 /* Set either the top or bottom exit condition as
2293 appropriate depending on whether we know an overflow
2294 cannot occur or not. */
2296 gnu_bottom_condition
2297 = build_binary_op (NE_EXPR
, integer_type_node
,
2298 gnu_loop_var
, gnu_last
);
2301 = build_binary_op (end_code
, integer_type_node
,
2302 gnu_loop_var
, gnu_last
);
2304 gnu_update
= reversep
? PREDECREMENT_EXPR
: PREINCREMENT_EXPR
;
2307 set_lineno (gnat_node
, 1);
2309 loop_id
= expand_start_loop_continue_elsewhere (1);
2311 loop_id
= expand_start_loop (1);
2313 /* If the loop was named, have the name point to this loop. In this
2314 case, the association is not a ..._DECL node; in fact, it isn't
2315 a GCC tree node at all. Since this name is referenced inside
2316 the loop, do it before we process the statements of the loop. */
2317 if (Present (Identifier (gnat_node
)))
2319 tree gnu_loop_id
= make_node (GNAT_LOOP_ID
);
2321 TREE_LOOP_ID (gnu_loop_id
) = (rtx
) loop_id
;
2322 save_gnu_tree (Entity (Identifier (gnat_node
)), gnu_loop_id
, 1);
2325 set_lineno (gnat_node
, 1);
2327 /* We must evaluate the condition after we've entered the
2328 loop so that any expression actions get done in the right
2330 if (Present (gnat_top_condition
))
2331 gnu_top_condition
= gnat_to_gnu (gnat_top_condition
);
2333 expand_exit_loop_top_cond (0, gnu_top_condition
);
2335 /* Make the loop body into its own block, so any allocated
2336 storage will be released every iteration. This is needed
2337 for stack allocation. */
2341 = tree_cons (gnu_bottom_condition
, NULL_TREE
, gnu_block_stack
);
2342 expand_start_bindings (0);
2344 for (gnat_statement
= First (Statements (gnat_node
));
2345 Present (gnat_statement
);
2346 gnat_statement
= Next (gnat_statement
))
2347 gnat_to_code (gnat_statement
);
2349 expand_end_bindings (getdecls (), kept_level_p (), 0);
2350 poplevel (kept_level_p (), 1, 0);
2351 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2353 set_lineno (gnat_node
, 1);
2354 expand_exit_loop_if_false (0, gnu_bottom_condition
);
2358 expand_loop_continue_here ();
2359 gnu_expr
= build_binary_op (gnu_update
, TREE_TYPE (gnu_loop_var
),
2361 convert (TREE_TYPE (gnu_loop_var
),
2363 set_lineno (gnat_iter_scheme
, 1);
2364 expand_expr_stmt (gnu_expr
);
2367 set_lineno (gnat_node
, 1);
2372 /* Close the nesting level that sourround the loop that was used to
2373 declare the loop index variable. */
2374 set_lineno (gnat_node
, 1);
2375 expand_end_bindings (getdecls (), 1, 0);
2381 set_lineno (gnat_node
, 1);
2387 case N_Block_Statement
:
2389 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2390 expand_start_bindings (0);
2391 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2392 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2393 expand_end_bindings (getdecls (), kept_level_p (), 0);
2394 poplevel (kept_level_p (), 1, 0);
2395 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2396 if (Present (Identifier (gnat_node
)))
2397 mark_out_of_scope (Entity (Identifier (gnat_node
)));
2400 case N_Exit_Statement
:
2402 /* Which loop to exit, NULL if the current loop. */
2403 struct nesting
*loop_id
= 0;
2404 /* The GCC version of the optional GNAT condition node attached to the
2405 exit statement. Exit the loop if this is false. */
2406 tree gnu_cond
= integer_zero_node
;
2408 if (Present (Name (gnat_node
)))
2410 = (struct nesting
*)
2411 TREE_LOOP_ID (get_gnu_tree (Entity (Name (gnat_node
))));
2413 if (Present (Condition (gnat_node
)))
2414 gnu_cond
= invert_truthvalue (gnat_truthvalue_conversion
2415 (gnat_to_gnu (Condition (gnat_node
))));
2417 set_lineno (gnat_node
, 1);
2418 expand_exit_loop_if_false (loop_id
, gnu_cond
);
2422 case N_Return_Statement
:
2423 if (type_annotate_only
)
2427 /* The gnu function type of the subprogram currently processed. */
2428 tree gnu_subprog_type
= TREE_TYPE (current_function_decl
);
2429 /* The return value from the subprogram. */
2430 tree gnu_ret_val
= 0;
2432 /* If we are dealing with a "return;" from an Ada procedure with
2433 parameters passed by copy in copy out, we need to return a record
2434 containing the final values of these parameters. If the list
2435 contains only one entry, return just that entry.
2437 For a full description of the copy in copy out parameter mechanism,
2438 see the part of the gnat_to_gnu_entity routine dealing with the
2439 translation of subprograms.
2441 But if we have a return label defined, convert this into
2442 a branch to that label. */
2444 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2445 expand_goto (TREE_VALUE (gnu_return_label_stack
));
2447 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
2449 if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type
)) == 1)
2450 gnu_ret_val
= TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type
));
2453 = build_constructor (TREE_TYPE (gnu_subprog_type
),
2454 TYPE_CI_CO_LIST (gnu_subprog_type
));
2457 /* If the Ada subprogram is a function, we just need to return the
2458 expression. If the subprogram returns an unconstrained
2459 array, we have to allocate a new version of the result and
2460 return it. If we return by reference, return a pointer. */
2462 else if (Present (Expression (gnat_node
)))
2464 gnu_ret_val
= gnat_to_gnu (Expression (gnat_node
));
2466 /* Do not remove the padding from GNU_RET_VAL if the inner
2467 type is self-referential since we want to allocate the fixed
2468 size in that case. */
2469 if (TREE_CODE (gnu_ret_val
) == COMPONENT_REF
2470 && (TYPE_IS_PADDING_P
2471 (TREE_TYPE (TREE_OPERAND (gnu_ret_val
, 0))))
2472 && contains_placeholder_p
2473 (TYPE_SIZE (TREE_TYPE (gnu_ret_val
))))
2474 gnu_ret_val
= TREE_OPERAND (gnu_ret_val
, 0);
2476 if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type
)
2477 || By_Ref (gnat_node
))
2478 gnu_ret_val
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_ret_val
);
2480 else if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
))
2482 gnu_ret_val
= maybe_unconstrained_array (gnu_ret_val
);
2484 /* We have two cases: either the function returns with
2485 depressed stack or not. If not, we allocate on the
2486 secondary stack. If so, we allocate in the stack frame.
2487 if no copy is needed, the front end will set By_Ref,
2488 which we handle in the case above. */
2489 if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type
))
2491 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2492 TREE_TYPE (gnu_subprog_type
), 0, -1);
2495 = build_allocator (TREE_TYPE (gnu_ret_val
), gnu_ret_val
,
2496 TREE_TYPE (gnu_subprog_type
),
2497 Procedure_To_Call (gnat_node
),
2498 Storage_Pool (gnat_node
));
2502 set_lineno (gnat_node
, 1);
2504 expand_return (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2505 DECL_RESULT (current_function_decl
),
2508 expand_null_return ();
2513 case N_Goto_Statement
:
2514 if (type_annotate_only
)
2517 gnu_expr
= gnat_to_gnu (Name (gnat_node
));
2518 TREE_USED (gnu_expr
) = 1;
2519 set_lineno (gnat_node
, 1);
2520 expand_goto (gnu_expr
);
2523 /****************************/
2524 /* Chapter 6: Subprograms: */
2525 /****************************/
2527 case N_Subprogram_Declaration
:
2528 /* Unless there is a freeze node, declare the subprogram. We consider
2529 this a "definition" even though we're not generating code for
2530 the subprogram because we will be making the corresponding GCC
2533 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node
)))))
2534 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node
)),
2539 case N_Abstract_Subprogram_Declaration
:
2540 /* This subprogram doesn't exist for code generation purposes, but we
2541 have to elaborate the types of any parameters, unless they are
2542 imported types (nothing to generate in this case). */
2544 = First_Formal (Defining_Entity (Specification (gnat_node
)));
2545 Present (gnat_temp
);
2546 gnat_temp
= Next_Formal_With_Extras (gnat_temp
))
2547 if (Is_Itype (Etype (gnat_temp
))
2548 && !From_With_Type (Etype (gnat_temp
)))
2549 gnat_to_gnu_entity (Etype (gnat_temp
), NULL_TREE
, 0);
2553 case N_Defining_Program_Unit_Name
:
2554 /* For a child unit identifier go up a level to get the
2555 specificaton. We get this when we try to find the spec of
2556 a child unit package that is the compilation unit being compiled. */
2557 gnat_to_code (Parent (gnat_node
));
2560 case N_Subprogram_Body
:
2562 /* Save debug output mode in case it is reset. */
2563 enum debug_info_type save_write_symbols
= write_symbols
;
2564 const struct gcc_debug_hooks
*const save_debug_hooks
= debug_hooks
;
2565 /* Definining identifier of a parameter to the subprogram. */
2566 Entity_Id gnat_param
;
2567 /* The defining identifier for the subprogram body. Note that if a
2568 specification has appeared before for this body, then the identifier
2569 occurring in that specification will also be a defining identifier
2570 and all the calls to this subprogram will point to that
2572 Entity_Id gnat_subprog_id
2573 = (Present (Corresponding_Spec (gnat_node
))
2574 ? Corresponding_Spec (gnat_node
) : Defining_Entity (gnat_node
));
2576 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
2577 tree gnu_subprog_decl
;
2578 /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
2579 tree gnu_subprog_type
;
2582 /* If this is a generic object or if it has been eliminated,
2585 if (Ekind (gnat_subprog_id
) == E_Generic_Procedure
2586 || Ekind (gnat_subprog_id
) == E_Generic_Function
2587 || Is_Eliminated (gnat_subprog_id
))
2590 /* If debug information is suppressed for the subprogram,
2591 turn debug mode off for the duration of processing. */
2592 if (Debug_Info_Off (gnat_subprog_id
))
2594 write_symbols
= NO_DEBUG
;
2595 debug_hooks
= &do_nothing_debug_hooks
;
2598 /* If this subprogram acts as its own spec, define it. Otherwise,
2599 just get the already-elaborated tree node. However, if this
2600 subprogram had its elaboration deferred, we will already have
2601 made a tree node for it. So treat it as not being defined in
2602 that case. Such a subprogram cannot have an address clause or
2603 a freeze node, so this test is safe, though it does disable
2604 some otherwise-useful error checking. */
2606 = gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
,
2607 Acts_As_Spec (gnat_node
)
2608 && ! present_gnu_tree (gnat_subprog_id
));
2610 gnu_subprog_type
= TREE_TYPE (gnu_subprog_decl
);
2612 /* Set the line number in the decl to correspond to that of
2613 the body so that the line number notes are written
2615 set_lineno (gnat_node
, 0);
2616 DECL_SOURCE_FILE (gnu_subprog_decl
) = input_filename
;
2617 DECL_SOURCE_LINE (gnu_subprog_decl
) = lineno
;
2619 begin_subprog_body (gnu_subprog_decl
);
2620 set_lineno (gnat_node
, 1);
2623 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
2624 expand_start_bindings (0);
2626 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2628 /* If there are OUT parameters, we need to ensure that the
2629 return statement properly copies them out. We do this by
2630 making a new block and converting any inner return into a goto
2631 to a label at the end of the block. */
2633 if (gnu_cico_list
!= 0)
2635 gnu_return_label_stack
2636 = tree_cons (NULL_TREE
,
2637 build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
),
2638 gnu_return_label_stack
);
2640 expand_start_bindings (0);
2643 gnu_return_label_stack
2644 = tree_cons (NULL_TREE
, NULL_TREE
, gnu_return_label_stack
);
2646 /* See if there are any parameters for which we don't yet have
2647 GCC entities. These must be for OUT parameters for which we
2648 will be making VAR_DECL nodes here. Fill them in to
2649 TYPE_CI_CO_LIST, which must contain the empty entry as well.
2650 We can match up the entries because TYPE_CI_CO_LIST is in the
2651 order of the parameters. */
2653 for (gnat_param
= First_Formal (gnat_subprog_id
);
2654 Present (gnat_param
);
2655 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2656 if (present_gnu_tree (gnat_param
))
2657 adjust_decl_rtl (get_gnu_tree (gnat_param
));
2660 /* Skip any entries that have been already filled in; they
2661 must correspond to IN OUT parameters. */
2662 for (; gnu_cico_list
!= 0 && TREE_VALUE (gnu_cico_list
) != 0;
2663 gnu_cico_list
= TREE_CHAIN (gnu_cico_list
))
2666 /* Do any needed references for padded types. */
2667 TREE_VALUE (gnu_cico_list
)
2668 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list
)),
2669 gnat_to_gnu_entity (gnat_param
, NULL_TREE
, 1));
2672 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
2674 /* Generate the code of the subprogram itself. A return statement
2675 will be present and any OUT parameters will be handled there. */
2676 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
2678 expand_end_bindings (getdecls (), kept_level_p (), 0);
2679 poplevel (kept_level_p (), 1, 0);
2680 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
2682 if (TREE_VALUE (gnu_return_label_stack
) != 0)
2686 expand_end_bindings (NULL_TREE
, kept_level_p (), 0);
2687 poplevel (kept_level_p (), 1, 0);
2688 expand_label (TREE_VALUE (gnu_return_label_stack
));
2690 gnu_cico_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
2691 set_lineno (gnat_node
, 1);
2692 if (list_length (gnu_cico_list
) == 1)
2693 gnu_retval
= TREE_VALUE (gnu_cico_list
);
2695 gnu_retval
= build_constructor (TREE_TYPE (gnu_subprog_type
),
2698 if (DECL_P (gnu_retval
) && DECL_BY_REF_P (gnu_retval
))
2700 = build_unary_op (INDIRECT_REF
, NULL_TREE
, gnu_retval
);
2703 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
2704 DECL_RESULT (current_function_decl
),
2709 gnu_return_label_stack
= TREE_CHAIN (gnu_return_label_stack
);
2711 /* Disconnect the trees for parameters that we made variables for
2712 from the GNAT entities since these will become unusable after
2713 we end the function. */
2714 for (gnat_param
= First_Formal (gnat_subprog_id
);
2715 Present (gnat_param
);
2716 gnat_param
= Next_Formal_With_Extras (gnat_param
))
2717 if (TREE_CODE (get_gnu_tree (gnat_param
)) == VAR_DECL
)
2718 save_gnu_tree (gnat_param
, NULL_TREE
, 0);
2720 end_subprog_body ();
2721 mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node
)));
2722 write_symbols
= save_write_symbols
;
2723 debug_hooks
= save_debug_hooks
;
2727 case N_Function_Call
:
2728 case N_Procedure_Call_Statement
:
2730 if (type_annotate_only
)
2734 /* The GCC node corresponding to the GNAT subprogram name. This can
2735 either be a FUNCTION_DECL node if we are dealing with a standard
2736 subprogram call, or an indirect reference expression (an
2737 INDIRECT_REF node) pointing to a subprogram. */
2738 tree gnu_subprog_node
= gnat_to_gnu (Name (gnat_node
));
2739 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
2740 tree gnu_subprog_type
= TREE_TYPE (gnu_subprog_node
);
2741 tree gnu_subprog_addr
2742 = build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_subprog_node
);
2743 Entity_Id gnat_formal
;
2744 Node_Id gnat_actual
;
2745 tree gnu_actual_list
= NULL_TREE
;
2746 tree gnu_name_list
= NULL_TREE
;
2747 tree gnu_after_list
= NULL_TREE
;
2748 tree gnu_subprog_call
;
2750 switch (Nkind (Name (gnat_node
)))
2753 case N_Operator_Symbol
:
2754 case N_Expanded_Name
:
2755 case N_Attribute_Reference
:
2756 if (Is_Eliminated (Entity (Name (gnat_node
))))
2757 post_error_ne ("cannot call eliminated subprogram &!",
2758 gnat_node
, Entity (Name (gnat_node
)));
2761 if (TREE_CODE (gnu_subprog_type
) != FUNCTION_TYPE
)
2764 /* If we are calling a stubbed function, make this into a
2765 raise of Program_Error. Elaborate all our args first. */
2767 if (TREE_CODE (gnu_subprog_node
) == FUNCTION_DECL
2768 && DECL_STUBBED_P (gnu_subprog_node
))
2770 for (gnat_actual
= First_Actual (gnat_node
);
2771 Present (gnat_actual
);
2772 gnat_actual
= Next_Actual (gnat_actual
))
2773 expand_expr_stmt (gnat_to_gnu (gnat_actual
));
2775 if (Nkind (gnat_node
) == N_Function_Call
)
2777 gnu_result_type
= TREE_TYPE (gnu_subprog_type
);
2779 = build1 (NULL_EXPR
, gnu_result_type
,
2780 build_call_raise (PE_Stubbed_Subprogram_Called
));
2784 (build_call_raise (PE_Stubbed_Subprogram_Called
));
2788 /* The only way we can be making a call via an access type is
2789 if Name is an explicit dereference. In that case, get the
2790 list of formal args from the type the access type is pointing
2791 to. Otherwise, get the formals from entity being called. */
2792 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
2793 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
2794 else if (Nkind (Name (gnat_node
)) == N_Attribute_Reference
)
2795 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
2798 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
2800 /* Create the list of the actual parameters as GCC expects it, namely
2801 a chain of TREE_LIST nodes in which the TREE_VALUE field of each
2802 node is a parameter-expression and the TREE_PURPOSE field is
2803 null. Skip OUT parameters that are not passed by reference. */
2805 for (gnat_actual
= First_Actual (gnat_node
);
2806 Present (gnat_actual
);
2807 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
2808 gnat_actual
= Next_Actual (gnat_actual
))
2810 tree gnu_formal_type
= gnat_to_gnu_type (Etype (gnat_formal
));
2812 = ((Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2813 ? Expression (gnat_actual
) : gnat_actual
);
2814 tree gnu_name
= gnat_to_gnu (gnat_name
);
2815 tree gnu_name_type
= gnat_to_gnu_type (Etype (gnat_name
));
2818 /* If it's possible we may need to use this expression twice,
2819 make sure than any side-effects are handled via SAVE_EXPRs.
2820 Likewise if we need to force side-effects before the call.
2821 ??? This is more conservative than we need since we don't
2822 need to do this for pass-by-ref with no conversion.
2823 If we are passing a non-addressable Out or In Out parameter by
2824 reference, pass the address of a copy and set up to copy back
2825 out after the call. */
2827 if (Ekind (gnat_formal
) != E_In_Parameter
)
2829 gnu_name
= gnat_stabilize_reference (gnu_name
, 1);
2830 if (! addressable_p (gnu_name
)
2831 && present_gnu_tree (gnat_formal
)
2832 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
2833 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
))
2834 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
2836 tree gnu_copy
= gnu_name
;
2838 /* Remove any unpadding on the actual and make a copy.
2839 But if the actual is a left-justified modular type,
2840 first convert to it. */
2841 if (TREE_CODE (gnu_name
) == COMPONENT_REF
2842 && (TYPE_IS_PADDING_P
2843 (TREE_TYPE (TREE_OPERAND (gnu_name
, 0)))))
2844 gnu_name
= gnu_copy
= TREE_OPERAND (gnu_name
, 0);
2845 else if (TREE_CODE (gnu_name_type
) == RECORD_TYPE
2846 && (TYPE_LEFT_JUSTIFIED_MODULAR_P
2848 gnu_name
= convert (gnu_name_type
, gnu_name
);
2850 gnu_actual
= save_expr (gnu_name
);
2852 /* Set up to move the copy back to the original. */
2853 gnu_after_list
= tree_cons (gnu_copy
, gnu_actual
,
2856 gnu_name
= gnu_actual
;
2860 /* If this was a procedure call, we may not have removed any
2861 padding. So do it here for the part we will use as an
2863 gnu_actual
= gnu_name
;
2864 if (Ekind (gnat_formal
) != E_Out_Parameter
2865 && TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2866 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2867 gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual
)),
2870 if (Ekind (gnat_formal
) != E_Out_Parameter
2871 && Nkind (gnat_actual
) != N_Unchecked_Type_Conversion
2872 && Do_Range_Check (gnat_actual
))
2873 gnu_actual
= emit_range_check (gnu_actual
, Etype (gnat_formal
));
2875 /* Do any needed conversions. We need only check for
2876 unchecked conversion since normal conversions will be handled
2877 by just converting to the formal type. */
2878 if (Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
)
2881 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2884 /* One we've done the unchecked conversion, we still
2885 must ensure that the object is in range of the formal's
2887 if (Ekind (gnat_formal
) != E_Out_Parameter
2888 && Do_Range_Check (gnat_actual
))
2889 gnu_actual
= emit_range_check (gnu_actual
,
2890 Etype (gnat_formal
));
2893 /* We may have suppressed a conversion to the Etype of the
2894 actual since the parent is a procedure call. So add the
2896 gnu_actual
= convert (gnat_to_gnu_type (Etype (gnat_actual
)),
2899 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2901 /* If we have not saved a GCC object for the formal, it means
2902 it is an OUT parameter not passed by reference. Otherwise,
2903 look at the PARM_DECL to see if it is passed by reference. */
2904 if (present_gnu_tree (gnat_formal
)
2905 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2906 && DECL_BY_REF_P (get_gnu_tree (gnat_formal
)))
2908 if (Ekind (gnat_formal
) != E_In_Parameter
)
2910 gnu_actual
= gnu_name
;
2912 /* If we have a padded type, be sure we've removed the
2914 if (TREE_CODE (TREE_TYPE (gnu_actual
)) == RECORD_TYPE
2915 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual
)))
2917 = convert (get_unpadded_type (Etype (gnat_actual
)),
2921 /* The symmetry of the paths to the type of an entity is
2922 broken here since arguments don't know that they will
2923 be passed by ref. */
2924 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2925 gnu_actual
= build_unary_op (ADDR_EXPR
, gnu_formal_type
,
2928 else if (present_gnu_tree (gnat_formal
)
2929 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2930 && DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal
)))
2932 gnu_formal_type
= TREE_TYPE (get_gnu_tree (gnat_formal
));
2933 gnu_actual
= maybe_implicit_deref (gnu_actual
);
2934 gnu_actual
= maybe_unconstrained_array (gnu_actual
);
2936 if (TREE_CODE (gnu_formal_type
) == RECORD_TYPE
2937 && TYPE_IS_PADDING_P (gnu_formal_type
))
2940 = TREE_TYPE (TYPE_FIELDS (gnu_formal_type
));
2941 gnu_actual
= convert (gnu_formal_type
, gnu_actual
);
2944 /* Take the address of the object and convert to the
2945 proper pointer type. We'd like to actually compute
2946 the address of the beginning of the array using
2947 an ADDR_EXPR of an ARRAY_REF, but there's a possibility
2948 that the ARRAY_REF might return a constant and we'd
2949 be getting the wrong address. Neither approach is
2950 exactly correct, but this is the most likely to work
2952 gnu_actual
= convert (gnu_formal_type
,
2953 build_unary_op (ADDR_EXPR
, NULL_TREE
,
2956 else if (present_gnu_tree (gnat_formal
)
2957 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
2958 && DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
)))
2960 /* If arg is 'Null_Parameter, pass zero descriptor. */
2961 if ((TREE_CODE (gnu_actual
) == INDIRECT_REF
2962 || TREE_CODE (gnu_actual
) == UNCONSTRAINED_ARRAY_REF
)
2963 && TREE_PRIVATE (gnu_actual
))
2965 = convert (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
2969 = build_unary_op (ADDR_EXPR
, NULL_TREE
,
2970 fill_vms_descriptor (gnu_actual
,
2975 tree gnu_actual_size
= TYPE_SIZE (TREE_TYPE (gnu_actual
));
2977 if (Ekind (gnat_formal
) != E_In_Parameter
)
2979 = chainon (gnu_name_list
,
2980 build_tree_list (NULL_TREE
, gnu_name
));
2982 if (! present_gnu_tree (gnat_formal
)
2983 || TREE_CODE (get_gnu_tree (gnat_formal
)) != PARM_DECL
)
2986 /* If this is 'Null_Parameter, pass a zero even though we are
2987 dereferencing it. */
2988 else if (TREE_CODE (gnu_actual
) == INDIRECT_REF
2989 && TREE_PRIVATE (gnu_actual
)
2990 && host_integerp (gnu_actual_size
, 1)
2991 && 0 >= compare_tree_int (gnu_actual_size
,
2995 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
)),
2996 convert (gnat_type_for_size
2997 (tree_low_cst (gnu_actual_size
, 1), 1),
2998 integer_zero_node
));
3001 = convert (TYPE_MAIN_VARIANT
3002 (DECL_ARG_TYPE (get_gnu_tree (gnat_formal
))),
3007 = chainon (gnu_actual_list
,
3008 build_tree_list (NULL_TREE
, gnu_actual
));
3011 gnu_subprog_call
= build (CALL_EXPR
, TREE_TYPE (gnu_subprog_type
),
3012 gnu_subprog_addr
, gnu_actual_list
,
3014 TREE_SIDE_EFFECTS (gnu_subprog_call
) = 1;
3016 /* If it is a function call, the result is the call expression. */
3017 if (Nkind (gnat_node
) == N_Function_Call
)
3019 gnu_result
= gnu_subprog_call
;
3021 /* If the function returns an unconstrained array or by reference,
3022 we have to de-dereference the pointer. */
3023 if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type
)
3024 || TYPE_RETURNS_BY_REF_P (gnu_subprog_type
))
3025 gnu_result
= build_unary_op (INDIRECT_REF
, NULL_TREE
,
3028 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3031 /* If this is the case where the GNAT tree contains a procedure call
3032 but the Ada procedure has copy in copy out parameters, the special
3033 parameter passing mechanism must be used. */
3034 else if (TYPE_CI_CO_LIST (gnu_subprog_type
) != NULL_TREE
)
3036 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy
3037 in copy out parameters. */
3038 tree scalar_return_list
= TYPE_CI_CO_LIST (gnu_subprog_type
);
3039 int length
= list_length (scalar_return_list
);
3045 gnu_subprog_call
= protect_multiple_eval (gnu_subprog_call
);
3047 /* If any of the names had side-effects, ensure they are
3048 all evaluated before the call. */
3049 for (gnu_name
= gnu_name_list
; gnu_name
;
3050 gnu_name
= TREE_CHAIN (gnu_name
))
3051 if (TREE_SIDE_EFFECTS (TREE_VALUE (gnu_name
)))
3053 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_subprog_call
),
3054 TREE_VALUE (gnu_name
), gnu_subprog_call
);
3057 if (Nkind (Name (gnat_node
)) == N_Explicit_Dereference
)
3058 gnat_formal
= First_Formal (Etype (Name (gnat_node
)));
3060 gnat_formal
= First_Formal (Entity (Name (gnat_node
)));
3062 for (gnat_actual
= First_Actual (gnat_node
);
3063 Present (gnat_actual
);
3064 gnat_formal
= Next_Formal_With_Extras (gnat_formal
),
3065 gnat_actual
= Next_Actual (gnat_actual
))
3066 /* If we are dealing with a copy in copy out parameter, we must
3067 retrieve its value from the record returned in the function
3069 if (! (present_gnu_tree (gnat_formal
)
3070 && TREE_CODE (get_gnu_tree (gnat_formal
)) == PARM_DECL
3071 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal
))
3072 || (DECL_BY_COMPONENT_PTR_P
3073 (get_gnu_tree (gnat_formal
)))
3074 || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal
))))
3075 && Ekind (gnat_formal
) != E_In_Parameter
)
3077 /* Get the value to assign to this OUT or IN OUT
3078 parameter. It is either the result of the function if
3079 there is only a single such parameter or the appropriate
3080 field from the record returned. */
3082 = length
== 1 ? gnu_subprog_call
3083 : build_component_ref
3084 (gnu_subprog_call
, NULL_TREE
,
3085 TREE_PURPOSE (scalar_return_list
));
3086 int unchecked_conversion
3087 = Nkind (gnat_actual
) == N_Unchecked_Type_Conversion
;
3088 /* If the actual is a conversion, get the inner expression,
3089 which will be the real destination, and convert the
3090 result to the type of the actual parameter. */
3092 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list
));
3094 /* If the result is a padded type, remove the padding. */
3095 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3096 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3098 = convert (TREE_TYPE (TYPE_FIELDS
3099 (TREE_TYPE (gnu_result
))),
3102 /* If the result is a type conversion, do it. */
3103 if (Nkind (gnat_actual
) == N_Type_Conversion
)
3105 = convert_with_check
3106 (Etype (Expression (gnat_actual
)), gnu_result
,
3107 Do_Overflow_Check (gnat_actual
),
3108 Do_Range_Check (Expression (gnat_actual
)),
3109 Float_Truncate (gnat_actual
));
3111 else if (unchecked_conversion
)
3113 = unchecked_convert (TREE_TYPE (gnu_actual
), gnu_result
);
3116 if (Do_Range_Check (gnat_actual
))
3117 gnu_result
= emit_range_check (gnu_result
,
3118 Etype (gnat_actual
));
3120 if (! (! TREE_CONSTANT (TYPE_SIZE
3121 (TREE_TYPE (gnu_actual
)))
3122 && TREE_CONSTANT (TYPE_SIZE
3123 (TREE_TYPE (gnu_result
)))))
3124 gnu_result
= convert (TREE_TYPE (gnu_actual
),
3128 set_lineno (gnat_node
, 1);
3129 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3130 gnu_actual
, gnu_result
));
3131 scalar_return_list
= TREE_CHAIN (scalar_return_list
);
3132 gnu_name_list
= TREE_CHAIN (gnu_name_list
);
3137 set_lineno (gnat_node
, 1);
3138 expand_expr_stmt (gnu_subprog_call
);
3141 /* Handle anything we need to assign back. */
3142 for (gnu_expr
= gnu_after_list
;
3144 gnu_expr
= TREE_CHAIN (gnu_expr
))
3145 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3146 TREE_PURPOSE (gnu_expr
),
3147 TREE_VALUE (gnu_expr
)));
3151 /*************************/
3152 /* Chapter 7: Packages: */
3153 /*************************/
3155 case N_Package_Declaration
:
3156 gnat_to_code (Specification (gnat_node
));
3159 case N_Package_Specification
:
3161 process_decls (Visible_Declarations (gnat_node
),
3162 Private_Declarations (gnat_node
), Empty
, 1, 1);
3165 case N_Package_Body
:
3167 /* If this is the body of a generic package - do nothing */
3168 if (Ekind (Corresponding_Spec (gnat_node
)) == E_Generic_Package
)
3171 process_decls (Declarations (gnat_node
), Empty
, Empty
, 1, 1);
3173 if (Present (Handled_Statement_Sequence (gnat_node
)))
3175 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
3176 gnat_to_code (Handled_Statement_Sequence (gnat_node
));
3177 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
3181 /*********************************/
3182 /* Chapter 8: Visibility Rules: */
3183 /*********************************/
3185 case N_Use_Package_Clause
:
3186 case N_Use_Type_Clause
:
3187 /* Nothing to do here - but these may appear in list of declarations */
3190 /***********************/
3191 /* Chapter 9: Tasks: */
3192 /***********************/
3194 case N_Protected_Type_Declaration
:
3197 case N_Single_Task_Declaration
:
3198 gnat_to_gnu_entity (Defining_Entity (gnat_node
), NULL_TREE
, 1);
3201 /***********************************************************/
3202 /* Chapter 10: Program Structure and Compilation Issues: */
3203 /***********************************************************/
3205 case N_Compilation_Unit
:
3207 /* For a body, first process the spec if there is one. */
3208 if (Nkind (Unit (gnat_node
)) == N_Package_Body
3209 || (Nkind (Unit (gnat_node
)) == N_Subprogram_Body
3210 && ! Acts_As_Spec (gnat_node
)))
3211 gnat_to_code (Library_Unit (gnat_node
));
3213 process_inlined_subprograms (gnat_node
);
3215 if (type_annotate_only
&& gnat_node
== Cunit (Main_Unit
))
3217 elaborate_all_entities (gnat_node
);
3219 if (Nkind (Unit (gnat_node
)) == N_Subprogram_Declaration
3220 || Nkind (Unit (gnat_node
)) == N_Generic_Package_Declaration
3221 || Nkind (Unit (gnat_node
)) == N_Generic_Subprogram_Declaration
)
3225 process_decls (Declarations (Aux_Decls_Node (gnat_node
)),
3226 Empty
, Empty
, 1, 1);
3228 gnat_to_code (Unit (gnat_node
));
3230 /* Process any pragmas following the unit. */
3231 if (Present (Pragmas_After (Aux_Decls_Node (gnat_node
))))
3232 for (gnat_temp
= First (Pragmas_After (Aux_Decls_Node (gnat_node
)));
3233 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3234 gnat_to_code (gnat_temp
);
3236 /* Put all the Actions into the elaboration routine if we already had
3237 elaborations. This will happen anyway if they are statements, but we
3238 want to force declarations there too due to order-of-elaboration
3239 issues. Most should have Is_Statically_Allocated set. If we
3240 have had no elaborations, we have no order-of-elaboration issue and
3241 don't want to create elaborations here. */
3242 if (Is_Non_Empty_List (Actions (Aux_Decls_Node (gnat_node
))))
3243 for (gnat_temp
= First (Actions (Aux_Decls_Node (gnat_node
)));
3244 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3246 if (pending_elaborations_p ())
3247 add_pending_elaborations (NULL_TREE
,
3248 make_transform_expr (gnat_temp
));
3250 gnat_to_code (gnat_temp
);
3253 /* Generate elaboration code for this unit, if necessary, and
3254 say whether we did or not. */
3255 Set_Has_No_Elaboration_Code
3258 (Defining_Entity (Unit (gnat_node
)),
3259 Nkind (Unit (gnat_node
)) == N_Package_Body
3260 || Nkind (Unit (gnat_node
)) == N_Subprogram_Body
,
3261 get_pending_elaborations ()));
3265 case N_Subprogram_Body_Stub
:
3266 case N_Package_Body_Stub
:
3267 case N_Protected_Body_Stub
:
3268 case N_Task_Body_Stub
:
3269 /* Simply process whatever unit is being inserted. */
3270 gnat_to_code (Unit (Library_Unit (gnat_node
)));
3274 gnat_to_code (Proper_Body (gnat_node
));
3277 /***************************/
3278 /* Chapter 11: Exceptions: */
3279 /***************************/
3281 case N_Handled_Sequence_Of_Statements
:
3283 /* The GCC exception handling mechanism can handle both ZCX and SJLJ
3284 schemes and we have our own SJLJ mechanism. To call the GCC
3285 mechanism, we first call expand_eh_region_start if there is at least
3286 one handler associated with the region. We then generate code for
3287 the region and call expand_start_all_catch to announce that the
3288 associated handlers are going to be generated.
3290 For each handler we call expand_start_catch, generate code for the
3291 handler, and then call expand_end_catch.
3293 After all the handlers, we call expand_end_all_catch.
3295 Here we deal with the region level calls and the
3296 N_Exception_Handler branch deals with the handler level calls
3297 (start_catch/end_catch).
3299 ??? The region level calls down there have been specifically put in
3300 place for a ZCX context and currently the order in which things are
3301 emitted (region/handlers) is different from the SJLJ case. Instead of
3302 putting other calls with different conditions at other places for the
3303 SJLJ case, it seems cleaner to reorder things for the SJLJ case and
3304 generalize the condition to make it not ZCX specific. */
3306 /* Tell the back-end we are starting a new exception region if
3308 if (! type_annotate_only
3309 && Exception_Mechanism
== GCC_ZCX
3310 && Present (Exception_Handlers (gnat_node
)))
3311 expand_eh_region_start ();
3313 /* If there are exception handlers, start a new binding level that
3314 we can exit (since each exception handler will do so). Then
3315 declare a variable to save the old __gnat_jmpbuf value and a
3316 variable for our jmpbuf. Call setjmp and handle each of the
3317 possible exceptions if it returns one. */
3319 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3321 tree gnu_jmpsave_decl
= 0;
3322 tree gnu_jmpbuf_decl
= 0;
3323 tree gnu_cleanup_call
= 0;
3324 tree gnu_cleanup_decl
;
3327 expand_start_bindings (1);
3329 if (Exception_Mechanism
== Setjmp_Longjmp
)
3332 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE
,
3334 build_call_0_expr (get_jmpbuf_decl
),
3337 gnu_jmpbuf_decl
= create_var_decl (get_identifier ("JMP_BUF"),
3338 NULL_TREE
, jmpbuf_type
,
3339 NULL_TREE
, 0, 0, 0, 0,
3341 TREE_VALUE (gnu_block_stack
) = gnu_jmpbuf_decl
;
3344 /* See if we are to call a function when exiting this block. */
3345 if (Present (At_End_Proc (gnat_node
)))
3348 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3351 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3352 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3355 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3358 if (Exception_Mechanism
== Setjmp_Longjmp
)
3360 /* When we exit this block, restore the saved value. */
3361 expand_decl_cleanup (gnu_jmpsave_decl
,
3362 build_call_1_expr (set_jmpbuf_decl
,
3365 /* Call setjmp and handle exceptions if it returns one. */
3366 set_lineno (gnat_node
, 1);
3368 (build_call_1_expr (setjmp_decl
,
3369 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3373 /* Restore our incoming longjmp value before we do anything. */
3374 expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl
,
3378 expand_start_bindings (0);
3380 gnu_except_ptr_stack
3381 = tree_cons (NULL_TREE
,
3383 (get_identifier ("EXCEPT_PTR"), NULL_TREE
,
3384 build_pointer_type (except_type_node
),
3385 build_call_0_expr (get_excptr_decl
),
3387 gnu_except_ptr_stack
);
3389 /* Generate code for each exception handler. The code at
3390 N_Exception_Handler below does the real work. Note that
3391 we ignore the dummy exception handler for the identifier
3392 case, this is used only by the front end */
3393 if (Present (Exception_Handlers (gnat_node
)))
3395 = First_Non_Pragma (Exception_Handlers (gnat_node
));
3396 Present (gnat_temp
);
3397 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3398 gnat_to_code (gnat_temp
);
3400 /* If none of the exception handlers did anything, re-raise
3401 but do not defer abortion. */
3402 set_lineno (gnat_node
, 1);
3404 (build_call_1_expr (raise_nodefer_decl
,
3405 TREE_VALUE (gnu_except_ptr_stack
)));
3407 gnu_except_ptr_stack
= TREE_CHAIN (gnu_except_ptr_stack
);
3408 expand_end_bindings (getdecls (), kept_level_p (), 0);
3409 poplevel (kept_level_p (), 1, 0);
3411 /* End the "if" on setjmp. Note that we have arranged things so
3412 control never returns here. */
3415 /* This is now immediately before the body proper. Set
3416 our jmp_buf as the current buffer. */
3418 (build_call_1_expr (set_jmpbuf_decl
,
3419 build_unary_op (ADDR_EXPR
, NULL_TREE
,
3424 /* If there are no exception handlers, we must not have an at end
3425 cleanup identifier, since the cleanup identifier should always
3426 generate a corresponding exception handler, except in the case
3427 of the No_Exception_Handlers restriction, where the front-end
3428 does not generate exception handlers. */
3429 else if (! type_annotate_only
&& Present (At_End_Proc (gnat_node
)))
3431 if (No_Exception_Handlers_Set ())
3433 tree gnu_cleanup_call
= 0;
3434 tree gnu_cleanup_decl
;
3437 = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node
)));
3440 = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE
,
3441 integer_type_node
, NULL_TREE
, 0, 0, 0, 0,
3444 expand_decl_cleanup (gnu_cleanup_decl
, gnu_cleanup_call
);
3450 /* Generate code and declarations for the prefix of this block,
3452 if (Present (First_Real_Statement (gnat_node
)))
3453 process_decls (Statements (gnat_node
), Empty
,
3454 First_Real_Statement (gnat_node
), 1, 1);
3456 /* Generate code for each statement in the block. */
3457 for (gnat_temp
= (Present (First_Real_Statement (gnat_node
))
3458 ? First_Real_Statement (gnat_node
)
3459 : First (Statements (gnat_node
)));
3460 Present (gnat_temp
); gnat_temp
= Next (gnat_temp
))
3461 gnat_to_code (gnat_temp
);
3463 /* Tell the back-end we are ending the new exception region and
3464 starting the associated handlers. */
3465 if (! type_annotate_only
3466 && Exception_Mechanism
== GCC_ZCX
3467 && Present (Exception_Handlers (gnat_node
)))
3468 expand_start_all_catch ();
3470 /* For zero-cost exceptions, exit the block and then compile
3472 if (! type_annotate_only
3473 && Exception_Mechanism
== GCC_ZCX
3474 && Present (Exception_Handlers (gnat_node
)))
3476 expand_exit_something ();
3477 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3478 Present (gnat_temp
);
3479 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3480 gnat_to_code (gnat_temp
);
3483 /* We don't support Front_End_ZCX in GNAT 5.0, but we don't want to
3484 crash if -gnatdX is specified. */
3485 if (! type_annotate_only
3486 && Exception_Mechanism
== Front_End_ZCX
3487 && Present (Exception_Handlers (gnat_node
)))
3489 for (gnat_temp
= First_Non_Pragma (Exception_Handlers (gnat_node
));
3490 Present (gnat_temp
);
3491 gnat_temp
= Next_Non_Pragma (gnat_temp
))
3492 gnat_to_code (gnat_temp
);
3495 /* Tell the backend when we are done with the handlers. */
3496 if (! type_annotate_only
3497 && Exception_Mechanism
== GCC_ZCX
3498 && Present (Exception_Handlers (gnat_node
)))
3499 expand_end_all_catch ();
3501 /* If we have handlers, close the block we made. */
3502 if (! type_annotate_only
&& Present (Exception_Handlers (gnat_node
)))
3504 expand_end_bindings (getdecls (), kept_level_p (), 0);
3505 poplevel (kept_level_p (), 1, 0);
3510 case N_Exception_Handler
:
3511 if (Exception_Mechanism
== Setjmp_Longjmp
)
3513 /* Unless this is "Others" or the special "Non-Ada" exception
3514 for Ada, make an "if" statement to select the proper
3515 exceptions. For "Others", exclude exceptions where
3516 Handled_By_Others is nonzero unless the All_Others flag is set.
3517 For "Non-ada", accept an exception if "Lang" is 'V'. */
3518 tree gnu_choice
= integer_zero_node
;
3520 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3521 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3525 if (Nkind (gnat_temp
) == N_Others_Choice
)
3527 if (All_Others (gnat_temp
))
3528 this_choice
= integer_one_node
;
3532 (EQ_EXPR
, integer_type_node
,
3537 (INDIRECT_REF
, NULL_TREE
,
3538 TREE_VALUE (gnu_except_ptr_stack
)),
3539 get_identifier ("not_handled_by_others"), NULL_TREE
)),
3543 else if (Nkind (gnat_temp
) == N_Identifier
3544 || Nkind (gnat_temp
) == N_Expanded_Name
)
3546 /* ??? Note that we have to use gnat_to_gnu_entity here
3547 since the type of the exception will be wrong in the
3548 VMS case and that's exactly what this test is for. */
3550 = gnat_to_gnu_entity (Entity (gnat_temp
), NULL_TREE
, 0);
3552 /* If this was a VMS exception, check import_code
3553 against the value of the exception. */
3554 if (TREE_CODE (TREE_TYPE (gnu_expr
)) == INTEGER_TYPE
)
3557 (EQ_EXPR
, integer_type_node
,
3560 (INDIRECT_REF
, NULL_TREE
,
3561 TREE_VALUE (gnu_except_ptr_stack
)),
3562 get_identifier ("import_code"), NULL_TREE
),
3567 (EQ_EXPR
, integer_type_node
,
3568 TREE_VALUE (gnu_except_ptr_stack
),
3570 (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack
)),
3571 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
)));
3573 /* If this is the distinguished exception "Non_Ada_Error"
3574 (and we are in VMS mode), also allow a non-Ada
3575 exception (a VMS condition) to match. */
3576 if (Is_Non_Ada_Error (Entity (gnat_temp
)))
3579 = build_component_ref
3581 (INDIRECT_REF
, NULL_TREE
,
3582 TREE_VALUE (gnu_except_ptr_stack
)),
3583 get_identifier ("lang"), NULL_TREE
);
3587 (TRUTH_ORIF_EXPR
, integer_type_node
,
3589 (EQ_EXPR
, integer_type_node
, gnu_comp
,
3590 convert (TREE_TYPE (gnu_comp
),
3591 build_int_2 ('V', 0))),
3598 gnu_choice
= build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
3599 gnu_choice
, this_choice
);
3602 set_lineno (gnat_node
, 1);
3604 expand_start_cond (gnu_choice
, 0);
3607 /* Tell the back end that we start an exception handler if necessary. */
3608 if (Exception_Mechanism
== GCC_ZCX
)
3610 /* We build a TREE_LIST of nodes representing what exception
3611 types this handler is able to catch, with special cases
3612 for others and all others cases.
3614 Each exception type is actually identified by a pointer to the
3615 exception id, with special value zero for "others" and one for
3616 "all others". Beware that these special values are known and used
3617 by the personality routine to identify the corresponding specific
3620 ??? For initial time frame reasons, the others and all_others
3621 cases have been handled using specific type trees, but this
3622 somehow hides information to the back-end, which expects NULL to
3623 be passed for catch all and end_cleanup to be used for cleanups.
3625 Care should be taken to ensure that the control flow impact of
3626 such clauses is rendered in some way. lang_eh_type_covers is
3627 doing the trick currently.
3629 ??? Should investigate the possible usage of the end_cleanup
3630 interface in this context. */
3632 tree gnu_expr
, gnu_etype
;
3633 tree gnu_etypes_list
= NULL_TREE
;
3635 for (gnat_temp
= First (Exception_Choices (gnat_node
));
3636 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3638 if (Nkind (gnat_temp
) == N_Others_Choice
)
3640 = All_Others (gnat_temp
) ? integer_one_node
3641 : integer_zero_node
;
3642 else if (Nkind (gnat_temp
) == N_Identifier
3643 || Nkind (gnat_temp
) == N_Expanded_Name
)
3645 gnu_expr
= gnat_to_gnu_entity (Entity (gnat_temp
),
3647 gnu_etype
= build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_expr
);
3653 = tree_cons (NULL_TREE
, gnu_etype
, gnu_etypes_list
);
3655 /* The GCC interface expects NULL to be passed for catch all
3656 handlers, so the approach below is quite tempting :
3658 if (gnu_etype == integer_zero_node)
3659 gnu_etypes_list = NULL;
3661 It would not work, however, because GCC's notion
3662 of "catch all" is stronger than our notion of "others".
3664 Until we correctly use the cleanup interface as well, the
3665 two lines above will prevent the "all others" handlers from
3666 beeing seen, because nothing can be caught beyond a catch
3667 all from GCC's point of view. */
3670 expand_start_catch (gnu_etypes_list
);
3673 for (gnat_temp
= First (Statements (gnat_node
));
3674 gnat_temp
; gnat_temp
= Next (gnat_temp
))
3675 gnat_to_code (gnat_temp
);
3677 /* At the end of the handler, exit the block. We made this block
3678 in N_Handled_Sequence_Of_Statements. */
3679 expand_exit_something ();
3681 /* Tell the back end that we're done with the current handler. */
3682 if (Exception_Mechanism
== GCC_ZCX
)
3683 expand_end_catch ();
3684 else if (Exception_Mechanism
== Setjmp_Longjmp
)
3689 /*******************************/
3690 /* Chapter 12: Generic Units: */
3691 /*******************************/
3693 case N_Generic_Function_Renaming_Declaration
:
3694 case N_Generic_Package_Renaming_Declaration
:
3695 case N_Generic_Procedure_Renaming_Declaration
:
3696 case N_Generic_Package_Declaration
:
3697 case N_Generic_Subprogram_Declaration
:
3698 case N_Package_Instantiation
:
3699 case N_Procedure_Instantiation
:
3700 case N_Function_Instantiation
:
3701 /* These nodes can appear on a declaration list but there is nothing to
3702 to be done with them. */
3705 /***************************************************/
3706 /* Chapter 13: Representation Clauses and */
3707 /* Implementation-Dependent Features: */
3708 /***************************************************/
3710 case N_Attribute_Definition_Clause
:
3712 /* The only one we need deal with is for 'Address. For the others, SEM
3713 puts the information elsewhere. We need only deal with 'Address
3714 if the object has a Freeze_Node (which it never will currently). */
3715 if (Get_Attribute_Id (Chars (gnat_node
)) != Attr_Address
3716 || No (Freeze_Node (Entity (Name (gnat_node
)))))
3719 /* Get the value to use as the address and save it as the
3720 equivalent for GNAT_TEMP. When the object is frozen,
3721 gnat_to_gnu_entity will do the right thing. */
3722 gnu_expr
= gnat_to_gnu (Expression (gnat_node
));
3723 save_gnu_tree (Entity (Name (gnat_node
)), gnu_expr
, 1);
3726 case N_Enumeration_Representation_Clause
:
3727 case N_Record_Representation_Clause
:
3729 /* We do nothing with these. SEM puts the information elsewhere. */
3732 case N_Code_Statement
:
3733 if (! type_annotate_only
)
3735 tree gnu_template
= gnat_to_gnu (Asm_Template (gnat_node
));
3736 tree gnu_input_list
= 0, gnu_output_list
= 0, gnu_orig_out_list
= 0;
3737 tree gnu_clobber_list
= 0;
3740 /* First process inputs, then outputs, then clobbers. */
3741 Setup_Asm_Inputs (gnat_node
);
3742 while (Present (gnat_temp
= Asm_Input_Value ()))
3744 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3745 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3746 (Asm_Input_Constraint ()));
3749 = tree_cons (gnu_constr
, gnu_value
, gnu_input_list
);
3753 Setup_Asm_Outputs (gnat_node
);
3754 while (Present (gnat_temp
= Asm_Output_Variable ()))
3756 tree gnu_value
= gnat_to_gnu (gnat_temp
);
3757 tree gnu_constr
= build_tree_list (NULL_TREE
, gnat_to_gnu
3758 (Asm_Output_Constraint ()));
3761 = tree_cons (gnu_constr
, gnu_value
, gnu_orig_out_list
);
3763 = tree_cons (gnu_constr
, gnu_value
, gnu_output_list
);
3767 Clobber_Setup (gnat_node
);
3768 while ((clobber
= Clobber_Get_Next ()) != 0)
3770 = tree_cons (NULL_TREE
,
3771 build_string (strlen (clobber
) + 1, clobber
),
3774 gnu_input_list
= nreverse (gnu_input_list
);
3775 gnu_output_list
= nreverse (gnu_output_list
);
3776 gnu_orig_out_list
= nreverse (gnu_orig_out_list
);
3777 expand_asm_operands (gnu_template
, gnu_output_list
, gnu_input_list
,
3778 gnu_clobber_list
, Is_Asm_Volatile (gnat_node
),
3779 input_filename
, lineno
);
3781 /* Copy all the intermediate outputs into the specified outputs. */
3782 for (; gnu_output_list
;
3783 (gnu_output_list
= TREE_CHAIN (gnu_output_list
),
3784 gnu_orig_out_list
= TREE_CHAIN (gnu_orig_out_list
)))
3785 if (TREE_VALUE (gnu_orig_out_list
) != TREE_VALUE (gnu_output_list
))
3788 (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
3789 TREE_VALUE (gnu_orig_out_list
),
3790 TREE_VALUE (gnu_output_list
)));
3796 /***************************************************/
3798 /***************************************************/
3800 case N_Freeze_Entity
:
3801 process_freeze_entity (gnat_node
);
3802 process_decls (Actions (gnat_node
), Empty
, Empty
, 1, 1);
3805 case N_Itype_Reference
:
3806 if (! present_gnu_tree (Itype (gnat_node
)))
3807 process_type (Itype (gnat_node
));
3810 case N_Free_Statement
:
3811 if (! type_annotate_only
)
3813 tree gnu_ptr
= gnat_to_gnu (Expression (gnat_node
));
3818 /* If this is an unconstrained array, we know the object must
3819 have been allocated with the template in front of the object.
3820 So pass the template address, but get the total size. Do this
3821 by converting to a thin pointer. */
3822 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr
)))
3824 = convert (build_pointer_type
3825 (TYPE_OBJECT_RECORD_TYPE
3826 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr
)))),
3829 gnu_obj_type
= TREE_TYPE (TREE_TYPE (gnu_ptr
));
3830 gnu_obj_size
= TYPE_SIZE_UNIT (gnu_obj_type
);
3831 align
= TYPE_ALIGN (gnu_obj_type
);
3833 if (TREE_CODE (gnu_obj_type
) == RECORD_TYPE
3834 && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type
))
3836 tree gnu_char_ptr_type
= build_pointer_type (char_type_node
);
3837 tree gnu_pos
= byte_position (TYPE_FIELDS (gnu_obj_type
));
3838 tree gnu_byte_offset
3839 = convert (gnu_char_ptr_type
,
3840 size_diffop (size_zero_node
, gnu_pos
));
3842 gnu_ptr
= convert (gnu_char_ptr_type
, gnu_ptr
);
3843 gnu_ptr
= build_binary_op (MINUS_EXPR
, gnu_char_ptr_type
,
3844 gnu_ptr
, gnu_byte_offset
);
3847 set_lineno (gnat_node
, 1);
3849 (build_call_alloc_dealloc (gnu_ptr
, gnu_obj_size
, align
,
3850 Procedure_To_Call (gnat_node
),
3851 Storage_Pool (gnat_node
)));
3855 case N_Raise_Constraint_Error
:
3856 case N_Raise_Program_Error
:
3857 case N_Raise_Storage_Error
:
3859 if (type_annotate_only
)
3862 gnu_result_type
= get_unpadded_type (Etype (gnat_node
));
3863 gnu_result
= build_call_raise (UI_To_Int (Reason (gnat_node
)));
3865 /* If the type is VOID, this is a statement, so we need to
3866 generate the code for the call. Handle a Condition, if there
3868 if (TREE_CODE (gnu_result_type
) == VOID_TYPE
)
3870 set_lineno (gnat_node
, 1);
3872 if (Present (Condition (gnat_node
)))
3873 expand_start_cond (gnat_to_gnu (Condition (gnat_node
)), 0);
3875 expand_expr_stmt (gnu_result
);
3876 if (Present (Condition (gnat_node
)))
3878 gnu_result
= error_mark_node
;
3881 gnu_result
= build1 (NULL_EXPR
, gnu_result_type
, gnu_result
);
3884 /* Nothing to do, since front end does all validation using the
3885 values that Gigi back-annotates. */
3886 case N_Validate_Unchecked_Conversion
:
3889 case N_Raise_Statement
:
3890 case N_Function_Specification
:
3891 case N_Procedure_Specification
:
3893 case N_Component_Association
:
3896 if (! type_annotate_only
)
3900 /* If the result is a constant that overflows, raise constraint error. */
3901 if (TREE_CODE (gnu_result
) == INTEGER_CST
3902 && TREE_CONSTANT_OVERFLOW (gnu_result
))
3904 post_error ("Constraint_Error will be raised at run-time?", gnat_node
);
3907 = build1 (NULL_EXPR
, gnu_result_type
,
3908 build_call_raise (CE_Overflow_Check_Failed
));
3911 /* If our result has side-effects and is of an unconstrained type,
3912 make a SAVE_EXPR so that we can be sure it will only be referenced
3913 once. Note we must do this before any conversions. */
3914 if (TREE_SIDE_EFFECTS (gnu_result
)
3915 && (TREE_CODE (gnu_result_type
) == UNCONSTRAINED_ARRAY_TYPE
3916 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3917 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))))
3918 gnu_result
= gnat_stabilize_reference (gnu_result
, 0);
3920 /* Now convert the result to the proper type. If the type is void or if
3921 we have no result, return error_mark_node to show we have no result.
3922 If the type of the result is correct or if we have a label (which doesn't
3923 have any well-defined type), return our result. Also don't do the
3924 conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size
3925 since those are the cases where the front end may have the type wrong due
3926 to "instantiating" the unconstrained record with discriminant values
3927 or if this is a FIELD_DECL. If this is the Name of an assignment
3928 statement or a parameter of a procedure call, return what we have since
3929 the RHS has to be converted to our type there in that case, unless
3930 GNU_RESULT_TYPE has a simpler size. Similarly, if the two types are
3931 record types with the same name, the expression type has integral mode,
3932 and GNU_RESULT_TYPE BLKmode, don't convert. This will be the case when
3933 we are converting from a packable type to its actual type and we need
3934 those conversions to be NOPs in order for assignments into these types to
3935 work properly if the inner object is a bitfield and hence can't have
3936 its address taken. Finally, don't convert integral types that are the
3937 operand of an unchecked conversion since we need to ignore those
3938 conversions (for 'Valid). Otherwise, convert the result to the proper
3941 if (Present (Parent (gnat_node
))
3942 && ((Nkind (Parent (gnat_node
)) == N_Assignment_Statement
3943 && Name (Parent (gnat_node
)) == gnat_node
)
3944 || (Nkind (Parent (gnat_node
)) == N_Procedure_Call_Statement
3945 && Name (Parent (gnat_node
)) != gnat_node
)
3946 || (Nkind (Parent (gnat_node
)) == N_Unchecked_Type_Conversion
3947 && ! AGGREGATE_TYPE_P (gnu_result_type
)
3948 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3949 || Nkind (Parent (gnat_node
)) == N_Parameter_Association
)
3950 && ! (TYPE_SIZE (gnu_result_type
) != 0
3951 && TYPE_SIZE (TREE_TYPE (gnu_result
)) != 0
3952 && (AGGREGATE_TYPE_P (gnu_result_type
)
3953 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result
)))
3954 && ((TREE_CODE (TYPE_SIZE (gnu_result_type
)) == INTEGER_CST
3955 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3957 || (TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3958 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result
)))
3960 && ! (contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3961 && (contains_placeholder_p
3962 (TYPE_SIZE (TREE_TYPE (gnu_result
))))))
3963 && ! (TREE_CODE (gnu_result_type
) == RECORD_TYPE
3964 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type
))))
3966 /* In this case remove padding only if the inner object is of
3967 self-referential size: in that case it must be an object of
3968 unconstrained type with a default discriminant. In other cases,
3969 we want to avoid copying too much data. */
3970 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3971 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
))
3972 && contains_placeholder_p (TYPE_SIZE
3973 (TREE_TYPE (TYPE_FIELDS
3974 (TREE_TYPE (gnu_result
))))))
3975 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
3979 else if (TREE_CODE (gnu_result
) == LABEL_DECL
3980 || TREE_CODE (gnu_result
) == FIELD_DECL
3981 || TREE_CODE (gnu_result
) == ERROR_MARK
3982 || (TYPE_SIZE (gnu_result_type
) != 0
3983 && TREE_CODE (TYPE_SIZE (gnu_result_type
)) != INTEGER_CST
3984 && TREE_CODE (gnu_result
) != INDIRECT_REF
3985 && contains_placeholder_p (TYPE_SIZE (gnu_result_type
)))
3986 || ((TYPE_NAME (gnu_result_type
)
3987 == TYPE_NAME (TREE_TYPE (gnu_result
)))
3988 && TREE_CODE (gnu_result_type
) == RECORD_TYPE
3989 && TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3990 && TYPE_MODE (gnu_result_type
) == BLKmode
3991 && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (gnu_result
)))
3994 /* Remove any padding record, but do nothing more in this case. */
3995 if (TREE_CODE (TREE_TYPE (gnu_result
)) == RECORD_TYPE
3996 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result
)))
3997 gnu_result
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result
))),
4001 else if (gnu_result
== error_mark_node
4002 || gnu_result_type
== void_type_node
)
4003 gnu_result
= error_mark_node
;
4004 else if (gnu_result_type
!= TREE_TYPE (gnu_result
))
4005 gnu_result
= convert (gnu_result_type
, gnu_result
);
4007 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */
4008 while ((TREE_CODE (gnu_result
) == NOP_EXPR
4009 || TREE_CODE (gnu_result
) == NON_LVALUE_EXPR
)
4010 && TREE_TYPE (TREE_OPERAND (gnu_result
, 0)) == TREE_TYPE (gnu_result
))
4011 gnu_result
= TREE_OPERAND (gnu_result
, 0);
4016 /* Force references to each of the entities in packages GNAT_NODE with's
4017 so that the debugging information for all of them are identical
4018 in all clients. Operate recursively on anything it with's, but check
4019 that we aren't elaborating something more than once. */
4021 /* The reason for this routine's existence is two-fold.
4022 First, with some debugging formats, notably MDEBUG on SGI
4023 IRIX, the linker will remove duplicate debugging information if two
4024 clients have identical debugguing information. With the normal scheme
4025 of elaboration, this does not usually occur, since entities in with'ed
4026 packages are elaborated on demand, and if clients have different usage
4027 patterns, the normal case, then the order and selection of entities
4028 will differ. In most cases however, it seems that linkers do not know
4029 how to eliminate duplicate debugging information, even if it is
4030 identical, so the use of this routine would increase the total amount
4031 of debugging information in the final executable.
4033 Second, this routine is called in type_annotate mode, to compute DDA
4034 information for types in withed units, for ASIS use */
4037 elaborate_all_entities (gnat_node
)
4040 Entity_Id gnat_with_clause
, gnat_entity
;
4042 save_gnu_tree (gnat_node
, integer_zero_node
, 1);
4044 /* Save entities in all context units. A body may have an implicit_with
4045 on its own spec, if the context includes a child unit, so don't save
4048 for (gnat_with_clause
= First (Context_Items (gnat_node
));
4049 Present (gnat_with_clause
);
4050 gnat_with_clause
= Next (gnat_with_clause
))
4051 if (Nkind (gnat_with_clause
) == N_With_Clause
4052 && ! present_gnu_tree (Library_Unit (gnat_with_clause
))
4053 && Library_Unit (gnat_with_clause
) != Library_Unit (Cunit (Main_Unit
)))
4055 elaborate_all_entities (Library_Unit (gnat_with_clause
));
4057 if (Ekind (Entity (Name (gnat_with_clause
))) == E_Package
)
4058 for (gnat_entity
= First_Entity (Entity (Name (gnat_with_clause
)));
4059 Present (gnat_entity
);
4060 gnat_entity
= Next_Entity (gnat_entity
))
4061 if (Is_Public (gnat_entity
)
4062 && Convention (gnat_entity
) != Convention_Intrinsic
4063 && Ekind (gnat_entity
) != E_Package
4064 && Ekind (gnat_entity
) != E_Package_Body
4065 && Ekind (gnat_entity
) != E_Operator
4066 && ! (IN (Ekind (gnat_entity
), Type_Kind
)
4067 && ! Is_Frozen (gnat_entity
))
4068 && ! ((Ekind (gnat_entity
) == E_Procedure
4069 || Ekind (gnat_entity
) == E_Function
)
4070 && Is_Intrinsic_Subprogram (gnat_entity
))
4071 && ! IN (Ekind (gnat_entity
), Named_Kind
)
4072 && ! IN (Ekind (gnat_entity
), Generic_Unit_Kind
))
4073 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4076 if (Nkind (Unit (gnat_node
)) == N_Package_Body
&& type_annotate_only
)
4077 elaborate_all_entities (Library_Unit (gnat_node
));
4080 /* Do the processing of N_Freeze_Entity, GNAT_NODE. */
4083 process_freeze_entity (gnat_node
)
4086 Entity_Id gnat_entity
= Entity (gnat_node
);
4090 = (Nkind (Declaration_Node (gnat_entity
)) == N_Object_Declaration
4091 && present_gnu_tree (Declaration_Node (gnat_entity
)))
4092 ? get_gnu_tree (Declaration_Node (gnat_entity
)) : NULL_TREE
;
4094 /* If this is a package, need to generate code for the package. */
4095 if (Ekind (gnat_entity
) == E_Package
)
4098 (Parent (Corresponding_Body
4099 (Parent (Declaration_Node (gnat_entity
)))));
4103 /* Check for old definition after the above call. This Freeze_Node
4104 might be for one its Itypes. */
4106 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4108 /* If this entity has an Address representation clause, GNU_OLD is the
4109 address, so discard it here. */
4110 if (Present (Address_Clause (gnat_entity
)))
4113 /* Don't do anything for class-wide types they are always
4114 transformed into their root type. */
4115 if (Ekind (gnat_entity
) == E_Class_Wide_Type
4116 || (Ekind (gnat_entity
) == E_Class_Wide_Subtype
4117 && Present (Equivalent_Type (gnat_entity
))))
4120 /* Don't do anything for subprograms that may have been elaborated before
4121 their freeze nodes. This can happen, for example because of an inner call
4122 in an instance body. */
4124 && TREE_CODE (gnu_old
) == FUNCTION_DECL
4125 && (Ekind (gnat_entity
) == E_Function
4126 || Ekind (gnat_entity
) == E_Procedure
))
4129 /* If we have a non-dummy type old tree, we have nothing to do. Unless
4130 this is the public view of a private type whose full view was not
4131 delayed, this node was never delayed as it should have been.
4132 Also allow this to happen for concurrent types since we may have
4133 frozen both the Corresponding_Record_Type and this type. */
4135 && ! (TREE_CODE (gnu_old
) == TYPE_DECL
4136 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
))))
4138 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4139 && Present (Full_View (gnat_entity
))
4140 && No (Freeze_Node (Full_View (gnat_entity
))))
4142 else if (Is_Concurrent_Type (gnat_entity
))
4148 /* Reset the saved tree, if any, and elaborate the object or type for real.
4149 If there is a full declaration, elaborate it and copy the type to
4150 GNAT_ENTITY. Likewise if this is the record subtype corresponding to
4151 a class wide type or subtype. */
4154 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4155 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4156 && Present (Full_View (gnat_entity
))
4157 && present_gnu_tree (Full_View (gnat_entity
)))
4158 save_gnu_tree (Full_View (gnat_entity
), NULL_TREE
, 0);
4159 if (Present (Class_Wide_Type (gnat_entity
))
4160 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4161 save_gnu_tree (Class_Wide_Type (gnat_entity
), NULL_TREE
, 0);
4164 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4165 && Present (Full_View (gnat_entity
)))
4167 gnu_new
= gnat_to_gnu_entity (Full_View (gnat_entity
), NULL_TREE
, 1);
4169 /* The above call may have defined this entity (the simplest example
4170 of this is when we have a private enumeral type since the bounds
4171 will have the public view. */
4172 if (! present_gnu_tree (gnat_entity
))
4173 save_gnu_tree (gnat_entity
, gnu_new
, 0);
4174 if (Present (Class_Wide_Type (gnat_entity
))
4175 && Class_Wide_Type (gnat_entity
) != gnat_entity
)
4176 save_gnu_tree (Class_Wide_Type (gnat_entity
), gnu_new
, 0);
4179 gnu_new
= gnat_to_gnu_entity (gnat_entity
, gnu_init
, 1);
4181 /* If we've made any pointers to the old version of this type, we
4182 have to update them. */
4184 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4185 TREE_TYPE (gnu_new
));
4188 /* Process the list of inlined subprograms of GNAT_NODE, which is an
4189 N_Compilation_Unit. */
4192 process_inlined_subprograms (gnat_node
)
4195 Entity_Id gnat_entity
;
4198 /* If we can inline, generate RTL for all the inlined subprograms.
4199 Define the entity first so we set DECL_EXTERNAL. */
4200 if (optimize
> 0 && ! flag_no_inline
)
4201 for (gnat_entity
= First_Inlined_Subprogram (gnat_node
);
4202 Present (gnat_entity
);
4203 gnat_entity
= Next_Inlined_Subprogram (gnat_entity
))
4205 gnat_body
= Parent (Declaration_Node (gnat_entity
));
4207 if (Nkind (gnat_body
) != N_Subprogram_Body
)
4209 /* ??? This really should always be Present. */
4210 if (No (Corresponding_Body (gnat_body
)))
4214 = Parent (Declaration_Node (Corresponding_Body (gnat_body
)));
4217 if (Present (gnat_body
))
4219 gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 0);
4220 gnat_to_code (gnat_body
);
4225 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
4226 We make two passes, one to elaborate anything other than bodies (but
4227 we declare a function if there was no spec). The second pass
4228 elaborates the bodies.
4230 GNAT_END_LIST gives the element in the list past the end. Normally,
4231 this is Empty, but can be First_Real_Statement for a
4232 Handled_Sequence_Of_Statements.
4234 We make a complete pass through both lists if PASS1P is true, then make
4235 the second pass over both lists if PASS2P is true. The lists usually
4236 correspond to the public and private parts of a package. */
4239 process_decls (gnat_decls
, gnat_decls2
, gnat_end_list
, pass1p
, pass2p
)
4240 List_Id gnat_decls
, gnat_decls2
;
4241 Node_Id gnat_end_list
;
4244 List_Id gnat_decl_array
[2];
4248 gnat_decl_array
[0] = gnat_decls
, gnat_decl_array
[1] = gnat_decls2
;
4251 for (i
= 0; i
<= 1; i
++)
4252 if (Present (gnat_decl_array
[i
]))
4253 for (gnat_decl
= First (gnat_decl_array
[i
]);
4254 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4256 set_lineno (gnat_decl
, 0);
4258 /* For package specs, we recurse inside the declarations,
4259 thus taking the two pass approach inside the boundary. */
4260 if (Nkind (gnat_decl
) == N_Package_Declaration
4261 && (Nkind (Specification (gnat_decl
)
4262 == N_Package_Specification
)))
4263 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4264 Private_Declarations (Specification (gnat_decl
)),
4267 /* Similarly for any declarations in the actions of a
4269 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4271 process_freeze_entity (gnat_decl
);
4272 process_decls (Actions (gnat_decl
), Empty
, Empty
, 1, 0);
4275 /* Package bodies with freeze nodes get their elaboration deferred
4276 until the freeze node, but the code must be placed in the right
4277 place, so record the code position now. */
4278 else if (Nkind (gnat_decl
) == N_Package_Body
4279 && Present (Freeze_Node (Corresponding_Spec (gnat_decl
))))
4280 record_code_position (gnat_decl
);
4282 else if (Nkind (gnat_decl
) == N_Package_Body_Stub
4283 && Present (Library_Unit (gnat_decl
))
4284 && Present (Freeze_Node
4287 (Library_Unit (gnat_decl
)))))))
4288 record_code_position
4289 (Proper_Body (Unit (Library_Unit (gnat_decl
))));
4291 /* We defer most subprogram bodies to the second pass.
4292 However, Init_Proc subprograms cannot be defered, but luckily
4293 don't need to be. */
4294 else if ((Nkind (gnat_decl
) == N_Subprogram_Body
4295 && (Chars (Defining_Entity (gnat_decl
))
4296 != Name_uInit_Proc
)))
4298 if (Acts_As_Spec (gnat_decl
))
4300 Node_Id gnat_subprog_id
= Defining_Entity (gnat_decl
);
4302 if (Ekind (gnat_subprog_id
) != E_Generic_Procedure
4303 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4304 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4307 /* For bodies and stubs that act as their own specs, the entity
4308 itself must be elaborated in the first pass, because it may
4309 be used in other declarations. */
4310 else if (Nkind (gnat_decl
) == N_Subprogram_Body_Stub
)
4312 Node_Id gnat_subprog_id
=
4313 Defining_Entity (Specification (gnat_decl
));
4315 if (Ekind (gnat_subprog_id
) != E_Subprogram_Body
4316 && Ekind (gnat_subprog_id
) != E_Generic_Procedure
4317 && Ekind (gnat_subprog_id
) != E_Generic_Function
)
4318 gnat_to_gnu_entity (gnat_subprog_id
, NULL_TREE
, 1);
4321 /* Concurrent stubs stand for the corresponding subprogram bodies,
4322 which are deferred like other bodies. */
4323 else if (Nkind (gnat_decl
) == N_Task_Body_Stub
4324 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4328 gnat_to_code (gnat_decl
);
4331 /* Here we elaborate everything we deferred above except for package bodies,
4332 which are elaborated at their freeze nodes. Note that we must also
4333 go inside things (package specs and freeze nodes) the first pass did. */
4335 for (i
= 0; i
<= 1; i
++)
4336 if (Present (gnat_decl_array
[i
]))
4337 for (gnat_decl
= First (gnat_decl_array
[i
]);
4338 gnat_decl
!= gnat_end_list
; gnat_decl
= Next (gnat_decl
))
4340 if ((Nkind (gnat_decl
) == N_Subprogram_Body
4341 && (Chars (Defining_Entity (gnat_decl
))
4342 != Name_uInit_Proc
))
4343 || Nkind (gnat_decl
) == N_Subprogram_Body_Stub
4344 || Nkind (gnat_decl
) == N_Task_Body_Stub
4345 || Nkind (gnat_decl
) == N_Protected_Body_Stub
)
4346 gnat_to_code (gnat_decl
);
4348 else if (Nkind (gnat_decl
) == N_Package_Declaration
4349 && (Nkind (Specification (gnat_decl
)
4350 == N_Package_Specification
)))
4351 process_decls (Visible_Declarations (Specification (gnat_decl
)),
4352 Private_Declarations (Specification (gnat_decl
)),
4355 else if (Nkind (gnat_decl
) == N_Freeze_Entity
)
4356 process_decls (Actions (gnat_decl
), Empty
, Empty
, 0, 1);
4360 /* Emits an access check. GNU_EXPR is the expression that needs to be
4361 checked against the NULL pointer. */
4364 emit_access_check (gnu_expr
)
4367 tree gnu_check_expr
;
4369 /* Checked expressions must be evaluated only once. */
4370 gnu_check_expr
= gnu_expr
= protect_multiple_eval (gnu_expr
);
4372 /* Technically, we check a fat pointer against two words of zero. However,
4373 that's wasteful and really doesn't protect against null accesses. It
4374 makes more sense to check oly the array pointer. */
4375 if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_expr
)))
4377 = build_component_ref (gnu_expr
, get_identifier ("P_ARRAY"), NULL_TREE
);
4379 if (! POINTER_TYPE_P (TREE_TYPE (gnu_check_expr
)))
4382 return emit_check (build_binary_op (EQ_EXPR
, integer_type_node
,
4384 convert (TREE_TYPE (gnu_check_expr
),
4385 integer_zero_node
)),
4387 CE_Access_Check_Failed
);
4390 /* Emits a discriminant check. GNU_EXPR is the expression to be checked and
4391 GNAT_NODE a N_Selected_Component node. */
4394 emit_discriminant_check (gnu_expr
, gnat_node
)
4399 = Original_Record_Component (Entity (Selector_Name (gnat_node
)));
4400 Entity_Id gnat_discr_fct
= Discriminant_Checking_Func (orig_comp
);
4402 Entity_Id gnat_discr
;
4403 tree gnu_actual_list
= NULL_TREE
;
4405 Entity_Id gnat_pref_type
;
4408 if (Is_Tagged_Type (Scope (orig_comp
)))
4409 gnat_pref_type
= Scope (orig_comp
);
4412 gnat_pref_type
= Etype (Prefix (gnat_node
));
4414 /* For an untagged derived type, use the discriminants of the parent,
4415 which have been renamed in the derivation, possibly by a one-to-many
4417 if (Is_Derived_Type (gnat_pref_type
)
4418 && (Number_Discriminants (gnat_pref_type
)
4419 != Number_Discriminants (Etype (Base_Type (gnat_pref_type
)))))
4420 gnat_pref_type
= Etype (Base_Type (gnat_pref_type
));
4423 if (! Present (gnat_discr_fct
))
4426 gnu_discr_fct
= gnat_to_gnu (gnat_discr_fct
);
4428 /* Checked expressions must be evaluated only once. */
4429 gnu_expr
= protect_multiple_eval (gnu_expr
);
4431 /* Create the list of the actual parameters as GCC expects it.
4432 This list is the list of the discriminant fields of the
4433 record expression to be discriminant checked. For documentation
4434 on what is the GCC format for this list see under the
4435 N_Function_Call case */
4437 while (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
)
4438 || IN (Ekind (gnat_pref_type
), Access_Kind
))
4440 if (IN (Ekind (gnat_pref_type
), Incomplete_Or_Private_Kind
))
4441 gnat_pref_type
= Underlying_Type (gnat_pref_type
);
4442 else if (IN (Ekind (gnat_pref_type
), Access_Kind
))
4443 gnat_pref_type
= Designated_Type (gnat_pref_type
);
4447 = TREE_TYPE (gnat_to_gnu_entity (gnat_pref_type
, NULL_TREE
, 0));
4449 for (gnat_discr
= First_Discriminant (gnat_pref_type
);
4450 Present (gnat_discr
); gnat_discr
= Next_Discriminant (gnat_discr
))
4452 Entity_Id gnat_real_discr
4453 = ((Present (Corresponding_Discriminant (gnat_discr
))
4454 && Present (Parent_Subtype (gnat_pref_type
)))
4455 ? Corresponding_Discriminant (gnat_discr
) : gnat_discr
);
4456 tree gnu_discr
= gnat_to_gnu_entity (gnat_real_discr
, NULL_TREE
, 0);
4459 = chainon (gnu_actual_list
,
4460 build_tree_list (NULL_TREE
,
4462 (convert (gnu_pref_type
, gnu_expr
),
4463 NULL_TREE
, gnu_discr
)));
4466 gnu_cond
= build (CALL_EXPR
,
4467 TREE_TYPE (TREE_TYPE (gnu_discr_fct
)),
4468 build_unary_op (ADDR_EXPR
, NULL_TREE
, gnu_discr_fct
),
4471 TREE_SIDE_EFFECTS (gnu_cond
) = 1;
4475 (INDIRECT_REF
, NULL_TREE
,
4476 emit_check (gnu_cond
,
4477 build_unary_op (ADDR_EXPR
,
4478 build_reference_type (TREE_TYPE (gnu_expr
)),
4480 CE_Discriminant_Check_Failed
));
4483 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
4484 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
4485 which we have to check. */
4488 emit_range_check (gnu_expr
, gnat_range_type
)
4490 Entity_Id gnat_range_type
;
4492 tree gnu_range_type
= get_unpadded_type (gnat_range_type
);
4493 tree gnu_low
= TYPE_MIN_VALUE (gnu_range_type
);
4494 tree gnu_high
= TYPE_MAX_VALUE (gnu_range_type
);
4495 tree gnu_compare_type
= get_base_type (TREE_TYPE (gnu_expr
));
4497 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE,
4498 we can't do anything since we might be truncating the bounds. No
4499 check is needed in this case. */
4500 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr
))
4501 && (TYPE_PRECISION (gnu_compare_type
)
4502 < TYPE_PRECISION (get_base_type (gnu_range_type
))))
4505 /* Checked expressions must be evaluated only once. */
4506 gnu_expr
= protect_multiple_eval (gnu_expr
);
4508 /* There's no good type to use here, so we might as well use
4509 integer_type_node. Note that the form of the check is
4510 (not (expr >= lo)) or (not (expr >= hi))
4511 the reason for this slightly convoluted form is that NaN's
4512 are not considered to be in range in the float case. */
4514 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4516 (build_binary_op (GE_EXPR
, integer_type_node
,
4517 convert (gnu_compare_type
, gnu_expr
),
4518 convert (gnu_compare_type
, gnu_low
))),
4520 (build_binary_op (LE_EXPR
, integer_type_node
,
4521 convert (gnu_compare_type
, gnu_expr
),
4522 convert (gnu_compare_type
,
4524 gnu_expr
, CE_Range_Check_Failed
);
4527 /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object
4528 which we are about to index, GNU_EXPR is the index expression to be
4529 checked, GNU_LOW and GNU_HIGH are the lower and upper bounds
4530 against which GNU_EXPR has to be checked. Note that for index
4531 checking we cannot use the emit_range_check function (although very
4532 similar code needs to be generated in both cases) since for index
4533 checking the array type against which we are checking the indeces
4534 may be unconstrained and consequently we need to retrieve the
4535 actual index bounds from the array object itself
4536 (GNU_ARRAY_OBJECT). The place where we need to do that is in
4537 subprograms having unconstrained array formal parameters */
4540 emit_index_check (gnu_array_object
, gnu_expr
, gnu_low
, gnu_high
)
4541 tree gnu_array_object
;
4546 tree gnu_expr_check
;
4548 /* Checked expressions must be evaluated only once. */
4549 gnu_expr
= protect_multiple_eval (gnu_expr
);
4551 /* Must do this computation in the base type in case the expression's
4552 type is an unsigned subtypes. */
4553 gnu_expr_check
= convert (get_base_type (TREE_TYPE (gnu_expr
)), gnu_expr
);
4555 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
4556 the object we are handling. */
4557 if (TREE_CODE (gnu_low
) != INTEGER_CST
&& contains_placeholder_p (gnu_low
))
4558 gnu_low
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_low
),
4559 gnu_low
, gnu_array_object
);
4561 if (TREE_CODE (gnu_high
) != INTEGER_CST
&& contains_placeholder_p (gnu_high
))
4562 gnu_high
= build (WITH_RECORD_EXPR
, TREE_TYPE (gnu_high
),
4563 gnu_high
, gnu_array_object
);
4565 /* There's no good type to use here, so we might as well use
4566 integer_type_node. */
4568 (build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
,
4569 build_binary_op (LT_EXPR
, integer_type_node
,
4571 convert (TREE_TYPE (gnu_expr_check
),
4573 build_binary_op (GT_EXPR
, integer_type_node
,
4575 convert (TREE_TYPE (gnu_expr_check
),
4577 gnu_expr
, CE_Index_Check_Failed
);
4580 /* Given GNU_COND which contains the condition corresponding to an access,
4581 discriminant or range check, of value GNU_EXPR, build a COND_EXPR
4582 that returns GNU_EXPR if GNU_COND is false and raises a
4583 CONSTRAINT_ERROR if GNU_COND is true. REASON is the code that says
4584 why the exception was raised. */
4587 emit_check (gnu_cond
, gnu_expr
, reason
)
4595 gnu_call
= build_call_raise (reason
);
4597 /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated
4598 in front of the comparison in case it ends up being a SAVE_EXPR. Put the
4599 whole thing inside its own SAVE_EXPR so the inner SAVE_EXPR doesn't leak
4601 gnu_result
= fold (build (COND_EXPR
, TREE_TYPE (gnu_expr
), gnu_cond
,
4602 build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
),
4603 gnu_call
, gnu_expr
),
4606 /* If GNU_EXPR has side effects, make the outer COMPOUND_EXPR and
4607 protect it. Otherwise, show GNU_RESULT has no side effects: we
4608 don't need to evaluate it just for the check. */
4609 if (TREE_SIDE_EFFECTS (gnu_expr
))
4611 = build (COMPOUND_EXPR
, TREE_TYPE (gnu_expr
), gnu_expr
, gnu_result
);
4613 TREE_SIDE_EFFECTS (gnu_result
) = 0;
4615 /* ??? Unfortunately, if we don't put a SAVE_EXPR around this whole thing,
4616 we will repeatedly do the test. It would be nice if GCC was able
4617 to optimize this and only do it once. */
4618 return save_expr (gnu_result
);
4621 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing
4622 overflow checks if OVERFLOW_P is nonzero and range checks if
4623 RANGE_P is nonzero. GNAT_TYPE is known to be an integral type.
4624 If TRUNCATE_P is nonzero, do a float to integer conversion with
4625 truncation; otherwise round. */
4628 convert_with_check (gnat_type
, gnu_expr
, overflow_p
, range_p
, truncate_p
)
4629 Entity_Id gnat_type
;
4635 tree gnu_type
= get_unpadded_type (gnat_type
);
4636 tree gnu_in_type
= TREE_TYPE (gnu_expr
);
4637 tree gnu_in_basetype
= get_base_type (gnu_in_type
);
4638 tree gnu_base_type
= get_base_type (gnu_type
);
4639 tree gnu_ada_base_type
= get_ada_base_type (gnu_type
);
4640 tree gnu_in_lb
= TYPE_MIN_VALUE (gnu_in_basetype
);
4641 tree gnu_in_ub
= TYPE_MAX_VALUE (gnu_in_basetype
);
4642 tree gnu_out_lb
= TYPE_MIN_VALUE (gnu_base_type
);
4643 tree gnu_out_ub
= TYPE_MAX_VALUE (gnu_base_type
);
4644 tree gnu_result
= gnu_expr
;
4646 /* If we are not doing any checks, the output is an integral type, and
4647 the input is not a floating type, just do the conversion. This
4648 shortcut is required to avoid problems with packed array types
4649 and simplifies code in all cases anyway. */
4650 if (! range_p
&& ! overflow_p
&& INTEGRAL_TYPE_P (gnu_base_type
)
4651 && ! FLOAT_TYPE_P (gnu_in_type
))
4652 return convert (gnu_type
, gnu_expr
);
4654 /* First convert the expression to its base type. This
4655 will never generate code, but makes the tests below much simpler.
4656 But don't do this if converting from an integer type to an unconstrained
4657 array type since then we need to get the bounds from the original
4659 if (TREE_CODE (gnu_type
) != UNCONSTRAINED_ARRAY_TYPE
)
4660 gnu_result
= convert (gnu_in_basetype
, gnu_result
);
4662 /* If overflow checks are requested, we need to be sure the result will
4663 fit in the output base type. But don't do this if the input
4664 is integer and the output floating-point. */
4666 && ! (FLOAT_TYPE_P (gnu_base_type
) && INTEGRAL_TYPE_P (gnu_in_basetype
)))
4668 /* Ensure GNU_EXPR only gets evaluated once. */
4669 tree gnu_input
= protect_multiple_eval (gnu_result
);
4670 tree gnu_cond
= integer_zero_node
;
4672 /* Convert the lower bounds to signed types, so we're sure we're
4673 comparing them properly. Likewise, convert the upper bounds
4674 to unsigned types. */
4675 if (INTEGRAL_TYPE_P (gnu_in_basetype
) && TREE_UNSIGNED (gnu_in_basetype
))
4676 gnu_in_lb
= convert (gnat_signed_type (gnu_in_basetype
), gnu_in_lb
);
4678 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4679 && ! TREE_UNSIGNED (gnu_in_basetype
))
4680 gnu_in_ub
= convert (gnat_unsigned_type (gnu_in_basetype
), gnu_in_ub
);
4682 if (INTEGRAL_TYPE_P (gnu_base_type
) && TREE_UNSIGNED (gnu_base_type
))
4683 gnu_out_lb
= convert (gnat_signed_type (gnu_base_type
), gnu_out_lb
);
4685 if (INTEGRAL_TYPE_P (gnu_base_type
) && ! TREE_UNSIGNED (gnu_base_type
))
4686 gnu_out_ub
= convert (gnat_unsigned_type (gnu_base_type
), gnu_out_ub
);
4688 /* Check each bound separately and only if the result bound
4689 is tighter than the bound on the input type. Note that all the
4690 types are base types, so the bounds must be constant. Also,
4691 the comparison is done in the base type of the input, which
4692 always has the proper signedness. First check for input
4693 integer (which means output integer), output float (which means
4694 both float), or mixed, in which case we always compare.
4695 Note that we have to do the comparison which would *fail* in the
4696 case of an error since if it's an FP comparison and one of the
4697 values is a NaN or Inf, the comparison will fail. */
4698 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4699 ? tree_int_cst_lt (gnu_in_lb
, gnu_out_lb
)
4700 : (FLOAT_TYPE_P (gnu_base_type
)
4701 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb
),
4702 TREE_REAL_CST (gnu_out_lb
))
4706 (build_binary_op (GE_EXPR
, integer_type_node
,
4707 gnu_input
, convert (gnu_in_basetype
,
4710 if (INTEGRAL_TYPE_P (gnu_in_basetype
)
4711 ? tree_int_cst_lt (gnu_out_ub
, gnu_in_ub
)
4712 : (FLOAT_TYPE_P (gnu_base_type
)
4713 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub
),
4714 TREE_REAL_CST (gnu_in_lb
))
4717 = build_binary_op (TRUTH_ORIF_EXPR
, integer_type_node
, gnu_cond
,
4719 (build_binary_op (LE_EXPR
, integer_type_node
,
4721 convert (gnu_in_basetype
,
4724 if (! integer_zerop (gnu_cond
))
4725 gnu_result
= emit_check (gnu_cond
, gnu_input
,
4726 CE_Overflow_Check_Failed
);
4729 /* Now convert to the result base type. If this is a non-truncating
4730 float-to-integer conversion, round. */
4731 if (INTEGRAL_TYPE_P (gnu_ada_base_type
) && FLOAT_TYPE_P (gnu_in_basetype
)
4734 tree gnu_point_5
= build_real (gnu_in_basetype
, dconstp5
);
4735 tree gnu_minus_point_5
= build_real (gnu_in_basetype
, dconstmp5
);
4736 tree gnu_zero
= convert (gnu_in_basetype
, integer_zero_node
);
4737 tree gnu_saved_result
= save_expr (gnu_result
);
4738 tree gnu_comp
= build (GE_EXPR
, integer_type_node
,
4739 gnu_saved_result
, gnu_zero
);
4740 tree gnu_adjust
= build (COND_EXPR
, gnu_in_basetype
, gnu_comp
,
4741 gnu_point_5
, gnu_minus_point_5
);
4744 = build (PLUS_EXPR
, gnu_in_basetype
, gnu_saved_result
, gnu_adjust
);
4747 if (TREE_CODE (gnu_ada_base_type
) == INTEGER_TYPE
4748 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type
)
4749 && TREE_CODE (gnu_result
) == UNCONSTRAINED_ARRAY_REF
)
4750 gnu_result
= unchecked_convert (gnu_ada_base_type
, gnu_result
);
4752 gnu_result
= convert (gnu_ada_base_type
, gnu_result
);
4754 /* Finally, do the range check if requested. Note that if the
4755 result type is a modular type, the range check is actually
4756 an overflow check. */
4759 || (TREE_CODE (gnu_base_type
) == INTEGER_TYPE
4760 && TYPE_MODULAR_P (gnu_base_type
) && overflow_p
))
4761 gnu_result
= emit_range_check (gnu_result
, gnat_type
);
4763 return convert (gnu_type
, gnu_result
);
4766 /* Return 1 if GNU_EXPR can be directly addressed. This is the case
4767 unless it is an expression involving computation or if it involves
4768 a bitfield reference. This returns the same as
4769 gnat_mark_addressable in most cases. */
4772 addressable_p (gnu_expr
)
4775 switch (TREE_CODE (gnu_expr
))
4777 case UNCONSTRAINED_ARRAY_REF
:
4788 return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr
, 1))
4789 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4791 case ARRAY_REF
: case ARRAY_RANGE_REF
:
4792 case REALPART_EXPR
: case IMAGPART_EXPR
:
4794 return addressable_p (TREE_OPERAND (gnu_expr
, 0));
4797 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr
))
4798 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4800 case VIEW_CONVERT_EXPR
:
4802 /* This is addressable if we can avoid a copy. */
4803 tree type
= TREE_TYPE (gnu_expr
);
4804 tree inner_type
= TREE_TYPE (TREE_OPERAND (gnu_expr
, 0));
4806 return (((TYPE_MODE (type
) == TYPE_MODE (inner_type
)
4807 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4808 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
))
4809 || ((TYPE_MODE (type
) == BLKmode
4810 || TYPE_MODE (inner_type
) == BLKmode
)
4811 && (TYPE_ALIGN (type
) <= TYPE_ALIGN (inner_type
)
4812 || TYPE_ALIGN (inner_type
) >= BIGGEST_ALIGNMENT
4813 || TYPE_ALIGN_OK (type
)
4814 || TYPE_ALIGN_OK (inner_type
))))
4815 && addressable_p (TREE_OPERAND (gnu_expr
, 0)));
4823 /* Do the processing for the declaration of a GNAT_ENTITY, a type. If
4824 a separate Freeze node exists, delay the bulk of the processing. Otherwise
4825 make a GCC type for GNAT_ENTITY and set up the correspondance. */
4828 process_type (gnat_entity
)
4829 Entity_Id gnat_entity
;
4832 = present_gnu_tree (gnat_entity
) ? get_gnu_tree (gnat_entity
) : 0;
4835 /* If we are to delay elaboration of this type, just do any
4836 elaborations needed for expressions within the declaration and
4837 make a dummy type entry for this node and its Full_View (if
4838 any) in case something points to it. Don't do this if it
4839 has already been done (the only way that can happen is if
4840 the private completion is also delayed). */
4841 if (Present (Freeze_Node (gnat_entity
))
4842 || (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4843 && Present (Full_View (gnat_entity
))
4844 && Freeze_Node (Full_View (gnat_entity
))
4845 && ! present_gnu_tree (Full_View (gnat_entity
))))
4847 elaborate_entity (gnat_entity
);
4851 tree gnu_decl
= create_type_decl (get_entity_name (gnat_entity
),
4852 make_dummy_type (gnat_entity
),
4855 save_gnu_tree (gnat_entity
, gnu_decl
, 0);
4856 if (IN (Ekind (gnat_entity
), Incomplete_Or_Private_Kind
)
4857 && Present (Full_View (gnat_entity
)))
4858 save_gnu_tree (Full_View (gnat_entity
), gnu_decl
, 0);
4864 /* If we saved away a dummy type for this node it means that this
4865 made the type that corresponds to the full type of an incomplete
4866 type. Clear that type for now and then update the type in the
4870 if (TREE_CODE (gnu_old
) != TYPE_DECL
4871 || ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old
)))
4873 /* If this was a withed access type, this is not an error
4874 and merely indicates we've already elaborated the type
4876 if (Is_Type (gnat_entity
) && From_With_Type (gnat_entity
))
4882 save_gnu_tree (gnat_entity
, NULL_TREE
, 0);
4885 /* Now fully elaborate the type. */
4886 gnu_new
= gnat_to_gnu_entity (gnat_entity
, NULL_TREE
, 1);
4887 if (TREE_CODE (gnu_new
) != TYPE_DECL
)
4890 /* If we have an old type and we've made pointers to this type,
4891 update those pointers. */
4893 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old
)),
4894 TREE_TYPE (gnu_new
));
4896 /* If this is a record type corresponding to a task or protected type
4897 that is a completion of an incomplete type, perform a similar update
4899 /* ??? Including protected types here is a guess. */
4901 if (IN (Ekind (gnat_entity
), Record_Kind
)
4902 && Is_Concurrent_Record_Type (gnat_entity
)
4903 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
)))
4906 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
));
4908 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4910 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity
),
4913 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old
)),
4914 TREE_TYPE (gnu_new
));
4918 /* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
4919 GNU_TYPE is the GCC type of the corresponding record.
4921 Return a CONSTRUCTOR to build the record. */
4924 assoc_to_constructor (gnat_assoc
, gnu_type
)
4928 tree gnu_field
, gnu_list
, gnu_result
;
4930 /* We test for GNU_FIELD being empty in the case where a variant
4931 was the last thing since we don't take things off GNAT_ASSOC in
4932 that case. We check GNAT_ASSOC in case we have a variant, but it
4935 for (gnu_list
= NULL_TREE
; Present (gnat_assoc
);
4936 gnat_assoc
= Next (gnat_assoc
))
4938 Node_Id gnat_field
= First (Choices (gnat_assoc
));
4939 tree gnu_field
= gnat_to_gnu_entity (Entity (gnat_field
), NULL_TREE
, 0);
4940 tree gnu_expr
= gnat_to_gnu (Expression (gnat_assoc
));
4942 /* The expander is supposed to put a single component selector name
4943 in every record component association */
4944 if (Next (gnat_field
))
4947 /* Before assigning a value in an aggregate make sure range checks
4948 are done if required. Then convert to the type of the field. */
4949 if (Do_Range_Check (Expression (gnat_assoc
)))
4950 gnu_expr
= emit_range_check (gnu_expr
, Etype (gnat_field
));
4952 gnu_expr
= convert (TREE_TYPE (gnu_field
), gnu_expr
);
4954 /* Add the field and expression to the list. */
4955 gnu_list
= tree_cons (gnu_field
, gnu_expr
, gnu_list
);
4958 gnu_result
= extract_values (gnu_list
, gnu_type
);
4960 /* Verify every enty in GNU_LIST was used. */
4961 for (gnu_field
= gnu_list
; gnu_field
; gnu_field
= TREE_CHAIN (gnu_field
))
4962 if (! TREE_ADDRESSABLE (gnu_field
))
4968 /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR
4969 is the first element of an array aggregate. It may itself be an
4970 aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type
4971 corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type
4972 of the array component. It is needed for range checking. */
4975 pos_to_constructor (gnat_expr
, gnu_array_type
, gnat_component_type
)
4977 tree gnu_array_type
;
4978 Entity_Id gnat_component_type
;
4981 tree gnu_expr_list
= NULL_TREE
;
4983 for ( ; Present (gnat_expr
); gnat_expr
= Next (gnat_expr
))
4985 /* If the expression is itself an array aggregate then first build the
4986 innermost constructor if it is part of our array (multi-dimensional
4989 if (Nkind (gnat_expr
) == N_Aggregate
4990 && TREE_CODE (TREE_TYPE (gnu_array_type
)) == ARRAY_TYPE
4991 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type
)))
4992 gnu_expr
= pos_to_constructor (First (Expressions (gnat_expr
)),
4993 TREE_TYPE (gnu_array_type
),
4994 gnat_component_type
);
4997 gnu_expr
= gnat_to_gnu (gnat_expr
);
4999 /* before assigning the element to the array make sure it is
5001 if (Do_Range_Check (gnat_expr
))
5002 gnu_expr
= emit_range_check (gnu_expr
, gnat_component_type
);
5006 = tree_cons (NULL_TREE
, convert (TREE_TYPE (gnu_array_type
), gnu_expr
),
5010 return build_constructor (gnu_array_type
, nreverse (gnu_expr_list
));
5013 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
5014 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting
5015 of the associations that are from RECORD_TYPE. If we see an internal
5016 record, make a recursive call to fill it in as well. */
5019 extract_values (values
, record_type
)
5023 tree result
= NULL_TREE
;
5026 for (field
= TYPE_FIELDS (record_type
); field
; field
= TREE_CHAIN (field
))
5030 /* _Parent is an internal field, but may have values in the aggregate,
5031 so check for values first. */
5032 if ((tem
= purpose_member (field
, values
)) != 0)
5034 value
= TREE_VALUE (tem
);
5035 TREE_ADDRESSABLE (tem
) = 1;
5038 else if (DECL_INTERNAL_P (field
))
5040 value
= extract_values (values
, TREE_TYPE (field
));
5041 if (TREE_CODE (value
) == CONSTRUCTOR
5042 && CONSTRUCTOR_ELTS (value
) == 0)
5046 /* If we have a record subtype, the names will match, but not the
5047 actual FIELD_DECLs. */
5048 for (tem
= values
; tem
; tem
= TREE_CHAIN (tem
))
5049 if (DECL_NAME (TREE_PURPOSE (tem
)) == DECL_NAME (field
))
5051 value
= convert (TREE_TYPE (field
), TREE_VALUE (tem
));
5052 TREE_ADDRESSABLE (tem
) = 1;
5058 result
= tree_cons (field
, value
, result
);
5061 return build_constructor (record_type
, nreverse (result
));
5064 /* EXP is to be treated as an array or record. Handle the cases when it is
5065 an access object and perform the required dereferences. */
5068 maybe_implicit_deref (exp
)
5071 /* If the type is a pointer, dereference it. */
5073 if (POINTER_TYPE_P (TREE_TYPE (exp
)) || TYPE_FAT_POINTER_P (TREE_TYPE (exp
)))
5074 exp
= build_unary_op (INDIRECT_REF
, NULL_TREE
, exp
);
5076 /* If we got a padded type, remove it too. */
5077 if (TREE_CODE (TREE_TYPE (exp
)) == RECORD_TYPE
5078 && TYPE_IS_PADDING_P (TREE_TYPE (exp
)))
5079 exp
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp
))), exp
);
5084 /* Protect EXP from multiple evaluation. This may make a SAVE_EXPR. */
5087 protect_multiple_eval (exp
)
5090 tree type
= TREE_TYPE (exp
);
5092 /* If this has no side effects, we don't need to do anything. */
5093 if (! TREE_SIDE_EFFECTS (exp
))
5096 /* If it is a conversion, protect what's inside the conversion.
5097 Similarly, if we're indirectly referencing something, we only
5098 actually need to protect the address since the data itself can't
5099 change in these situations. */
5100 else if (TREE_CODE (exp
) == NON_LVALUE_EXPR
5101 || TREE_CODE (exp
) == NOP_EXPR
|| TREE_CODE (exp
) == CONVERT_EXPR
5102 || TREE_CODE (exp
) == VIEW_CONVERT_EXPR
5103 || TREE_CODE (exp
) == INDIRECT_REF
5104 || TREE_CODE (exp
) == UNCONSTRAINED_ARRAY_REF
)
5105 return build1 (TREE_CODE (exp
), type
,
5106 protect_multiple_eval (TREE_OPERAND (exp
, 0)));
5108 /* If EXP is a fat pointer or something that can be placed into a register,
5109 just make a SAVE_EXPR. */
5110 if (TYPE_FAT_POINTER_P (type
) || TYPE_MODE (type
) != BLKmode
)
5111 return save_expr (exp
);
5113 /* Otherwise, dereference, protect the address, and re-reference. */
5116 build_unary_op (INDIRECT_REF
, type
,
5117 save_expr (build_unary_op (ADDR_EXPR
,
5118 build_reference_type (type
),
5122 /* This is equivalent to stabilize_reference in GCC's tree.c, but we know
5123 how to handle our new nodes and we take an extra argument that says
5124 whether to force evaluation of everything. */
5127 gnat_stabilize_reference (ref
, force
)
5131 register tree type
= TREE_TYPE (ref
);
5132 register enum tree_code code
= TREE_CODE (ref
);
5133 register tree result
;
5140 /* No action is needed in this case. */
5146 case FIX_TRUNC_EXPR
:
5147 case FIX_FLOOR_EXPR
:
5148 case FIX_ROUND_EXPR
:
5150 case VIEW_CONVERT_EXPR
:
5153 = build1 (code
, type
,
5154 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
));
5158 case UNCONSTRAINED_ARRAY_REF
:
5159 result
= build1 (code
, type
,
5160 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5165 result
= build (COMPONENT_REF
, type
,
5166 gnat_stabilize_reference (TREE_OPERAND (ref
, 0),
5168 TREE_OPERAND (ref
, 1));
5172 result
= build (BIT_FIELD_REF
, type
,
5173 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5174 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5176 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 2),
5181 result
= build (ARRAY_REF
, type
,
5182 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5183 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5187 case ARRAY_RANGE_REF
:
5188 result
= build (ARRAY_RANGE_REF
, type
,
5189 gnat_stabilize_reference (TREE_OPERAND (ref
, 0), force
),
5190 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 1),
5195 result
= build (COMPOUND_EXPR
, type
,
5196 gnat_stabilize_reference_1 (TREE_OPERAND (ref
, 0),
5198 gnat_stabilize_reference (TREE_OPERAND (ref
, 1),
5203 result
= build1 (INDIRECT_REF
, type
,
5204 save_expr (build1 (ADDR_EXPR
,
5205 build_reference_type (type
), ref
)));
5208 /* If arg isn't a kind of lvalue we recognize, make no change.
5209 Caller should recognize the error for an invalid lvalue. */
5214 return error_mark_node
;
5217 TREE_READONLY (result
) = TREE_READONLY (ref
);
5221 /* Similar to stabilize_reference_1 in tree.c, but supports an extra
5222 arg to force a SAVE_EXPR for everything. */
5225 gnat_stabilize_reference_1 (e
, force
)
5229 register enum tree_code code
= TREE_CODE (e
);
5230 register tree type
= TREE_TYPE (e
);
5231 register tree result
;
5233 /* We cannot ignore const expressions because it might be a reference
5234 to a const array but whose index contains side-effects. But we can
5235 ignore things that are actual constant or that already have been
5236 handled by this function. */
5238 if (TREE_CONSTANT (e
) || code
== SAVE_EXPR
)
5241 switch (TREE_CODE_CLASS (code
))
5251 if (TREE_SIDE_EFFECTS (e
) || force
)
5252 return save_expr (e
);
5256 /* Constants need no processing. In fact, we should never reach
5261 /* Recursively stabilize each operand. */
5262 result
= build (code
, type
,
5263 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0), force
),
5264 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 1), force
));
5268 /* Recursively stabilize each operand. */
5269 result
= build1 (code
, type
,
5270 gnat_stabilize_reference_1 (TREE_OPERAND (e
, 0),
5278 TREE_READONLY (result
) = TREE_READONLY (e
);
5282 /* GNAT_UNIT is the Defining_Identifier for some package or subprogram,
5283 either a spec or a body, BODY_P says which. If needed, make a function
5284 to be the elaboration routine for that object and perform the elaborations
5287 Return 1 if we didn't need an elaboration function, zero otherwise. */
5290 build_unit_elab (gnat_unit
, body_p
, gnu_elab_list
)
5291 Entity_Id gnat_unit
;
5299 /* If we have nothing to do, return. */
5300 if (gnu_elab_list
== 0)
5303 /* Set our file and line number to that of the object and set up the
5304 elaboration routine. */
5305 gnu_decl
= create_subprog_decl (create_concat_name (gnat_unit
,
5308 NULL_TREE
, void_ftype
, NULL_TREE
, 0, 1, 0,
5310 DECL_ELABORATION_PROC_P (gnu_decl
) = 1;
5312 begin_subprog_body (gnu_decl
);
5313 set_lineno (gnat_unit
, 1);
5315 gnu_block_stack
= tree_cons (NULL_TREE
, NULL_TREE
, gnu_block_stack
);
5316 expand_start_bindings (0);
5318 /* Emit the assignments for the elaborations we have to do. If there
5319 is no destination, this is just a call to execute some statement
5320 that was placed within the declarative region. But first save a
5321 pointer so we can see if any insns were generated. */
5323 insn
= get_last_insn ();
5325 for (; gnu_elab_list
; gnu_elab_list
= TREE_CHAIN (gnu_elab_list
))
5326 if (TREE_PURPOSE (gnu_elab_list
) == NULL_TREE
)
5328 if (TREE_VALUE (gnu_elab_list
) != 0)
5329 expand_expr_stmt (TREE_VALUE (gnu_elab_list
));
5333 tree lhs
= TREE_PURPOSE (gnu_elab_list
);
5335 input_filename
= DECL_SOURCE_FILE (lhs
);
5336 lineno
= DECL_SOURCE_LINE (lhs
);
5338 /* If LHS has a padded type, convert it to the unpadded type
5339 so the assignment is done properly. */
5340 if (TREE_CODE (TREE_TYPE (lhs
)) == RECORD_TYPE
5341 && TYPE_IS_PADDING_P (TREE_TYPE (lhs
)))
5342 lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs
))), lhs
);
5344 emit_line_note (input_filename
, lineno
);
5345 expand_expr_stmt (build_binary_op (MODIFY_EXPR
, NULL_TREE
,
5346 TREE_PURPOSE (gnu_elab_list
),
5347 TREE_VALUE (gnu_elab_list
)));
5350 /* See if any non-NOTE insns were generated. */
5351 for (insn
= NEXT_INSN (insn
); insn
; insn
= NEXT_INSN (insn
))
5352 if (GET_RTX_CLASS (GET_CODE (insn
)) == 'i')
5358 expand_end_bindings (getdecls (), kept_level_p (), 0);
5359 poplevel (kept_level_p (), 1, 0);
5360 gnu_block_stack
= TREE_CHAIN (gnu_block_stack
);
5361 end_subprog_body ();
5363 /* If there were no insns, we don't need an elab routine. It would
5364 be nice to not output this one, but there's no good way to do that. */
5368 extern char *__gnat_to_canonical_file_spec
PARAMS ((char *));
5370 /* Determine the input_filename and the lineno from the source location
5371 (Sloc) of GNAT_NODE node. Set the global variable input_filename and
5372 lineno. If WRITE_NOTE_P is true, emit a line number note. */
5375 set_lineno (gnat_node
, write_note_p
)
5379 Source_Ptr source_location
= Sloc (gnat_node
);
5381 /* If node not from source code, ignore. */
5382 if (source_location
< 0)
5385 /* Use the identifier table to make a hashed, permanent copy of the filename,
5386 since the name table gets reallocated after Gigi returns but before all
5387 the debugging information is output. The call to
5388 __gnat_to_canonical_file_spec translates filenames from pragmas
5389 Source_Reference that contain host style syntax not understood by gdb. */
5391 = IDENTIFIER_POINTER
5393 (__gnat_to_canonical_file_spec
5395 (Debug_Source_Name (Get_Source_File_Index (source_location
))))));
5397 /* ref_filename is the reference file name as given by sinput (i.e no
5400 = IDENTIFIER_POINTER
5403 (Reference_Name (Get_Source_File_Index (source_location
)))));;
5404 lineno
= Get_Logical_Line_Number (source_location
);
5407 emit_line_note (input_filename
, lineno
);
5410 /* Post an error message. MSG is the error message, properly annotated.
5411 NODE is the node at which to post the error and the node to use for the
5412 "&" substitution. */
5415 post_error (msg
, node
)
5419 String_Template temp
;
5422 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5423 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5425 Error_Msg_N (fp
, node
);
5428 /* Similar, but NODE is the node at which to post the error and ENT
5429 is the node to use for the "&" substitution. */
5432 post_error_ne (msg
, node
, ent
)
5437 String_Template temp
;
5440 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5441 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5443 Error_Msg_NE (fp
, node
, ent
);
5446 /* Similar, but NODE is the node at which to post the error, ENT is the node
5447 to use for the "&" substitution, and N is the number to use for the ^. */
5450 post_error_ne_num (msg
, node
, ent
, n
)
5456 String_Template temp
;
5459 temp
.Low_Bound
= 1, temp
.High_Bound
= strlen (msg
);
5460 fp
.Array
= msg
, fp
.Bounds
= &temp
;
5461 Error_Msg_Uint_1
= UI_From_Int (n
);
5464 Error_Msg_NE (fp
, node
, ent
);
5467 /* Similar to post_error_ne_num, but T is a GCC tree representing the
5468 number to write. If the tree represents a constant that fits within
5469 a host integer, the text inside curly brackets in MSG will be output
5470 (presumably including a '^'). Otherwise that text will not be output
5471 and the text inside square brackets will be output instead. */
5474 post_error_ne_tree (msg
, node
, ent
, t
)
5480 char *newmsg
= alloca (strlen (msg
) + 1);
5481 String_Template temp
= {1, 0};
5483 char start_yes
, end_yes
, start_no
, end_no
;
5487 fp
.Array
= newmsg
, fp
.Bounds
= &temp
;
5489 if (host_integerp (t
, 1)
5490 #if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
5491 && compare_tree_int (t
, 1 << (HOST_BITS_PER_INT
- 2)) < 0
5495 Error_Msg_Uint_1
= UI_From_Int (tree_low_cst (t
, 1));
5496 start_yes
= '{', end_yes
= '}', start_no
= '[', end_no
= ']';
5499 start_yes
= '[', end_yes
= ']', start_no
= '{', end_no
= '}';
5501 for (p
= msg
, q
= newmsg
; *p
!= 0; p
++)
5503 if (*p
== start_yes
)
5504 for (p
++; *p
!= end_yes
; p
++)
5506 else if (*p
== start_no
)
5507 for (p
++; *p
!= end_no
; p
++)
5515 temp
.High_Bound
= strlen (newmsg
);
5517 Error_Msg_NE (fp
, node
, ent
);
5520 /* Similar to post_error_ne_tree, except that NUM is a second
5521 integer to write in the message. */
5524 post_error_ne_tree_2 (msg
, node
, ent
, t
, num
)
5531 Error_Msg_Uint_2
= UI_From_Int (num
);
5532 post_error_ne_tree (msg
, node
, ent
, t
);
5535 /* Set the node for a second '&' in the error message. */
5538 set_second_error_entity (e
)
5541 Error_Msg_Node_2
= e
;
5544 /* Signal abort, with "Gigi abort" as the error label, and error_gnat_node
5545 as the relevant node that provides the location info for the error */
5551 String_Template temp
= {1, 10};
5554 fp
.Array
= "Gigi abort", fp
.Bounds
= &temp
;
5556 Current_Error_Node
= error_gnat_node
;
5557 Compiler_Abort (fp
, code
);
5560 /* Initialize the table that maps GNAT codes to GCC codes for simple
5561 binary and unary operations. */
5566 gnu_codes
[N_And_Then
] = TRUTH_ANDIF_EXPR
;
5567 gnu_codes
[N_Or_Else
] = TRUTH_ORIF_EXPR
;
5569 gnu_codes
[N_Op_And
] = TRUTH_AND_EXPR
;
5570 gnu_codes
[N_Op_Or
] = TRUTH_OR_EXPR
;
5571 gnu_codes
[N_Op_Xor
] = TRUTH_XOR_EXPR
;
5572 gnu_codes
[N_Op_Eq
] = EQ_EXPR
;
5573 gnu_codes
[N_Op_Ne
] = NE_EXPR
;
5574 gnu_codes
[N_Op_Lt
] = LT_EXPR
;
5575 gnu_codes
[N_Op_Le
] = LE_EXPR
;
5576 gnu_codes
[N_Op_Gt
] = GT_EXPR
;
5577 gnu_codes
[N_Op_Ge
] = GE_EXPR
;
5578 gnu_codes
[N_Op_Add
] = PLUS_EXPR
;
5579 gnu_codes
[N_Op_Subtract
] = MINUS_EXPR
;
5580 gnu_codes
[N_Op_Multiply
] = MULT_EXPR
;
5581 gnu_codes
[N_Op_Mod
] = FLOOR_MOD_EXPR
;
5582 gnu_codes
[N_Op_Rem
] = TRUNC_MOD_EXPR
;
5583 gnu_codes
[N_Op_Minus
] = NEGATE_EXPR
;
5584 gnu_codes
[N_Op_Abs
] = ABS_EXPR
;
5585 gnu_codes
[N_Op_Not
] = TRUTH_NOT_EXPR
;
5586 gnu_codes
[N_Op_Rotate_Left
] = LROTATE_EXPR
;
5587 gnu_codes
[N_Op_Rotate_Right
] = RROTATE_EXPR
;
5588 gnu_codes
[N_Op_Shift_Left
] = LSHIFT_EXPR
;
5589 gnu_codes
[N_Op_Shift_Right
] = RSHIFT_EXPR
;
5590 gnu_codes
[N_Op_Shift_Right_Arithmetic
] = RSHIFT_EXPR
;